PLASMA  2.4.5
PLASMA - Parallel Linear Algebra for Scalable Multi-core Architectures
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Groups
dchkqr.f
Go to the documentation of this file.
1  SUBROUTINE dchkqr( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
2  $ ibval, nrhs, thresh, tsterr, nmax, a, af, aq,
3  $ ar, ac, b, x, xact, tau, work, rwork, iwork,
4  $ nout )
5 *
6  include 'plasmaf.h'
7 *
8 * -- LAPACK test routine (version 3.1) --
9 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
10 * November 2006
11 *
12 * .. Scalar Arguments ..
13  LOGICAL tsterr
14  INTEGER nm, nmax, nn, nnb, nout, nrhs
15  DOUBLE PRECISION thresh
16 * ..
17 * .. Array Arguments ..
18  LOGICAL dotype( * )
19  INTEGER ibval( * ), iwork( * ), mval( * ), nbval( * ),
20  $ nval( * ), nxval( * )
21  DOUBLE PRECISION a( * ), ac( * ), af( * ), aq( * ), ar( * ),
22  $ b( * ), rwork( * ), tau( * ), work( * ),
23  $ x( * ), xact( * )
24 * ..
25 *
26 * Purpose
27 * =======
28 *
29 * DCHKQR tests DGEQRF, DORGQR and DORMQR.
30 *
31 * Arguments
32 * =========
33 *
34 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
35 * The matrix types to be used for testing. Matrices of type j
36 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
37 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
38 *
39 * NM (input) INTEGER
40 * The number of values of M contained in the vector MVAL.
41 *
42 * MVAL (input) INTEGER array, dimension (NM)
43 * The values of the matrix row dimension M.
44 *
45 * NN (input) INTEGER
46 * The number of values of N contained in the vector NVAL.
47 *
48 * NVAL (input) INTEGER array, dimension (NN)
49 * The values of the matrix column dimension N.
50 *
51 * NNB (input) INTEGER
52 * The number of values of NB and NX contained in the
53 * vectors NBVAL and NXVAL. The blocking parameters are used
54 * in pairs (NB,NX).
55 *
56 * NBVAL (input) INTEGER array, dimension (NNB)
57 * The values of the blocksize NB.
58 *
59 * IBVAL (input) INTEGER array, dimension (NBVAL)
60 * The values of the inner block size IB.
61 *
62 * NXVAL (input) INTEGER array, dimension (NNB)
63 * The values of the crossover point NX.
64 *
65 * NRHS (input) INTEGER
66 * The number of right hand side vectors to be generated for
67 * each linear system.
68 *
69 * THRESH (input) DOUBLE PRECISION
70 * The threshold value for the test ratios. A result is
71 * included in the output file if RESULT >= THRESH. To have
72 * every test ratio printed, use THRESH = 0.
73 *
74 * TSTERR (input) LOGICAL
75 * Flag that indicates whether error exits are to be tested.
76 *
77 * NMAX (input) INTEGER
78 * The maximum value permitted for M or N, used in dimensioning
79 * the work arrays.
80 *
81 * A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
82 *
83 * AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
84 *
85 * AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
86 *
87 * AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
88 *
89 * AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
90 *
91 * B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
92 *
93 * X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
94 *
95 * XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
96 *
97 * TAU (workspace) DOUBLE PRECISION array, dimension (NMAX)
98 *
99 * WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
100 *
101 * RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
102 *
103 * IWORK (workspace) INTEGER array, dimension (NMAX)
104 *
105 * NOUT (input) INTEGER
106 * The unit number for output.
107 *
108 * =====================================================================
109 *
110 * .. Parameters ..
111  INTEGER ntests
112  parameter( ntests = 7 )
113  INTEGER ntypes
114  parameter( ntypes = 8 )
115  DOUBLE PRECISION zero
116  parameter( zero = 0.0d0 )
117 * ..
118 * .. Local Scalars ..
119  CHARACTER dist, type
120  CHARACTER*3 path
121  INTEGER i, ib, ik, im, imat, in, inb, info, k, kl, ku,
122  $ lda, lwork, m, minmn, mode, n, nb, nerrs,
123  $ nfail, nk, nrun, nt, nx, irh, rhblk
124  DOUBLE PRECISION anorm, cndnum
125 * ..
126 * .. Local Arrays ..
127  INTEGER iseed( 4 ), iseedy( 4 ), kval( 4 )
128  DOUBLE PRECISION result( ntests )
129  INTEGER ht( 2 )
130 * ..
131 * .. External Functions ..
132  LOGICAL dgennd
133  EXTERNAL dgennd
134 * ..
135 * .. External Subroutines ..
136  EXTERNAL alaerh, alahd, alasum, derrqr, dget02,
137  $ dlacpy, dlarhs, dlatb4, dlatms, dqrt01, dqrt02,
138  $ dqrt03, xlaenv
139 * ..
140 * .. Intrinsic Functions ..
141  INTRINSIC max, min
142 * ..
143 * .. Scalars in Common ..
144  LOGICAL lerr, ok
145  CHARACTER*32 srnamt
146  INTEGER infot, nunit
147 * ..
148 * .. Common blocks ..
149  common / infoc / infot, nunit, ok, lerr
150  common / srnamc / srnamt
151 * ..
152 * .. Data statements ..
153  DATA iseedy / 1988, 1989, 1990, 1991 /
154 * ..
155 * .. Executable Statements ..
156 *
157 * Initialize constants and the random number seed.
158 *
159  rhblk = 4
160  path( 1: 1 ) = 'Double precision'
161  path( 2: 3 ) = 'QR'
162  nrun = 0
163  nfail = 0
164  nerrs = 0
165  DO 10 i = 1, 4
166  iseed( i ) = iseedy( i )
167  10 continue
168 *
169 * Test the error exits
170 *
171  IF( tsterr )
172  $ CALL derrqr( path, nout )
173  infot = 0
174  CALL xlaenv( 2, 2 )
175 *
176  lda = nmax
177  lwork = nmax*max( nmax, nrhs )
178 *
179 * Do for each value of M in MVAL.
180 *
181  DO 70 im = 1, nm
182  m = mval( im )
183 *
184 * Do for each value of N in NVAL.
185 *
186  DO 60 in = 1, nn
187  n = nval( in )
188  IF ( m.LT.n )
189  $ go to 60
190  minmn = min( m, n )
191 *
192  DO 50 imat = 1, ntypes
193 *
194 * Do the tests only if DOTYPE( IMAT ) is true.
195 *
196  IF( .NOT.dotype( imat ) )
197  $ go to 50
198 *
199 * Set up parameters with DLATB4 and generate a test matrix
200 * with DLATMS.
201 *
202  CALL dlatb4( path, imat, m, n, type, kl, ku, anorm, mode,
203  $ cndnum, dist )
204 *
205  srnamt = 'DLATMS'
206  CALL dlatms( m, n, dist, iseed, type, rwork, mode,
207  $ cndnum, anorm, kl, ku, 'No packing', a, lda,
208  $ work, info )
209 *
210 * Check error code from DLATMS.
211 *
212  IF( info.NE.0 ) THEN
213  CALL alaerh( path, 'DLATMS', info, 0, ' ', m, n, -1,
214  $ -1, -1, imat, nfail, nerrs, nout )
215  go to 50
216  END IF
217 *
218 * Set some values for K: the first value must be MINMN,
219 * corresponding to the call of DQRT01; other values are
220 * used in the calls of DQRT02, and must not exceed MINMN.
221 *
222  kval( 1 ) = minmn
223  kval( 2 ) = 0
224  kval( 3 ) = 1
225  kval( 4 ) = minmn / 2
226  IF( minmn.EQ.0 ) THEN
227  nk = 1
228  ELSE IF( minmn.EQ.1 ) THEN
229  nk = 2
230  ELSE IF( minmn.LE.3 ) THEN
231  nk = 3
232  ELSE
233  nk = 4
234  END IF
235 *
236 * Set Householder mode (tree or flat)
237 *
238  DO 45 irh = 0, 1
239  IF (irh .EQ. 0) THEN
240  CALL plasma_set(plasma_householder_mode,
241  $ plasma_flat_householder, info )
242  ELSE
243  CALL plasma_set(plasma_householder_mode,
244  $ plasma_tree_householder, info )
245  CALL plasma_set(plasma_householder_size,
246  $ rhblk, info)
247  END IF
248 *
249 * Do for each value of K in KVAL
250 *
251  DO 40 ik = 1, 2
252  k = kval( ik )
253 *
254 * Do for each pair of values (NB,NX) in NBVAL and NXVAL.
255 *
256  DO 30 inb = 1, nnb
257  nb = nbval( inb )
258  ib = ibval( inb )
259  CALL xlaenv( 1, nb )
260  nx = nxval( inb )
261  CALL xlaenv( 3, nx )
262  IF ( (max(m, n) / 10) .GT. nb ) THEN
263  goto 30
264  END IF
265  CALL plasma_set( plasma_tile_size, nb, info )
266  CALL plasma_set( plasma_inner_block_size, ib, info)
267 *
268 * Allocate HT
269 *
270  CALL plasma_alloc_workspace_dgeqrf( m, n, ht,
271  $ info )
272 *
273  DO i = 1, ntests
274  result( i ) = zero
275  END DO
276  nt = 2
277  IF( ik.EQ.1 ) THEN
278 *
279 * Test DGEQRF
280 *
281  CALL dqrt01( m, n, a, af, aq, ar, lda, ht,
282  $ work, lwork, rwork, result( 1 ) )
283 * IF( .NOT.DGENND( M, N, AF, LDA ) )
284 * $ RESULT( 8 ) = 2*THRESH
285 * NT = NT + 1
286  ELSE IF( m.GE.n ) THEN
287 *
288 * Test DORGQR, using factorization
289 * returned by DQRT01
290 
291  CALL dqrt02( m, n, k, a, af, aq, ar, lda, ht,
292  $ work, lwork, rwork, result( 1 ) )
293  END IF
294  IF( m.GE.k ) THEN
295 *
296 * Test DORMQR, using factorization returned
297 * by DQRT01
298 *
299  CALL dqrt03( m, n, k, af, ac, ar, aq, lda, ht,
300  $ work, lwork, rwork, result( 3 ) )
301  nt = nt + 4
302 *
303 * If M>=N and K=N, call DGEQRS to solve a system
304 * with NRHS right hand sides and compute the
305 * residual.
306 *
307  IF( k.EQ.n .AND. inb.EQ.1 ) THEN
308 *
309 * Generate a solution and set the right
310 * hand side.
311 *
312  srnamt = 'DLARHS'
313  CALL dlarhs( path, 'New', 'Full',
314  $ 'No transpose', m, n, 0, 0,
315  $ nrhs, a, lda, xact, lda, b, lda,
316  $ iseed, info )
317 *
318  CALL dlacpy( 'Full', m, nrhs, b, lda, x,
319  $ lda )
320  srnamt = 'DGEQRS'
321  CALL plasma_dgeqrs( m, n, nrhs, af, lda, ht,
322  $ x, lda, info )
323 
324 * Check error code from DGEQRS.
325 *
326  IF( info.NE.0 )
327  $ CALL alaerh( path, 'DGEQRS', info, 0, ' ',
328  $ m, n, nrhs, -1, nb, imat,
329  $ nfail, nerrs, nout )
330 *
331  CALL dget02( 'No transpose', m, n, nrhs, a,
332  $ lda, x, lda, b, lda, rwork,
333  $ result( 7 ) )
334  nt = nt + 1
335  END IF
336  END IF
337 *
338 * Print information about the tests that did not
339 * pass the threshold.
340 *
341  DO 20 i = 1, nt
342  IF( result( i ).GE.thresh ) THEN
343  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
344  $ CALL alahd( nout, path )
345  WRITE( nout, fmt = 9999 )m, n, k, nb, ib, nx,
346  $ imat, i, result( i )
347  nfail = nfail + 1
348  END IF
349  20 continue
350  nrun = nrun + nt
351 *
352 * Deallocate T
353 *
354  CALL plasma_dealloc_handle( ht, info )
355  30 continue
356  40 continue
357  45 continue
358  50 continue
359  60 continue
360  70 continue
361 *
362 * Print a summary of the results.
363 *
364  CALL alasum( path, nout, nfail, nrun, nerrs )
365 *
366  9999 format( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', IB=',
367  $ i4, ', NX=', i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
368  return
369 *
370 * End of DCHKQR
371 *
372  END