SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
pzblas3tst.f
Go to the documentation of this file.
1 BLOCK DATA
2 INTEGER NSUBS
3 parameter(nsubs = 11)
4 CHARACTER*7 SNAMES( NSUBS )
5 COMMON /snamec/snames
6 DATA snames/'PZGEMM ', 'PZSYMM ', 'PZHEMM ',
7 $ 'PZSYRK ', 'PZHERK ', 'PZSYR2K',
8 $ 'PZHER2K', 'PZTRMM ', 'PZTRSM ',
9 $ 'PZGEADD', 'PZTRADD'/
10 END BLOCK DATA
11
12 PROGRAM pzbla3tst
13*
14* -- PBLAS testing driver (version 2.0.2) --
15* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
16* May 1 2012
17*
18* Purpose
19* =======
20*
21* PZBLA3TST is the main testing program for the Level 3 PBLAS routines.
22*
23* The program must be driven by a short data file. An annotated exam-
24* ple of a data file can be obtained by deleting the first 3 characters
25*
26* from the following 64 lines:
27* 'Level 3 PBLAS, Testing input file'
28* 'Intel iPSC/860 hypercube, gamma model.'
29* 'PZBLAS3TST.SUMM' output file name (if any)
30* 6 device out
31* F logical flag, T to stop on failures
32* F logical flag, T to test error exits
33* 0 verbosity, 0 for pass/fail, 1-3 for matrix dump on errors
34* 10 the leading dimension gap
35* 16.0 threshold value of test ratio
36* 10 value of the logical computational blocksize NB
37* 1 number of process grids (ordered pairs of P & Q)
38* 2 2 1 4 2 3 8 values of P
39* 2 2 4 1 3 2 1 values of Q
40* (1.0D0, 0.0D0) value of ALPHA
41* (1.0D0, 0.0D0) value of BETA
42* 2 number of tests problems
43* 'N' 'U' values of DIAG
44* 'L' 'R' values of SIDE
45* 'N' 'T' values of TRANSA
46* 'N' 'T' values of TRANSB
47* 'U' 'L' values of UPLO
48* 3 4 values of M
49* 3 4 values of N
50* 3 4 values of K
51* 6 10 values of M_A
52* 6 10 values of N_A
53* 2 5 values of IMB_A
54* 2 5 values of INB_A
55* 2 5 values of MB_A
56* 2 5 values of NB_A
57* 0 1 values of RSRC_A
58* 0 0 values of CSRC_A
59* 1 1 values of IA
60* 1 1 values of JA
61* 6 10 values of M_B
62* 6 10 values of N_B
63* 2 5 values of IMB_B
64* 2 5 values of INB_B
65* 2 5 values of MB_B
66* 2 5 values of NB_B
67* 0 1 values of RSRC_B
68* 0 0 values of CSRC_B
69* 1 1 values of IB
70* 1 1 values of JB
71* 6 10 values of M_C
72* 6 10 values of N_C
73* 2 5 values of IMB_C
74* 2 5 values of INB_C
75* 2 5 values of MB_C
76* 2 5 values of NB_C
77* 0 1 values of RSRC_C
78* 0 0 values of CSRC_C
79* 1 1 values of IC
80* 1 1 values of JC
81* PZGEMM T put F for no test in the same column
82* PZSYMM T put F for no test in the same column
83* PZHEMM T put F for no test in the same column
84* PZSYRK T put F for no test in the same column
85* PZHERK T put F for no test in the same column
86* PZSYR2K T put F for no test in the same column
87* PZHER2K T put F for no test in the same column
88* PZTRMM T put F for no test in the same column
89* PZTRSM T put F for no test in the same column
90* PZGEADD T put F for no test in the same column
91* PZTRADD T put F for no test in the same column
92*
93* Internal Parameters
94* ===================
95*
96* TOTMEM INTEGER
97* TOTMEM is a machine-specific parameter indicating the maxi-
98* mum amount of available memory per process in bytes. The
99* user should customize TOTMEM to his platform. Remember to
100* leave room in memory for the operating system, the BLACS
101* buffer, etc. For example, on a system with 8 MB of memory
102* per process (e.g., one processor on an Intel iPSC/860), the
103* parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS,
104* code, BLACS buffer, etc). However, for PVM, we usually set
105* TOTMEM = 2000000. Some experimenting with the maximum value
106* of TOTMEM may be required. By default, TOTMEM is 2000000.
107*
108* DBLESZ INTEGER
109* ZPLXSZ INTEGER
110* DBLESZ and ZPLXSZ indicate the length in bytes on the given
111* platform for a double precision real and a double precision
112* complex. By default, DBLESZ is set to eight and ZPLXSZ is set
113* to sixteen.
114*
115* MEM COMPLEX*16 array
116* MEM is an array of dimension TOTMEM / ZPLXSZ.
117* All arrays used by SCALAPACK routines are allocated from this
118* array MEM and referenced by pointers. The integer IPA, for
119* example, is a pointer to the starting element of MEM for the
120* matrix A.
121*
122* -- Written on April 1, 1998 by
123* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
124*
125* =====================================================================
126*
127* .. Parameters ..
128 INTEGER maxtests, maxgrids, gapmul, zplxsz, totmem,
129 $ memsiz, nsubs, dblesz
130 COMPLEX*16 one, padval, zero, rogue
131 parameter( maxtests = 20, maxgrids = 20, gapmul = 10,
132 $ zplxsz = 16, totmem = 2000000,
133 $ memsiz = totmem / zplxsz, dblesz = 8,
134 $ padval = ( -9923.0d+0, -9923.0d+0 ),
135 $ zero = ( 0.0d+0, 0.0d+0 ),
136 $ rogue = ( -1.0d+10, 1.0d+10 ),
137 $ one = ( 1.0d+0, 0.0d+0 ), nsubs = 11 )
138 INTEGER block_cyclic_2d_inb, csrc_, ctxt_, dlen_,
139 $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
140 $ rsrc_
141 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
142 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
143 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
144 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
145* ..
146* .. Local Scalars ..
147 LOGICAL errflg, sof, tee
148 CHARACTER*1 adiagdo, aform, cform, diag, side, transa,
149 $ transb, uplo
150 INTEGER csrca, csrcb, csrcc, i, ia, iam, iaseed, ib,
151 $ ibseed, ic, icseed, ictxt, igap, imba, imbb,
152 $ imbc, imida, imidb, imidc, inba, inbb, inbc,
153 $ ipa, ipb, ipc, ipg, ipmata, ipmatb, ipmatc,
154 $ iposta, ipostb, ipostc, iprea, ipreb, iprec,
155 $ ipw, iverb, j, ja, jb, jc, k, l, lda, ldb, ldc,
156 $ m, ma, mb, mba, mbb, mbc, mc, memreqd, mpa,
157 $ mpb, mpc, mycol, myrow, n, na, nb, nba, nbb,
158 $ nbc, nc, ncola, ncolb, ncolc, ngrids, nout,
159 $ npcol, nprocs, nprow, nqa, nqb, nqc, nrowa,
160 $ nrowb, nrowc, ntests, offda, offdc, rsrca,
161 $ rsrcb, rsrcc, tskip, tstcnt
162 REAL thresh
163 COMPLEX*16 alpha, beta, scale
164* ..
165* .. Local Arrays ..
166 LOGICAL bcheck( nsubs ), ccheck( nsubs ),
167 $ ltest( nsubs )
168 CHARACTER*1 diagval( maxtests ), sideval( maxtests ),
169 $ trnaval( maxtests ), trnbval( maxtests ),
170 $ uploval( maxtests )
171 CHARACTER*80 outfile
172 INTEGER cscaval( maxtests ), cscbval( maxtests ),
173 $ csccval( maxtests ), desca( dlen_ ),
174 $ descar( dlen_ ), descb( dlen_ ),
175 $ descbr( dlen_ ), descc( dlen_ ),
176 $ desccr( dlen_ ), iaval( maxtests ),
177 $ ibval( maxtests ), icval( maxtests ),
178 $ ierr( 6 ), imbaval( maxtests ),
179 $ imbbval( maxtests ), imbcval( maxtests ),
180 $ inbaval( maxtests ), inbbval( maxtests ),
181 $ inbcval( maxtests ), javal( maxtests ),
182 $ jbval( maxtests ), jcval( maxtests )
183 INTEGER kfail( nsubs ), kpass( nsubs ), kskip( nsubs ),
184 $ ktests( nsubs ), kval( maxtests ),
185 $ maval( maxtests ), mbaval( maxtests ),
186 $ mbbval( maxtests ), mbcval( maxtests ),
187 $ mbval( maxtests ), mcval( maxtests ),
188 $ mval( maxtests ), naval( maxtests ),
189 $ nbaval( maxtests ), nbbval( maxtests ),
190 $ nbcval( maxtests ), nbval( maxtests ),
191 $ ncval( maxtests ), nval( maxtests ),
192 $ pval( maxtests ), qval( maxtests ),
193 $ rscaval( maxtests ), rscbval( maxtests ),
194 $ rsccval( maxtests )
195 COMPLEX*16 mem( memsiz )
196* ..
197* .. External Subroutines ..
198 EXTERNAL blacs_exit, blacs_get, blacs_gridexit,
199 $ blacs_gridinfo, blacs_gridinit, blacs_pinfo,
200 $ igsum2d, pb_descset2, pb_pzlaprnt, pb_zchekpad,
201 $ pb_zfillpad, pb_zlascal, pb_zlaset, pmdescchk,
202 $ pmdimchk, pzbla3tstinfo, pzblas3tstchk,
203 $ pzblas3tstchke, pzchkarg3, pzchkmout, pzgeadd,
204 $ pzgemm, pzhemm, pzher2k, pzherk, pzipset,
205 $ pzlagen, pzlascal, pzlaset, pzmprnt, pzsymm,
206 $ pzsyr2k, pzsyrk, pztradd, pztrmm, pztrsm
207* ..
208* .. External Functions ..
209 LOGICAL lsame
210 INTEGER pb_fceil
211 EXTERNAL pb_fceil, lsame
212* ..
213* .. Intrinsic Functions ..
214 INTRINSIC abs, dble, dcmplx, max, mod, real
215* ..
216* .. Common Blocks ..
217 CHARACTER*7 snames( nsubs )
218 LOGICAL abrtflg
219 INTEGER info, nblog
220 COMMON /snamec/snames
221 COMMON /infoc/info, nblog
222 COMMON /pberrorc/nout, abrtflg
223* ..
224* .. Data Statements ..
225 DATA bcheck/.true., .true., .true., .false.,
226 $ .false., .true., .true., .true., .true.,
227 $ .false., .false./
228 DATA ccheck/.true., .true., .true., .true., .true.,
229 $ .true., .true., .false., .false., .true.,
230 $ .true./
231* ..
232* .. Executable Statements ..
233*
234* Initialization
235*
236* Set flag so that the PBLAS error handler won't abort on errors,
237* so that the tester will detect unsupported operations.
238*
239 abrtflg = .false.
240*
241* So far no error, will become true as soon as one error is found.
242*
243 errflg = .false.
244*
245* Test counters
246*
247 tskip = 0
248 tstcnt = 0
249*
250* Seeds for random matrix generations.
251*
252 iaseed = 100
253 ibseed = 200
254 icseed = 300
255*
256* So far no tests have been performed.
257*
258 DO 10 i = 1, nsubs
259 kpass( i ) = 0
260 kskip( i ) = 0
261 kfail( i ) = 0
262 ktests( i ) = 0
263 10 CONTINUE
264*
265* Get starting information
266*
267 CALL blacs_pinfo( iam, nprocs )
268 CALL pzbla3tstinfo( outfile, nout, ntests, diagval, sideval,
269 $ trnaval, trnbval, uploval, mval, nval,
270 $ kval, maval, naval, imbaval, mbaval,
271 $ inbaval, nbaval, rscaval, cscaval, iaval,
272 $ javal, mbval, nbval, imbbval, mbbval,
273 $ inbbval, nbbval, rscbval, cscbval, ibval,
274 $ jbval, mcval, ncval, imbcval, mbcval,
275 $ inbcval, nbcval, rsccval, csccval, icval,
276 $ jcval, maxtests, ngrids, pval, maxgrids,
277 $ qval, maxgrids, nblog, ltest, sof, tee, iam,
278 $ igap, iverb, nprocs, thresh, alpha, beta,
279 $ mem )
280*
281 IF( iam.EQ.0 ) THEN
282 WRITE( nout, fmt = 9976 )
283 WRITE( nout, fmt = * )
284 END IF
285*
286* If TEE is set then Test Error Exits of routines.
287*
288 IF( tee )
289 $ CALL pzblas3tstchke( ltest, nout, nprocs )
290*
291* Loop over different process grids
292*
293 DO 60 i = 1, ngrids
294*
295 nprow = pval( i )
296 npcol = qval( i )
297*
298* Make sure grid information is correct
299*
300 ierr( 1 ) = 0
301 IF( nprow.LT.1 ) THEN
302 IF( iam.EQ.0 )
303 $ WRITE( nout, fmt = 9999 ) 'GRID SIZE', 'NPROW', nprow
304 ierr( 1 ) = 1
305 ELSE IF( npcol.LT.1 ) THEN
306 IF( iam.EQ.0 )
307 $ WRITE( nout, fmt = 9999 ) 'GRID SIZE', 'NPCOL', npcol
308 ierr( 1 ) = 1
309 ELSE IF( nprow*npcol.GT.nprocs ) THEN
310 IF( iam.EQ.0 )
311 $ WRITE( nout, fmt = 9998 ) nprow*npcol, nprocs
312 ierr( 1 ) = 1
313 END IF
314*
315 IF( ierr( 1 ).GT.0 ) THEN
316 IF( iam.EQ.0 )
317 $ WRITE( nout, fmt = 9997 ) 'GRID'
318 tskip = tskip + 1
319 GO TO 60
320 END IF
321*
322* Define process grid
323*
324 CALL blacs_get( -1, 0, ictxt )
325 CALL blacs_gridinit( ictxt, 'Row-major', nprow, npcol )
326 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
327*
328* Go to bottom of process grid loop if this case doesn't use my
329* process
330*
331 IF( myrow.GE.nprow .OR. mycol.GE.npcol )
332 $ GO TO 60
333*
334* Loop over number of tests
335*
336 DO 50 j = 1, ntests
337*
338* Get the test parameters
339*
340 diag = diagval( j )
341 side = sideval( j )
342 transa = trnaval( j )
343 transb = trnbval( j )
344 uplo = uploval( j )
345*
346 m = mval( j )
347 n = nval( j )
348 k = kval( j )
349*
350 ma = maval( j )
351 na = naval( j )
352 imba = imbaval( j )
353 mba = mbaval( j )
354 inba = inbaval( j )
355 nba = nbaval( j )
356 rsrca = rscaval( j )
357 csrca = cscaval( j )
358 ia = iaval( j )
359 ja = javal( j )
360*
361 mb = mbval( j )
362 nb = nbval( j )
363 imbb = imbbval( j )
364 mbb = mbbval( j )
365 inbb = inbbval( j )
366 nbb = nbbval( j )
367 rsrcb = rscbval( j )
368 csrcb = cscbval( j )
369 ib = ibval( j )
370 jb = jbval( j )
371*
372 mc = mcval( j )
373 nc = ncval( j )
374 imbc = imbcval( j )
375 mbc = mbcval( j )
376 inbc = inbcval( j )
377 nbc = nbcval( j )
378 rsrcc = rsccval( j )
379 csrcc = csccval( j )
380 ic = icval( j )
381 jc = jcval( j )
382*
383 IF( iam.EQ.0 ) THEN
384*
385 tstcnt = tstcnt + 1
386*
387 WRITE( nout, fmt = * )
388 WRITE( nout, fmt = 9996 ) tstcnt, nprow, npcol
389 WRITE( nout, fmt = * )
390*
391 WRITE( nout, fmt = 9995 )
392 WRITE( nout, fmt = 9994 )
393 WRITE( nout, fmt = 9995 )
394 WRITE( nout, fmt = 9993 ) m, n, k, side, uplo, transa,
395 $ transb, diag
396*
397 WRITE( nout, fmt = 9995 )
398 WRITE( nout, fmt = 9992 )
399 WRITE( nout, fmt = 9995 )
400 WRITE( nout, fmt = 9991 ) ia, ja, ma, na, imba, inba,
401 $ mba, nba, rsrca, csrca
402*
403 WRITE( nout, fmt = 9995 )
404 WRITE( nout, fmt = 9990 )
405 WRITE( nout, fmt = 9995 )
406 WRITE( nout, fmt = 9991 ) ib, jb, mb, nb, imbb, inbb,
407 $ mbb, nbb, rsrcb, csrcb
408*
409 WRITE( nout, fmt = 9995 )
410 WRITE( nout, fmt = 9989 )
411 WRITE( nout, fmt = 9995 )
412 WRITE( nout, fmt = 9991 ) ic, jc, mc, nc, imbc, inbc,
413 $ mbc, nbc, rsrcc, csrcc
414*
415 WRITE( nout, fmt = 9995 )
416*
417 END IF
418*
419* Check the validity of the input test parameters
420*
421 IF( .NOT.lsame( side, 'L' ).AND.
422 $ .NOT.lsame( side, 'R' ) ) THEN
423 IF( iam.EQ.0 )
424 $ WRITE( nout, fmt = 9997 ) 'SIDE'
425 tskip = tskip + 1
426 GO TO 40
427 END IF
428*
429 IF( .NOT.lsame( uplo, 'U' ).AND.
430 $ .NOT.lsame( uplo, 'L' ) ) THEN
431 IF( iam.EQ.0 )
432 $ WRITE( nout, fmt = 9997 ) 'UPLO'
433 tskip = tskip + 1
434 GO TO 40
435 END IF
436*
437 IF( .NOT.lsame( transa, 'N' ).AND.
438 $ .NOT.lsame( transa, 'T' ).AND.
439 $ .NOT.lsame( transa, 'C' ) ) THEN
440 IF( iam.EQ.0 )
441 $ WRITE( nout, fmt = 9997 ) 'TRANSA'
442 tskip = tskip + 1
443 GO TO 40
444 END IF
445*
446 IF( .NOT.lsame( transb, 'N' ).AND.
447 $ .NOT.lsame( transb, 'T' ).AND.
448 $ .NOT.lsame( transb, 'C' ) ) THEN
449 IF( iam.EQ.0 )
450 $ WRITE( nout, fmt = 9997 ) 'TRANSB'
451 tskip = tskip + 1
452 GO TO 40
453 END IF
454*
455 IF( .NOT.lsame( diag , 'U' ).AND.
456 $ .NOT.lsame( diag , 'N' ) )THEN
457 IF( iam.EQ.0 )
458 $ WRITE( nout, fmt = 9997 ) 'DIAG'
459 tskip = tskip + 1
460 GO TO 40
461 END IF
462*
463* Check and initialize the matrix descriptors
464*
465 CALL pmdescchk( ictxt, nout, 'A', desca,
466 $ block_cyclic_2d_inb, ma, na, imba, inba,
467 $ mba, nba, rsrca, csrca, mpa, nqa, iprea,
468 $ imida, iposta, igap, gapmul, ierr( 1 ) )
469*
470 CALL pmdescchk( ictxt, nout, 'B', descb,
471 $ block_cyclic_2d_inb, mb, nb, imbb, inbb,
472 $ mbb, nbb, rsrcb, csrcb, mpb, nqb, ipreb,
473 $ imidb, ipostb, igap, gapmul, ierr( 2 ) )
474*
475 CALL pmdescchk( ictxt, nout, 'C', descc,
476 $ block_cyclic_2d_inb, mc, nc, imbc, inbc,
477 $ mbc, nbc, rsrcc, csrcc, mpc, nqc, iprec,
478 $ imidc, ipostc, igap, gapmul, ierr( 3 ) )
479*
480 IF( ierr( 1 ).GT.0 .OR. ierr( 2 ).GT.0 .OR.
481 $ ierr( 3 ).GT.0 ) THEN
482 tskip = tskip + 1
483 GO TO 40
484 END IF
485*
486 lda = max( 1, ma )
487 ldb = max( 1, mb )
488 ldc = max( 1, mc )
489*
490* Assign pointers into MEM for matrices corresponding to
491* the distributed matrices A, X and Y.
492*
493 ipa = iprea + 1
494 ipb = ipa + desca( lld_ )*nqa + iposta + ipreb
495 ipc = ipb + descb( lld_ )*nqb + ipostb + iprec
496 ipmata = ipc + descc( lld_ )*nqc + ipostc
497 ipmatb = ipmata + ma*na
498 ipmatc = ipmatb + mb*nb
499 ipg = ipmatc + max( mb*nb, mc*nc )
500*
501* Check if sufficient memory.
502* Requirement = mem for local part of parallel matrices +
503* mem for whole matrices for comp. check +
504* mem for recving comp. check error vals.
505*
506 ipw = ipg + max( max( max( imba, mba ),
507 $ max( imbb, mbb ) ),
508 $ max( imbc, mbc ) ) + max( m, max( n, k ) )
509 memreqd = ipw + pb_fceil( real( max( m, max( n, k ) ) ) *
510 $ real( dblesz ), real( zplxsz ) ) - 1
511 ierr( 1 ) = 0
512 IF( memreqd.GT.memsiz ) THEN
513 IF( iam.EQ.0 )
514 $ WRITE( nout, fmt = 9987 ) memreqd*zplxsz
515 ierr( 1 ) = 1
516 END IF
517*
518* Check all processes for an error
519*
520 CALL igsum2d( ictxt, 'All', ' ', 1, 1, ierr, 1, -1, 0 )
521*
522 IF( ierr( 1 ).GT.0 ) THEN
523 IF( iam.EQ.0 )
524 $ WRITE( nout, fmt = 9988 )
525 tskip = tskip + 1
526 GO TO 40
527 END IF
528*
529* Loop over all PBLAS 3 routines
530*
531 DO 30 l = 1, nsubs
532*
533* Continue only if this subroutine has to be tested.
534*
535 IF( .NOT.ltest( l ) )
536 $ GO TO 30
537*
538 IF( iam.EQ.0 ) THEN
539 WRITE( nout, fmt = * )
540 WRITE( nout, fmt = 9986 ) snames( l )
541 END IF
542*
543* Define the size of the operands
544*
545 IF( l.EQ.1 ) THEN
546*
547* PZGEMM
548*
549 nrowc = m
550 ncolc = n
551 IF( lsame( transa, 'N' ) ) THEN
552 nrowa = m
553 ncola = k
554 ELSE
555 nrowa = k
556 ncola = m
557 END IF
558 IF( lsame( transb, 'N' ) ) THEN
559 nrowb = k
560 ncolb = n
561 ELSE
562 nrowb = n
563 ncolb = k
564 END IF
565*
566 ELSE IF( l.EQ.2 .OR. l.EQ.3 ) THEN
567*
568* PZSYMM, PZHEMM
569*
570 nrowc = m
571 ncolc = n
572 nrowb = m
573 ncolb = n
574 IF( lsame( side, 'L' ) ) THEN
575 nrowa = m
576 ncola = m
577 ELSE
578 nrowa = n
579 ncola = n
580 END IF
581*
582 ELSE IF( l.EQ.4 .OR. l.EQ.5 ) THEN
583*
584* PZSYRK, PZHERK
585*
586 nrowc = n
587 ncolc = n
588 IF( lsame( transa, 'N' ) ) THEN
589 nrowa = n
590 ncola = k
591 ELSE
592 nrowa = k
593 ncola = n
594 END IF
595 nrowb = 0
596 ncolb = 0
597*
598 ELSE IF( l.EQ.6 .OR. l.EQ.7 ) THEN
599*
600* PZSYR2K, PZHER2K
601*
602 nrowc = n
603 ncolc = n
604 IF( lsame( transa, 'N' ) ) THEN
605 nrowa = n
606 ncola = k
607 nrowb = n
608 ncolb = k
609 ELSE
610 nrowa = k
611 ncola = n
612 nrowb = k
613 ncolb = n
614 END IF
615*
616 ELSE IF( l.EQ.8 .OR. l.EQ.9 ) THEN
617 nrowb = m
618 ncolb = n
619 IF( lsame( side, 'L' ) ) THEN
620 nrowa = m
621 ncola = m
622 ELSE
623 nrowa = n
624 ncola = n
625 END IF
626 nrowc = 0
627 ncolc = 0
628*
629 ELSE IF( l.EQ.10 .OR. l.EQ.11 ) THEN
630*
631* PZGEADD, PZTRADD
632*
633 IF( lsame( transa, 'N' ) ) THEN
634 nrowa = m
635 ncola = n
636 ELSE
637 nrowa = n
638 ncola = m
639 END IF
640 nrowc = m
641 ncolc = n
642 nrowb = 0
643 ncolb = 0
644*
645 END IF
646*
647* Check the validity of the operand sizes
648*
649 CALL pmdimchk( ictxt, nout, nrowa, ncola, 'A', ia, ja,
650 $ desca, ierr( 1 ) )
651 CALL pmdimchk( ictxt, nout, nrowb, ncolb, 'B', ib, jb,
652 $ descb, ierr( 2 ) )
653 CALL pmdimchk( ictxt, nout, nrowc, ncolc, 'C', ic, jc,
654 $ descc, ierr( 3 ) )
655*
656 IF( ierr( 1 ).NE.0 .OR. ierr( 2 ).NE.0 .OR.
657 $ ierr( 3 ).NE.0 ) THEN
658 kskip( l ) = kskip( l ) + 1
659 GO TO 30
660 END IF
661*
662* Check special values of TRANSA for symmetric and
663* hermitian rank-k and rank-2k updates.
664*
665 IF( l.EQ.4 .OR. l.EQ.6 ) THEN
666 IF( .NOT.lsame( transa, 'N' ).AND.
667 $ .NOT.lsame( transa, 'T' ) ) THEN
668 IF( iam.EQ.0 )
669 $ WRITE( nout, fmt = 9975 ) 'TRANSA'
670 kskip( l ) = kskip( l ) + 1
671 GO TO 30
672 END IF
673 ELSE IF( l.EQ.5 .OR. l.EQ.7 ) THEN
674 IF( .NOT.lsame( transa, 'N' ).AND.
675 $ .NOT.lsame( transa, 'C' ) ) THEN
676 IF( iam.EQ.0 )
677 $ WRITE( nout, fmt = 9975 ) 'TRANSA'
678 kskip( l ) = kskip( l ) + 1
679 GO TO 30
680 END IF
681 END IF
682*
683* Generate distributed matrices A, B and C
684*
685 IF( l.EQ.2 ) THEN
686*
687* PZSYMM
688*
689 aform = 'S'
690 adiagdo = 'N'
691 offda = ia - ja
692 cform = 'N'
693 offdc = 0
694*
695 ELSE IF( l.EQ.3 ) THEN
696*
697* PZHEMM
698*
699 aform = 'H'
700 adiagdo = 'N'
701 offda = ia - ja
702 cform = 'N'
703 offdc = 0
704*
705 ELSE IF( l.EQ.4 .OR. l.EQ.6 ) THEN
706*
707* PZSYRK, PZSYR2K
708*
709 aform = 'N'
710 adiagdo = 'N'
711 offda = 0
712 cform = 'S'
713 offdc = ic - jc
714*
715 ELSE IF( l.EQ.5 .OR. l.EQ.7 ) THEN
716*
717* PZHERK, PZHER2K
718*
719 aform = 'N'
720 adiagdo = 'N'
721 offda = 0
722 cform = 'H'
723 offdc = ic - jc
724*
725 ELSE IF( ( l.EQ.9 ).AND.( lsame( diag, 'N' ) ) ) THEN
726*
727* PZTRSM
728*
729 aform = 'N'
730 adiagdo = 'D'
731 offda = ia - ja
732 cform = 'N'
733 offdc = 0
734*
735 ELSE
736*
737* Default values
738*
739 aform = 'N'
740 adiagdo = 'N'
741 offda = 0
742 cform = 'N'
743 offdc = 0
744*
745 END IF
746*
747 CALL pzlagen( .false., aform, adiagdo, offda, ma, na,
748 $ 1, 1, desca, iaseed, mem( ipa ),
749 $ desca( lld_ ) )
750*
751 IF( bcheck( l ) )
752 $ CALL pzlagen( .false., 'None', 'No diag', 0, mb, nb,
753 $ 1, 1, descb, ibseed, mem( ipb ),
754 $ descb( lld_ ) )
755*
756 IF( ccheck( l ) )
757 $ CALL pzlagen( .false., cform, 'No diag', offdc, mc,
758 $ nc, 1, 1, descc, icseed, mem( ipc ),
759 $ descc( lld_ ) )
760*
761* Generate entire matrices on each process.
762*
763 CALL pb_descset2( descar, ma, na, imba, inba, mba, nba,
764 $ -1, -1, ictxt, max( 1, ma ) )
765 CALL pzlagen( .false., aform, adiagdo, offda, ma, na,
766 $ 1, 1, descar, iaseed, mem( ipmata ),
767 $ descar( lld_ ) )
768*
769 IF( bcheck( l ) ) THEN
770 CALL pb_descset2( descbr, mb, nb, imbb, inbb, mbb,
771 $ nbb, -1, -1, ictxt, max( 1, mb ) )
772 CALL pzlagen( .false., 'None', 'No diag', 0, mb, nb,
773 $ 1, 1, descbr, ibseed, mem( ipmatb ),
774 $ descbr( lld_ ) )
775 END IF
776*
777 IF( ccheck( l ) ) THEN
778*
779 CALL pb_descset2( desccr, mc, nc, imbc, inbc, mbc,
780 $ nbc, -1, -1, ictxt, max( 1, mc ) )
781 CALL pzlagen( .false., cform, 'No diag', offdc, mc,
782 $ nc, 1, 1, desccr, icseed, mem( ipmatc ),
783 $ desccr( lld_ ) )
784*
785 ELSE
786*
787* If C is not needed, generate a copy of B instead
788*
789 CALL pb_descset2( desccr, mb, nb, imbb, inbb, mbb,
790 $ nbb, -1, -1, ictxt, max( 1, mb ) )
791 CALL pzlagen( .false., 'None', 'No diag', 0, mb, nb,
792 $ 1, 1, desccr, ibseed, mem( ipmatc ),
793 $ desccr( lld_ ) )
794*
795 END IF
796*
797* Zero non referenced part of the matrices A, B, C
798*
799 IF( ( ( l.EQ.2 ).OR. ( l.EQ.3 ) ).AND.
800 $ ( max( nrowa, ncola ).GT.1 ) ) THEN
801*
802* The distributed matrix A is symmetric or Hermitian
803*
804 IF( lsame( uplo, 'L' ) ) THEN
805*
806* Zeros the strict upper triangular part of A.
807*
808 CALL pzlaset( 'Upper', nrowa-1, ncola-1, rogue,
809 $ rogue, mem( ipa ), ia, ja+1, desca )
810*
811 ELSE IF( lsame( uplo, 'U' ) ) THEN
812*
813* Zeros the strict lower triangular part of A.
814*
815 CALL pzlaset( 'Lower', nrowa-1, ncola-1, rogue,
816 $ rogue, mem( ipa ), ia+1, ja, desca )
817*
818 END IF
819*
820 ELSE IF( ( ( l.EQ.4 ).OR.( l.EQ.5 ).OR.( l.EQ.6 ).OR.
821 $ ( l.EQ.7 ) ).AND.
822 $ ( max( nrowc, ncolc ).GT.1 ) ) THEN
823*
824* The distributed matrix C is symmetric or Hermitian
825*
826 IF( lsame( uplo, 'L' ) ) THEN
827*
828* Zeros the strict upper triangular part of C.
829*
830 IF( max( nrowc, ncolc ).GT.1 ) THEN
831 CALL pzlaset( 'Upper', nrowc-1, ncolc-1, rogue,
832 $ rogue, mem( ipc ), ic, jc+1,
833 $ descc )
834 CALL pb_zlaset( 'Upper', nrowc-1, ncolc-1, 0,
835 $ rogue, rogue,
836 $ mem( ipmatc+ic-1+jc*ldc ), ldc )
837 END IF
838*
839 ELSE IF( lsame( uplo, 'U' ) ) THEN
840*
841* Zeros the strict lower triangular part of C.
842*
843 IF( max( nrowc, ncolc ).GT.1 ) THEN
844 CALL pzlaset( 'Lower', nrowc-1, ncolc-1, rogue,
845 $ rogue, mem( ipc ), ic+1, jc,
846 $ descc )
847 CALL pb_zlaset( 'Lower', nrowc-1, ncolc-1, 0,
848 $ rogue, rogue,
849 $ mem( ipmatc+ic+(jc-1)*ldc ),
850 $ ldc )
851 END IF
852*
853 END IF
854*
855 ELSE IF( l.EQ.8 .OR. l.EQ.9 ) THEN
856*
857 IF( lsame( uplo, 'L' ) ) THEN
858*
859* The distributed matrix A is lower triangular
860*
861 IF( lsame( diag, 'N' ) ) THEN
862*
863 IF( max( nrowa, ncola ).GT.1 ) THEN
864 CALL pzlaset( 'Upper', nrowa-1, ncola-1,
865 $ rogue, rogue, mem( ipa ), ia,
866 $ ja+1, desca )
867 CALL pb_zlaset( 'Upper', nrowa-1, ncola-1, 0,
868 $ zero, zero,
869 $ mem( ipmata+ia-1+ja*lda ),
870 $ lda )
871 END IF
872*
873 ELSE
874*
875 CALL pzlaset( 'Upper', nrowa, ncola, rogue, one,
876 $ mem( ipa ), ia, ja, desca )
877 CALL pb_zlaset( 'Upper', nrowa, ncola, 0, zero,
878 $ one,
879 $ mem( ipmata+ia-1+(ja-1)*lda ),
880 $ lda )
881 IF( ( l.EQ.9 ).AND.
882 $ ( max( nrowa, ncola ).GT.1 ) ) THEN
883 scale = one /
884 $ dcmplx( dble( max( nrowa, ncola ) ) )
885 CALL pzlascal( 'Lower', nrowa-1, ncola-1,
886 $ scale, mem( ipa ), ia+1, ja,
887 $ desca )
888 CALL pb_zlascal( 'Lower', nrowa-1, ncola-1,
889 $ 0, scale,
890 $ mem( ipmata+ia+(ja-1)*lda ),
891 $ lda )
892 END IF
893 END IF
894*
895 ELSE IF( lsame( uplo, 'U' ) ) THEN
896*
897* The distributed matrix A is upper triangular
898*
899 IF( lsame( diag, 'N' ) ) THEN
900*
901 IF( max( nrowa, ncola ).GT.1 ) THEN
902 CALL pzlaset( 'Lower', nrowa-1, ncola-1,
903 $ rogue, rogue, mem( ipa ), ia+1,
904 $ ja, desca )
905 CALL pb_zlaset( 'Lower', nrowa-1, ncola-1, 0,
906 $ zero, zero,
907 $ mem( ipmata+ia+(ja-1)*lda ),
908 $ lda )
909 END IF
910*
911 ELSE
912*
913 CALL pzlaset( 'Lower', nrowa, ncola, rogue, one,
914 $ mem( ipa ), ia, ja, desca )
915 CALL pb_zlaset( 'Lower', nrowa, ncola, 0, zero,
916 $ one,
917 $ mem( ipmata+ia-1+(ja-1)*lda ),
918 $ lda )
919 IF( ( l.EQ.9 ).AND.
920 $ ( max( nrowa, ncola ).GT.1 ) ) THEN
921 scale = one /
922 $ dcmplx( dble( max( nrowa, ncola ) ) )
923 CALL pzlascal( 'Upper', nrowa-1, ncola-1,
924 $ scale, mem( ipa ), ia, ja+1,
925 $ desca )
926 CALL pb_zlascal( 'Upper', nrowa-1, ncola-1,
927 $ 0, scale,
928 $ mem( ipmata+ia-1+ja*lda ), lda )
929 END IF
930*
931 END IF
932*
933 END IF
934*
935 ELSE IF( l.EQ.11 ) THEN
936*
937 IF( lsame( uplo, 'L' ) ) THEN
938*
939* The distributed matrix C is lower triangular
940*
941 IF( max( nrowc, ncolc ).GT.1 ) THEN
942 CALL pzlaset( 'Upper', nrowc-1, ncolc-1,
943 $ rogue, rogue, mem( ipc ), ic,
944 $ jc+1, descc )
945 CALL pb_zlaset( 'Upper', nrowc-1, ncolc-1, 0,
946 $ rogue, rogue,
947 $ mem( ipmatc+ic-1+jc*ldc ), ldc )
948 END IF
949*
950 ELSE IF( lsame( uplo, 'U' ) ) THEN
951*
952* The distributed matrix C is upper triangular
953*
954 IF( max( nrowc, ncolc ).GT.1 ) THEN
955 CALL pzlaset( 'Lower', nrowc-1, ncolc-1,
956 $ rogue, rogue, mem( ipc ), ic+1,
957 $ jc, descc )
958 CALL pb_zlaset( 'Lower', nrowc-1, ncolc-1, 0,
959 $ rogue, rogue,
960 $ mem( ipmatc+ic+(jc-1)*ldc ),
961 $ ldc )
962 END IF
963*
964 END IF
965*
966 END IF
967*
968* Pad the guard zones of A, B and C
969*
970 CALL pb_zfillpad( ictxt, mpa, nqa, mem( ipa-iprea ),
971 $ desca( lld_ ), iprea, iposta, padval )
972*
973 IF( bcheck( l ) ) THEN
974 CALL pb_zfillpad( ictxt, mpb, nqb, mem( ipb-ipreb ),
975 $ descb( lld_ ), ipreb, ipostb,
976 $ padval )
977 END IF
978*
979 IF( ccheck( l ) ) THEN
980 CALL pb_zfillpad( ictxt, mpc, nqc, mem( ipc-iprec ),
981 $ descc( lld_ ), iprec, ipostc,
982 $ padval )
983 END IF
984*
985* Initialize the check for INPUT-only arguments.
986*
987 info = 0
988 CALL pzchkarg3( ictxt, nout, snames( l ), side, uplo,
989 $ transa, transb, diag, m, n, k, alpha, ia,
990 $ ja, desca, ib, jb, descb, beta, ic, jc,
991 $ descc, info )
992*
993* Print initial parallel data if IVERB >= 2.
994*
995 IF( iverb.EQ.2 ) THEN
996 CALL pb_pzlaprnt( nrowa, ncola, mem( ipa ), ia, ja,
997 $ desca, 0, 0,
998 $ 'PARALLEL_INITIAL_A', nout,
999 $ mem( ipw ) )
1000 ELSE IF( iverb.GE.3 ) THEN
1001 CALL pb_pzlaprnt( ma, na, mem( ipa ), 1, 1, desca,
1002 $ 0, 0, 'PARALLEL_INITIAL_A', nout,
1003 $ mem( ipw ) )
1004 END IF
1005*
1006 IF( bcheck( l ) ) THEN
1007 IF( iverb.EQ.2 ) THEN
1008 CALL pb_pzlaprnt( nrowb, ncolb, mem( ipb ), ib, jb,
1009 $ descb, 0, 0,
1010 $ 'PARALLEL_INITIAL_B', nout,
1011 $ mem( ipw ) )
1012 ELSE IF( iverb.GE.3 ) THEN
1013 CALL pb_pzlaprnt( mb, nb, mem( ipb ), 1, 1, descb,
1014 $ 0, 0, 'PARALLEL_INITIAL_B', nout,
1015 $ mem( ipw ) )
1016 END IF
1017 END IF
1018*
1019 IF( ccheck( l ) ) THEN
1020 IF( iverb.EQ.2 ) THEN
1021 CALL pb_pzlaprnt( nrowc, ncolc, mem( ipc ), ic, jc,
1022 $ descc, 0, 0,
1023 $ 'PARALLEL_INITIAL_C', nout,
1024 $ mem( ipw ) )
1025 ELSE IF( iverb.GE.3 ) THEN
1026 CALL pb_pzlaprnt( mc, nc, mem( ipc ), 1, 1, descc,
1027 $ 0, 0, 'PARALLEL_INITIAL_C', nout,
1028 $ mem( ipw ) )
1029 END IF
1030 END IF
1031*
1032* Call the Level 3 PBLAS routine
1033*
1034 info = 0
1035 IF( l.EQ.1 ) THEN
1036*
1037* Test PZGEMM
1038*
1039 CALL pzgemm( transa, transb, m, n, k, alpha,
1040 $ mem( ipa ), ia, ja, desca, mem( ipb ),
1041 $ ib, jb, descb, beta, mem( ipc ), ic, jc,
1042 $ descc )
1043*
1044 ELSE IF( l.EQ.2 ) THEN
1045*
1046* Test PZSYMM
1047*
1048 CALL pzsymm( side, uplo, m, n, alpha, mem( ipa ), ia,
1049 $ ja, desca, mem( ipb ), ib, jb, descb,
1050 $ beta, mem( ipc ), ic, jc, descc )
1051*
1052 ELSE IF( l.EQ.3 ) THEN
1053*
1054* Test PZHEMM
1055*
1056 CALL pzipset( 'Bignum', nrowa, mem( ipa ), ia, ja,
1057 $ desca )
1058*
1059 CALL pzhemm( side, uplo, m, n, alpha, mem( ipa ), ia,
1060 $ ja, desca, mem( ipb ), ib, jb, descb,
1061 $ beta, mem( ipc ), ic, jc, descc )
1062*
1063 CALL pzipset( 'Zero', nrowa, mem( ipa ), ia, ja,
1064 $ desca )
1065*
1066 ELSE IF( l.EQ.4 ) THEN
1067*
1068* Test PZSYRK
1069*
1070 CALL pzsyrk( uplo, transa, n, k, alpha, mem( ipa ),
1071 $ ia, ja, desca, beta, mem( ipc ), ic, jc,
1072 $ descc )
1073*
1074 ELSE IF( l.EQ.5 ) THEN
1075*
1076* Test PZHERK
1077*
1078 IF( ( ( dcmplx( dble( alpha ) ).NE.zero ).AND.
1079 $ ( k.NE.0 ) ).OR.
1080 $ ( dcmplx( dble( beta ) ).NE.one ) )
1081 $ CALL pzipset( 'Bignum', n, mem( ipc ), ic, jc,
1082 $ descc )
1083*
1084 CALL pzherk( uplo, transa, n, k, dble( alpha ),
1085 $ mem( ipa ), ia, ja, desca, dble( beta ),
1086 $ mem( ipc ), ic, jc, descc )
1087*
1088 ELSE IF( l.EQ.6 ) THEN
1089*
1090* Test PZSYR2K
1091*
1092 CALL pzsyr2k( uplo, transa, n, k, alpha, mem( ipa ),
1093 $ ia, ja, desca, mem( ipb ), ib, jb,
1094 $ descb, beta, mem( ipc ), ic, jc,
1095 $ descc )
1096*
1097 ELSE IF( l.EQ.7 ) THEN
1098*
1099* Test PZHER2K
1100*
1101 IF( ( ( alpha.NE.zero ).AND.( k.NE.0 ) ).OR.
1102 $ ( dcmplx( dble( beta ) ).NE.one ) )
1103 $ CALL pzipset( 'Bignum', n, mem( ipc ), ic, jc,
1104 $ descc )
1105*
1106 CALL pzher2k( uplo, transa, n, k, alpha, mem( ipa ),
1107 $ ia, ja, desca, mem( ipb ), ib, jb,
1108 $ descb, dble( beta ), mem( ipc ), ic, jc,
1109 $ descc )
1110*
1111 ELSE IF( l.EQ.8 ) THEN
1112*
1113* Test PZTRMM
1114*
1115 CALL pztrmm( side, uplo, transa, diag, m, n, alpha,
1116 $ mem( ipa ), ia, ja, desca, mem( ipb ),
1117 $ ib, jb, descb )
1118*
1119 ELSE IF( l.EQ.9 ) THEN
1120*
1121* Test PZTRSM
1122*
1123 CALL pztrsm( side, uplo, transa, diag, m, n, alpha,
1124 $ mem( ipa ), ia, ja, desca, mem( ipb ),
1125 $ ib, jb, descb )
1126*
1127*
1128 ELSE IF( l.EQ.10 ) THEN
1129*
1130* Test PZGEADD
1131*
1132 CALL pzgeadd( transa, m, n, alpha, mem( ipa ), ia, ja,
1133 $ desca, beta, mem( ipc ), ic, jc, descc )
1134*
1135 ELSE IF( l.EQ.11 ) THEN
1136*
1137* Test PZTRADD
1138*
1139 CALL pztradd( uplo, transa, m, n, alpha, mem( ipa ),
1140 $ ia, ja, desca, beta, mem( ipc ), ic, jc,
1141 $ descc )
1142*
1143 END IF
1144*
1145* Check if the operation has been performed.
1146*
1147 IF( info.NE.0 ) THEN
1148 kskip( l ) = kskip( l ) + 1
1149 IF( iam.EQ.0 )
1150 $ WRITE( nout, fmt = 9974 ) info
1151 GO TO 30
1152 END IF
1153*
1154* Check padding
1155*
1156 CALL pb_zchekpad( ictxt, snames( l ), mpa, nqa,
1157 $ mem( ipa-iprea ), desca( lld_ ),
1158 $ iprea, iposta, padval )
1159*
1160 IF( bcheck( l ) ) THEN
1161 CALL pb_zchekpad( ictxt, snames( l ), mpb, nqb,
1162 $ mem( ipb-ipreb ), descb( lld_ ),
1163 $ ipreb, ipostb, padval )
1164 END IF
1165*
1166 IF( ccheck( l ) ) THEN
1167 CALL pb_zchekpad( ictxt, snames( l ), mpc, nqc,
1168 $ mem( ipc-iprec ), descc( lld_ ),
1169 $ iprec, ipostc, padval )
1170 END IF
1171*
1172* Check the computations
1173*
1174 CALL pzblas3tstchk( ictxt, nout, l, side, uplo, transa,
1175 $ transb, diag, m, n, k, alpha,
1176 $ mem( ipmata ), mem( ipa ), ia, ja,
1177 $ desca, mem( ipmatb ), mem( ipb ),
1178 $ ib, jb, descb, beta, mem( ipmatc ),
1179 $ mem( ipc ), ic, jc, descc, thresh,
1180 $ rogue, mem( ipg ), mem( ipw ), info )
1181 IF( mod( info, 2 ).EQ.1 ) THEN
1182 ierr( 1 ) = 1
1183 ELSE IF( mod( info / 2, 2 ).EQ.1 ) THEN
1184 ierr( 2 ) = 1
1185 ELSE IF( mod( info / 4, 2 ).EQ.1 ) THEN
1186 ierr( 3 ) = 1
1187 ELSE IF( info.NE.0 ) THEN
1188 ierr( 1 ) = 1
1189 ierr( 2 ) = 1
1190 ierr( 3 ) = 1
1191 END IF
1192*
1193* Check input-only scalar arguments
1194*
1195 info = 1
1196 CALL pzchkarg3( ictxt, nout, snames( l ), side, uplo,
1197 $ transa, transb, diag, m, n, k, alpha, ia,
1198 $ ja, desca, ib, jb, descb, beta, ic, jc,
1199 $ descc, info )
1200*
1201* Check input-only array arguments
1202*
1203 CALL pzchkmout( nrowa, ncola, mem( ipmata ),
1204 $ mem( ipa ), ia, ja, desca, ierr( 4 ) )
1205 IF( ierr( 4 ).NE.0 ) THEN
1206 IF( iam.EQ.0 )
1207 $ WRITE( nout, fmt = 9983 ) 'PARALLEL_A',
1208 $ snames( l )
1209 END IF
1210*
1211 IF( bcheck( l ) ) THEN
1212 CALL pzchkmout( nrowb, ncolb, mem( ipmatb ),
1213 $ mem( ipb ), ib, jb, descb, ierr( 5 ) )
1214 IF( ierr( 5 ).NE.0 ) THEN
1215 IF( iam.EQ.0 )
1216 $ WRITE( nout, fmt = 9983 ) 'PARALLEL_B',
1217 $ snames( l )
1218 END IF
1219 END IF
1220*
1221 IF( ccheck( l ) ) THEN
1222 CALL pzchkmout( nrowc, ncolc, mem( ipmatc ),
1223 $ mem( ipc ), ic, jc, descc, ierr( 6 ) )
1224 IF( ierr( 6 ).NE.0 ) THEN
1225 IF( iam.EQ.0 )
1226 $ WRITE( nout, fmt = 9983 ) 'PARALLEL_C',
1227 $ snames( l )
1228 END IF
1229 END IF
1230*
1231* Only node 0 prints computational test result
1232*
1233 IF( info.NE.0 .OR. ierr( 1 ).NE.0 .OR.
1234 $ ierr( 2 ).NE.0 .OR. ierr( 3 ).NE.0 .OR.
1235 $ ierr( 4 ).NE.0 .OR. ierr( 5 ).NE.0 .OR.
1236 $ ierr( 6 ).NE.0 ) THEN
1237 kfail( l ) = kfail( l ) + 1
1238 errflg = .true.
1239 IF( iam.EQ.0 )
1240 $ WRITE( nout, fmt = 9985 ) snames( l )
1241 ELSE
1242 kpass( l ) = kpass( l ) + 1
1243 IF( iam.EQ.0 )
1244 $ WRITE( nout, fmt = 9984 ) snames( l )
1245 END IF
1246*
1247* Dump matrix if IVERB >= 1 and error.
1248*
1249 IF( iverb.GE.1 .AND. errflg ) THEN
1250 IF( ierr( 4 ).NE.0 .OR. iverb.GE.3 ) THEN
1251 CALL pzmprnt( ictxt, nout, ma, na, mem( ipmata ),
1252 $ lda, 0, 0, 'SERIAL_A' )
1253 CALL pb_pzlaprnt( ma, na, mem( ipa ), 1, 1, desca,
1254 $ 0, 0, 'PARALLEL_A', nout,
1255 $ mem( ipmata ) )
1256 ELSE IF( ierr( 1 ).NE.0 ) THEN
1257 IF( ( nrowa.GT.0 ).AND.( ncola.GT.0 ) )
1258 $ CALL pzmprnt( ictxt, nout, nrowa, ncola,
1259 $ mem( ipmata+ia-1+(ja-1)*lda ),
1260 $ lda, 0, 0, 'SERIAL_A' )
1261 CALL pb_pzlaprnt( nrowa, ncola, mem( ipa ), ia, ja,
1262 $ desca, 0, 0, 'PARALLEL_A', nout,
1263 $ mem( ipmata ) )
1264 END IF
1265 IF( bcheck( l ) ) THEN
1266 IF( ierr( 5 ).NE.0 .OR. iverb.GE.3 ) THEN
1267 CALL pzmprnt( ictxt, nout, mb, nb,
1268 $ mem( ipmatb ), ldb, 0, 0,
1269 $ 'SERIAL_B' )
1270 CALL pb_pzlaprnt( mb, nb, mem( ipb ), 1, 1,
1271 $ descb, 0, 0, 'PARALLEL_B',
1272 $ nout, mem( ipmatb ) )
1273 ELSE IF( ierr( 2 ).NE.0 ) THEN
1274 IF( ( nrowb.GT.0 ).AND.( ncolb.GT.0 ) )
1275 $ CALL pzmprnt( ictxt, nout, nrowb, ncolb,
1276 $ mem( ipmatb+ib-1+(jb-1)*ldb ),
1277 $ ldb, 0, 0, 'SERIAL_B' )
1278 CALL pb_pzlaprnt( nrowb, ncolb, mem( ipb ), ib,
1279 $ jb, descb, 0, 0, 'PARALLEL_B',
1280 $ nout, mem( ipmatb ) )
1281 END IF
1282 END IF
1283 IF( ccheck( l ) ) THEN
1284 IF( ierr( 6 ).NE.0 .OR. iverb.GE.3 ) THEN
1285 CALL pzmprnt( ictxt, nout, mc, nc,
1286 $ mem( ipmatc ), ldc, 0, 0,
1287 $ 'SERIAL_C' )
1288 CALL pb_pzlaprnt( mc, nc, mem( ipc ), 1, 1,
1289 $ descc, 0, 0, 'PARALLEL_C',
1290 $ nout, mem( ipmatc ) )
1291 ELSE IF( ierr( 3 ).NE.0 ) THEN
1292 IF( ( nrowb.GT.0 ).AND.( ncolb.GT.0 ) )
1293 $ CALL pzmprnt( ictxt, nout, nrowc, ncolc,
1294 $ mem( ipmatc+ic-1+(jc-1)*ldc ),
1295 $ ldc, 0, 0, 'SERIAL_C' )
1296 CALL pb_pzlaprnt( nrowc, ncolc, mem( ipc ), ic,
1297 $ jc, descc, 0, 0, 'PARALLEL_C',
1298 $ nout, mem( ipmatc ) )
1299 END IF
1300 END IF
1301 END IF
1302*
1303* Leave if error and "Stop On Failure"
1304*
1305 IF( sof.AND.errflg )
1306 $ GO TO 70
1307*
1308 30 CONTINUE
1309*
1310 40 IF( iam.EQ.0 ) THEN
1311 WRITE( nout, fmt = * )
1312 WRITE( nout, fmt = 9982 ) j
1313 END IF
1314*
1315 50 CONTINUE
1316*
1317 CALL blacs_gridexit( ictxt )
1318*
1319 60 CONTINUE
1320*
1321* Come here, if error and "Stop On Failure"
1322*
1323 70 CONTINUE
1324*
1325* Before printing out final stats, add TSKIP to all skips
1326*
1327 DO 80 i = 1, nsubs
1328 IF( ltest( i ) ) THEN
1329 kskip( i ) = kskip( i ) + tskip
1330 ktests( i ) = kskip( i ) + kfail( i ) + kpass( i )
1331 END IF
1332 80 CONTINUE
1333*
1334* Print results
1335*
1336 IF( iam.EQ.0 ) THEN
1337 WRITE( nout, fmt = * )
1338 WRITE( nout, fmt = 9978 )
1339 WRITE( nout, fmt = * )
1340 WRITE( nout, fmt = 9980 )
1341 WRITE( nout, fmt = 9979 )
1342*
1343 DO 90 i = 1, nsubs
1344 WRITE( nout, fmt = 9981 ) '|', snames( i ), ktests( i ),
1345 $ kpass( i ), kfail( i ), kskip( i )
1346 90 CONTINUE
1347 WRITE( nout, fmt = * )
1348 WRITE( nout, fmt = 9977 )
1349 WRITE( nout, fmt = * )
1350*
1351 END IF
1352*
1353 CALL blacs_exit( 0 )
1354*
1355 9999 FORMAT( 'ILLEGAL ', a, ': ', a, ' = ', i10,
1356 $ ' should be at least 1' )
1357 9998 FORMAT( 'ILLEGAL GRID: NPROW*NPCOL = ', i4,
1358 $ '. It can be at most', i4 )
1359 9997 FORMAT( 'Bad ', a, ' parameters: going on to next test case.' )
1360 9996 FORMAT( 2x, 'Test number ', i4 , ' started on a ', i6, ' x ',
1361 $ i6, ' process grid.' )
1362 9995 FORMAT( 2x, ' ------------------------------------------------',
1363 $ '-------------------' )
1364 9994 FORMAT( 2x, ' M N K SIDE UPLO TRANSA ',
1365 $ 'TRANSB DIAG' )
1366 9993 FORMAT( 5x,i6,1x,i6,1x,i6,6x,a1,5x,a1,7x,a1,7x,a1,5x,a1 )
1367 9992 FORMAT( 2x, ' IA JA MA NA IMBA INBA',
1368 $ ' MBA NBA RSRCA CSRCA' )
1369 9991 FORMAT( 5x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,
1370 $ 1x,i5,1x,i5 )
1371 9990 FORMAT( 2x, ' IB JB MB NB IMBB INBB',
1372 $ ' MBB NBB RSRCB CSRCB' )
1373 9989 FORMAT( 2x, ' IC JC MC NC IMBC INBC',
1374 $ ' MBC NBC RSRCC CSRCC' )
1375 9988 FORMAT( 'Not enough memory for this test: going on to',
1376 $ ' next test case.' )
1377 9987 FORMAT( 'Not enough memory. Need: ', i12 )
1378 9986 FORMAT( 2x, ' Tested Subroutine: ', a )
1379 9985 FORMAT( 2x, ' ***** Computational check: ', a, ' ',
1380 $ ' FAILED ',' *****' )
1381 9984 FORMAT( 2x, ' ***** Computational check: ', a, ' ',
1382 $ ' PASSED ',' *****' )
1383 9983 FORMAT( 2x, ' ***** ERROR ***** Matrix operand ', a,
1384 $ ' modified by ', a, ' *****' )
1385 9982 FORMAT( 2x, 'Test number ', i4, ' completed.' )
1386 9981 FORMAT( 2x,a1,2x,a7,8x,i4,6x,i4,5x,i4,4x,i4 )
1387 9980 FORMAT( 2x, ' SUBROUTINE TOTAL TESTS PASSED FAILED ',
1388 $ 'SKIPPED' )
1389 9979 FORMAT( 2x, ' ---------- ----------- ------ ------ ',
1390 $ '-------' )
1391 9978 FORMAT( 2x, 'Testing Summary')
1392 9977 FORMAT( 2x, 'End of Tests.' )
1393 9976 FORMAT( 2x, 'Tests started.' )
1394 9975 FORMAT( 2x, ' ***** ', a, ' has an incorrect value: ',
1395 $ ' BYPASS *****' )
1396 9974 FORMAT( 2x, ' ***** Operation not supported, error code: ',
1397 $ i5, ' *****' )
1398*
1399 stop
1400*
1401* End of PZBLA3TST
1402*
1403 END
1404 SUBROUTINE pzbla3tstinfo( SUMMRY, NOUT, NMAT, DIAGVAL, SIDEVAL,
1405 $ TRNAVAL, TRNBVAL, UPLOVAL, MVAL,
1406 $ NVAL, KVAL, MAVAL, NAVAL, IMBAVAL,
1407 $ MBAVAL, INBAVAL, NBAVAL, RSCAVAL,
1408 $ CSCAVAL, IAVAL, JAVAL, MBVAL, NBVAL,
1409 $ IMBBVAL, MBBVAL, INBBVAL, NBBVAL,
1410 $ RSCBVAL, CSCBVAL, IBVAL, JBVAL,
1411 $ MCVAL, NCVAL, IMBCVAL, MBCVAL,
1412 $ INBCVAL, NBCVAL, RSCCVAL, CSCCVAL,
1413 $ ICVAL, JCVAL, LDVAL, NGRIDS, PVAL,
1414 $ LDPVAL, QVAL, LDQVAL, NBLOG, LTEST, SOF,
1415 $ TEE, IAM, IGAP, IVERB, NPROCS, THRESH,
1416 $ ALPHA, BETA, WORK )
1417*
1418* -- PBLAS test routine (version 2.0) --
1419* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1420* and University of California, Berkeley.
1421* April 1, 1998
1422*
1423* .. Scalar Arguments ..
1424 LOGICAL SOF, TEE
1425 INTEGER IAM, IGAP, IVERB, LDPVAL, LDQVAL, LDVAL, NBLOG,
1426 $ NGRIDS, NMAT, NOUT, NPROCS
1427 REAL THRESH
1428 COMPLEX*16 ALPHA, BETA
1429* ..
1430* .. Array Arguments ..
1431 CHARACTER*( * ) SUMMRY
1432 CHARACTER*1 DIAGVAL( LDVAL ), SIDEVAL( LDVAL ),
1433 $ TRNAVAL( LDVAL ), TRNBVAL( LDVAL ),
1434 $ UPLOVAL( LDVAL )
1435 LOGICAL LTEST( * )
1436 INTEGER CSCAVAL( LDVAL ), CSCBVAL( LDVAL ),
1437 $ csccval( ldval ), iaval( ldval ),
1438 $ ibval( ldval ), icval( ldval ),
1439 $ imbaval( ldval ), imbbval( ldval ),
1440 $ imbcval( ldval ), inbaval( ldval ),
1441 $ inbbval( ldval ), inbcval( ldval ),
1442 $ javal( ldval ), jbval( ldval ), jcval( ldval ),
1443 $ kval( ldval ), maval( ldval ), mbaval( ldval ),
1444 $ mbbval( ldval ), mbcval( ldval ),
1445 $ mbval( ldval ), mcval( ldval ), mval( ldval ),
1446 $ naval( ldval ), nbaval( ldval ),
1447 $ nbbval( ldval ), nbcval( ldval ),
1448 $ nbval( ldval ), ncval( ldval ), nval( ldval ),
1449 $ pval( ldpval ), qval( ldqval ),
1450 $ rscaval( ldval ), rscbval( ldval ),
1451 $ rsccval( ldval ), work( * )
1452* ..
1453*
1454* Purpose
1455* =======
1456*
1457* PZBLA3TSTINFO get the needed startup information for testing various
1458* Level 3 PBLAS routines, and transmits it to all processes.
1459*
1460* Notes
1461* =====
1462*
1463* For packing the information we assumed that the length in bytes of an
1464* integer is equal to the length in bytes of a real single precision.
1465*
1466* Arguments
1467* =========
1468*
1469* SUMMRY (global output) CHARACTER*(*)
1470* On exit, SUMMRY is the name of output (summary) file (if
1471* any). SUMMRY is only defined for process 0.
1472*
1473* NOUT (global output) INTEGER
1474* On exit, NOUT specifies the unit number for the output file.
1475* When NOUT is 6, output to screen, when NOUT is 0, output to
1476* stderr. NOUT is only defined for process 0.
1477*
1478* NMAT (global output) INTEGER
1479* On exit, NMAT specifies the number of different test cases.
1480*
1481* DIAGVAL (global output) CHARACTER array
1482* On entry, DIAGVAL is an array of dimension LDVAL. On exit,
1483* this array contains the values of DIAG to run the code with.
1484*
1485* SIDEVAL (global output) CHARACTER array
1486* On entry, SIDEVAL is an array of dimension LDVAL. On exit,
1487* this array contains the values of SIDE to run the code with.
1488*
1489* TRNAVAL (global output) CHARACTER array
1490* On entry, TRNAVAL is an array of dimension LDVAL. On exit,
1491* this array contains the values of TRANSA to run the code
1492* with.
1493*
1494* TRNBVAL (global output) CHARACTER array
1495* On entry, TRNBVAL is an array of dimension LDVAL. On exit,
1496* this array contains the values of TRANSB to run the code
1497* with.
1498*
1499* UPLOVAL (global output) CHARACTER array
1500* On entry, UPLOVAL is an array of dimension LDVAL. On exit,
1501* this array contains the values of UPLO to run the code with.
1502*
1503* MVAL (global output) INTEGER array
1504* On entry, MVAL is an array of dimension LDVAL. On exit, this
1505* array contains the values of M to run the code with.
1506*
1507* NVAL (global output) INTEGER array
1508* On entry, NVAL is an array of dimension LDVAL. On exit, this
1509* array contains the values of N to run the code with.
1510*
1511* KVAL (global output) INTEGER array
1512* On entry, KVAL is an array of dimension LDVAL. On exit, this
1513* array contains the values of K to run the code with.
1514*
1515* MAVAL (global output) INTEGER array
1516* On entry, MAVAL is an array of dimension LDVAL. On exit, this
1517* array contains the values of DESCA( M_ ) to run the code
1518* with.
1519*
1520* NAVAL (global output) INTEGER array
1521* On entry, NAVAL is an array of dimension LDVAL. On exit, this
1522* array contains the values of DESCA( N_ ) to run the code
1523* with.
1524*
1525* IMBAVAL (global output) INTEGER array
1526* On entry, IMBAVAL is an array of dimension LDVAL. On exit,
1527* this array contains the values of DESCA( IMB_ ) to run the
1528* code with.
1529*
1530* MBAVAL (global output) INTEGER array
1531* On entry, MBAVAL is an array of dimension LDVAL. On exit,
1532* this array contains the values of DESCA( MB_ ) to run the
1533* code with.
1534*
1535* INBAVAL (global output) INTEGER array
1536* On entry, INBAVAL is an array of dimension LDVAL. On exit,
1537* this array contains the values of DESCA( INB_ ) to run the
1538* code with.
1539*
1540* NBAVAL (global output) INTEGER array
1541* On entry, NBAVAL is an array of dimension LDVAL. On exit,
1542* this array contains the values of DESCA( NB_ ) to run the
1543* code with.
1544*
1545* RSCAVAL (global output) INTEGER array
1546* On entry, RSCAVAL is an array of dimension LDVAL. On exit,
1547* this array contains the values of DESCA( RSRC_ ) to run the
1548* code with.
1549*
1550* CSCAVAL (global output) INTEGER array
1551* On entry, CSCAVAL is an array of dimension LDVAL. On exit,
1552* this array contains the values of DESCA( CSRC_ ) to run the
1553* code with.
1554*
1555* IAVAL (global output) INTEGER array
1556* On entry, IAVAL is an array of dimension LDVAL. On exit, this
1557* array contains the values of IA to run the code with.
1558*
1559* JAVAL (global output) INTEGER array
1560* On entry, JAVAL is an array of dimension LDVAL. On exit, this
1561* array contains the values of JA to run the code with.
1562*
1563* MBVAL (global output) INTEGER array
1564* On entry, MBVAL is an array of dimension LDVAL. On exit, this
1565* array contains the values of DESCB( M_ ) to run the code
1566* with.
1567*
1568* NBVAL (global output) INTEGER array
1569* On entry, NBVAL is an array of dimension LDVAL. On exit, this
1570* array contains the values of DESCB( N_ ) to run the code
1571* with.
1572*
1573* IMBBVAL (global output) INTEGER array
1574* On entry, IMBBVAL is an array of dimension LDVAL. On exit,
1575* this array contains the values of DESCB( IMB_ ) to run the
1576* code with.
1577*
1578* MBBVAL (global output) INTEGER array
1579* On entry, MBBVAL is an array of dimension LDVAL. On exit,
1580* this array contains the values of DESCB( MB_ ) to run the
1581* code with.
1582*
1583* INBBVAL (global output) INTEGER array
1584* On entry, INBBVAL is an array of dimension LDVAL. On exit,
1585* this array contains the values of DESCB( INB_ ) to run the
1586* code with.
1587*
1588* NBBVAL (global output) INTEGER array
1589* On entry, NBBVAL is an array of dimension LDVAL. On exit,
1590* this array contains the values of DESCB( NB_ ) to run the
1591* code with.
1592*
1593* RSCBVAL (global output) INTEGER array
1594* On entry, RSCBVAL is an array of dimension LDVAL. On exit,
1595* this array contains the values of DESCB( RSRC_ ) to run the
1596* code with.
1597*
1598* CSCBVAL (global output) INTEGER array
1599* On entry, CSCBVAL is an array of dimension LDVAL. On exit,
1600* this array contains the values of DESCB( CSRC_ ) to run the
1601* code with.
1602*
1603* IBVAL (global output) INTEGER array
1604* On entry, IBVAL is an array of dimension LDVAL. On exit, this
1605* array contains the values of IB to run the code with.
1606*
1607* JBVAL (global output) INTEGER array
1608* On entry, JBVAL is an array of dimension LDVAL. On exit, this
1609* array contains the values of JB to run the code with.
1610*
1611* MCVAL (global output) INTEGER array
1612* On entry, MCVAL is an array of dimension LDVAL. On exit, this
1613* array contains the values of DESCC( M_ ) to run the code
1614* with.
1615*
1616* NCVAL (global output) INTEGER array
1617* On entry, NCVAL is an array of dimension LDVAL. On exit, this
1618* array contains the values of DESCC( N_ ) to run the code
1619* with.
1620*
1621* IMBCVAL (global output) INTEGER array
1622* On entry, IMBCVAL is an array of dimension LDVAL. On exit,
1623* this array contains the values of DESCC( IMB_ ) to run the
1624* code with.
1625*
1626* MBCVAL (global output) INTEGER array
1627* On entry, MBCVAL is an array of dimension LDVAL. On exit,
1628* this array contains the values of DESCC( MB_ ) to run the
1629* code with.
1630*
1631* INBCVAL (global output) INTEGER array
1632* On entry, INBCVAL is an array of dimension LDVAL. On exit,
1633* this array contains the values of DESCC( INB_ ) to run the
1634* code with.
1635*
1636* NBCVAL (global output) INTEGER array
1637* On entry, NBCVAL is an array of dimension LDVAL. On exit,
1638* this array contains the values of DESCC( NB_ ) to run the
1639* code with.
1640*
1641* RSCCVAL (global output) INTEGER array
1642* On entry, RSCCVAL is an array of dimension LDVAL. On exit,
1643* this array contains the values of DESCC( RSRC_ ) to run the
1644* code with.
1645*
1646* CSCCVAL (global output) INTEGER array
1647* On entry, CSCCVAL is an array of dimension LDVAL. On exit,
1648* this array contains the values of DESCC( CSRC_ ) to run the
1649* code with.
1650*
1651* ICVAL (global output) INTEGER array
1652* On entry, ICVAL is an array of dimension LDVAL. On exit, this
1653* array contains the values of IC to run the code with.
1654*
1655* JCVAL (global output) INTEGER array
1656* On entry, JCVAL is an array of dimension LDVAL. On exit, this
1657* array contains the values of JC to run the code with.
1658*
1659* LDVAL (global input) INTEGER
1660* On entry, LDVAL specifies the maximum number of different va-
1661* lues that can be used for DIAG, SIDE, TRANSA, TRANSB, UPLO,
1662* M, N, K, DESCA(:), IA, JA, DESCB(:), IB, JB, DESCC(:), IC,
1663* JC. This is also the maximum number of test cases.
1664*
1665* NGRIDS (global output) INTEGER
1666* On exit, NGRIDS specifies the number of different values that
1667* can be used for P and Q.
1668*
1669* PVAL (global output) INTEGER array
1670* On entry, PVAL is an array of dimension LDPVAL. On exit, this
1671* array contains the values of P to run the code with.
1672*
1673* LDPVAL (global input) INTEGER
1674* On entry, LDPVAL specifies the maximum number of different
1675* values that can be used for P.
1676*
1677* QVAL (global output) INTEGER array
1678* On entry, QVAL is an array of dimension LDQVAL. On exit, this
1679* array contains the values of Q to run the code with.
1680*
1681* LDQVAL (global input) INTEGER
1682* On entry, LDQVAL specifies the maximum number of different
1683* values that can be used for Q.
1684*
1685* NBLOG (global output) INTEGER
1686* On exit, NBLOG specifies the logical computational block size
1687* to run the tests with. NBLOG must be at least one.
1688*
1689* LTEST (global output) LOGICAL array
1690* On entry, LTEST is an array of dimension at least eleven. On
1691* exit, if LTEST( i ) is .TRUE., the i-th Level 3 PBLAS routine
1692* will be tested. See the input file for the ordering of the
1693* routines.
1694*
1695* SOF (global output) LOGICAL
1696* On exit, if SOF is .TRUE., the tester will stop on the first
1697* detected failure. Otherwise, it won't.
1698*
1699* TEE (global output) LOGICAL
1700* On exit, if TEE is .TRUE., the tester will perform the error
1701* exit tests. These tests won't be performed otherwise.
1702*
1703* IAM (local input) INTEGER
1704* On entry, IAM specifies the number of the process executing
1705* this routine.
1706*
1707* IGAP (global output) INTEGER
1708* On exit, IGAP specifies the user-specified gap used for pad-
1709* ding. IGAP must be at least zero.
1710*
1711* IVERB (global output) INTEGER
1712* On exit, IVERB specifies the output verbosity level: 0 for
1713* pass/fail, 1, 2 or 3 for matrix dump on errors.
1714*
1715* NPROCS (global input) INTEGER
1716* On entry, NPROCS specifies the total number of processes.
1717*
1718* THRESH (global output) REAL
1719* On exit, THRESH specifies the threshhold value for the test
1720* ratio.
1721*
1722* ALPHA (global output) COMPLEX*16
1723* On exit, ALPHA specifies the value of alpha to be used in all
1724* the test cases.
1725*
1726* BETA (global output) COMPLEX*16
1727* On exit, BETA specifies the value of beta to be used in all
1728* the test cases.
1729*
1730* WORK (local workspace) INTEGER array
1731* On entry, WORK is an array of dimension at least
1732* MAX( 3, 2*NGRIDS+38*NMAT+NSUBS+4 ) with NSUBS equal to 11.
1733* This array is used to pack all output arrays in order to send
1734* the information in one message.
1735*
1736* -- Written on April 1, 1998 by
1737* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1738*
1739* =====================================================================
1740*
1741* .. Parameters ..
1742 INTEGER NIN, NSUBS
1743 PARAMETER ( NIN = 11, nsubs = 11 )
1744* ..
1745* .. Local Scalars ..
1746 LOGICAL LTESTT
1747 INTEGER I, ICTXT, J
1748 DOUBLE PRECISION EPS
1749* ..
1750* .. Local Arrays ..
1751 CHARACTER*7 SNAMET
1752 CHARACTER*79 USRINFO
1753* ..
1754* .. External Subroutines ..
1755 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
1756 $ blacs_gridinit, blacs_setup, icopy, igebr2d,
1757 $ igebs2d, sgebr2d, sgebs2d, zgebr2d, zgebs2d
1758* ..
1759* .. External Functions ..
1760 DOUBLE PRECISION PDLAMCH
1761 EXTERNAL PDLAMCH
1762* ..
1763* .. Intrinsic Functions ..
1764 INTRINSIC char, ichar, max, min
1765* ..
1766* .. Common Blocks ..
1767 CHARACTER*7 SNAMES( NSUBS )
1768 COMMON /SNAMEC/SNAMES
1769* ..
1770* .. Executable Statements ..
1771*
1772* Process 0 reads the input data, broadcasts to other processes and
1773* writes needed information to NOUT
1774*
1775 IF( iam.EQ.0 ) THEN
1776*
1777* Open file and skip data file header
1778*
1779 OPEN( nin, file='PZBLAS3TST.dat', status='OLD' )
1780 READ( nin, fmt = * ) summry
1781 summry = ' '
1782*
1783* Read in user-supplied info about machine type, compiler, etc.
1784*
1785 READ( nin, fmt = 9999 ) usrinfo
1786*
1787* Read name and unit number for summary output file
1788*
1789 READ( nin, fmt = * ) summry
1790 READ( nin, fmt = * ) nout
1791 IF( nout.NE.0 .AND. nout.NE.6 )
1792 $ OPEN( nout, file = summry, status = 'UNKNOWN' )
1793*
1794* Read and check the parameter values for the tests.
1795*
1796* Read the flag that indicates if Stop on Failure
1797*
1798 READ( nin, fmt = * ) sof
1799*
1800* Read the flag that indicates if Test Error Exits
1801*
1802 READ( nin, fmt = * ) tee
1803*
1804* Read the verbosity level
1805*
1806 READ( nin, fmt = * ) iverb
1807 IF( iverb.LT.0 .OR. iverb.GT.3 )
1808 $ iverb = 0
1809*
1810* Read the leading dimension gap
1811*
1812 READ( nin, fmt = * ) igap
1813 IF( igap.LT.0 )
1814 $ igap = 0
1815*
1816* Read the threshold value for test ratio
1817*
1818 READ( nin, fmt = * ) thresh
1819 IF( thresh.LT.0.0 )
1820 $ thresh = 16.0
1821*
1822* Get logical computational block size
1823*
1824 READ( nin, fmt = * ) nblog
1825 IF( nblog.LT.1 )
1826 $ nblog = 32
1827*
1828* Get number of grids
1829*
1830 READ( nin, fmt = * ) ngrids
1831 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
1832 WRITE( nout, fmt = 9998 ) 'Grids', ldpval
1833 GO TO 120
1834 ELSE IF( ngrids.GT.ldqval ) THEN
1835 WRITE( nout, fmt = 9998 ) 'Grids', ldqval
1836 GO TO 120
1837 END IF
1838*
1839* Get values of P and Q
1840*
1841 READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
1842 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
1843*
1844* Read ALPHA, BETA
1845*
1846 READ( nin, fmt = * ) alpha
1847 READ( nin, fmt = * ) beta
1848*
1849* Read number of tests.
1850*
1851 READ( nin, fmt = * ) nmat
1852 IF( nmat.LT.1 .OR. nmat.GT.ldval ) THEN
1853 WRITE( nout, fmt = 9998 ) 'Tests', ldval
1854 GO TO 120
1855 ENDIF
1856*
1857* Read in input data into arrays.
1858*
1859 READ( nin, fmt = * ) ( diagval( i ), i = 1, nmat )
1860 READ( nin, fmt = * ) ( sideval( i ), i = 1, nmat )
1861 READ( nin, fmt = * ) ( trnaval( i ), i = 1, nmat )
1862 READ( nin, fmt = * ) ( trnbval( i ), i = 1, nmat )
1863 READ( nin, fmt = * ) ( uploval( i ), i = 1, nmat )
1864 READ( nin, fmt = * ) ( mval( i ), i = 1, nmat )
1865 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
1866 READ( nin, fmt = * ) ( kval( i ), i = 1, nmat )
1867 READ( nin, fmt = * ) ( maval( i ), i = 1, nmat )
1868 READ( nin, fmt = * ) ( naval( i ), i = 1, nmat )
1869 READ( nin, fmt = * ) ( imbaval( i ), i = 1, nmat )
1870 READ( nin, fmt = * ) ( inbaval( i ), i = 1, nmat )
1871 READ( nin, fmt = * ) ( mbaval( i ), i = 1, nmat )
1872 READ( nin, fmt = * ) ( nbaval( i ), i = 1, nmat )
1873 READ( nin, fmt = * ) ( rscaval( i ), i = 1, nmat )
1874 READ( nin, fmt = * ) ( cscaval( i ), i = 1, nmat )
1875 READ( nin, fmt = * ) ( iaval( i ), i = 1, nmat )
1876 READ( nin, fmt = * ) ( javal( i ), i = 1, nmat )
1877 READ( nin, fmt = * ) ( mbval( i ), i = 1, nmat )
1878 READ( nin, fmt = * ) ( nbval( i ), i = 1, nmat )
1879 READ( nin, fmt = * ) ( imbbval( i ), i = 1, nmat )
1880 READ( nin, fmt = * ) ( inbbval( i ), i = 1, nmat )
1881 READ( nin, fmt = * ) ( mbbval( i ), i = 1, nmat )
1882 READ( nin, fmt = * ) ( nbbval( i ), i = 1, nmat )
1883 READ( nin, fmt = * ) ( rscbval( i ), i = 1, nmat )
1884 READ( nin, fmt = * ) ( cscbval( i ), i = 1, nmat )
1885 READ( nin, fmt = * ) ( ibval( i ), i = 1, nmat )
1886 READ( nin, fmt = * ) ( jbval( i ), i = 1, nmat )
1887 READ( nin, fmt = * ) ( mcval( i ), i = 1, nmat )
1888 READ( nin, fmt = * ) ( ncval( i ), i = 1, nmat )
1889 READ( nin, fmt = * ) ( imbcval( i ), i = 1, nmat )
1890 READ( nin, fmt = * ) ( inbcval( i ), i = 1, nmat )
1891 READ( nin, fmt = * ) ( mbcval( i ), i = 1, nmat )
1892 READ( nin, fmt = * ) ( nbcval( i ), i = 1, nmat )
1893 READ( nin, fmt = * ) ( rsccval( i ), i = 1, nmat )
1894 READ( nin, fmt = * ) ( csccval( i ), i = 1, nmat )
1895 READ( nin, fmt = * ) ( icval( i ), i = 1, nmat )
1896 READ( nin, fmt = * ) ( jcval( i ), i = 1, nmat )
1897*
1898* Read names of subroutines and flags which indicate
1899* whether they are to be tested.
1900*
1901 DO 10 i = 1, nsubs
1902 ltest( i ) = .false.
1903 10 CONTINUE
1904 20 CONTINUE
1905 READ( nin, fmt = 9996, END = 50 ) SNAMET, ltestt
1906 DO 30 i = 1, nsubs
1907 IF( snamet.EQ.snames( i ) )
1908 $ GO TO 40
1909 30 CONTINUE
1910*
1911 WRITE( nout, fmt = 9995 )snamet
1912 GO TO 120
1913*
1914 40 CONTINUE
1915 ltest( i ) = ltestt
1916 GO TO 20
1917*
1918 50 CONTINUE
1919*
1920* Close input file
1921*
1922 CLOSE ( nin )
1923*
1924* For pvm only: if virtual machine not set up, allocate it and
1925* spawn the correct number of processes.
1926*
1927 IF( nprocs.LT.1 ) THEN
1928 nprocs = 0
1929 DO 60 i = 1, ngrids
1930 nprocs = max( nprocs, pval( i )*qval( i ) )
1931 60 CONTINUE
1932 CALL blacs_setup( iam, nprocs )
1933 END IF
1934*
1935* Temporarily define blacs grid to include all processes so
1936* information can be broadcast to all processes
1937*
1938 CALL blacs_get( -1, 0, ictxt )
1939 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1940*
1941* Compute machine epsilon
1942*
1943 eps = pdlamch( ictxt, 'eps' )
1944*
1945* Pack information arrays and broadcast
1946*
1947 CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
1948 CALL zgebs2d( ictxt, 'All', ' ', 1, 1, alpha, 1 )
1949 CALL zgebs2d( ictxt, 'All', ' ', 1, 1, beta, 1 )
1950*
1951 work( 1 ) = ngrids
1952 work( 2 ) = nmat
1953 work( 3 ) = nblog
1954 CALL igebs2d( ictxt, 'All', ' ', 3, 1, work, 3 )
1955*
1956 i = 1
1957 IF( sof ) THEN
1958 work( i ) = 1
1959 ELSE
1960 work( i ) = 0
1961 END IF
1962 i = i + 1
1963 IF( tee ) THEN
1964 work( i ) = 1
1965 ELSE
1966 work( i ) = 0
1967 END IF
1968 i = i + 1
1969 work( i ) = iverb
1970 i = i + 1
1971 work( i ) = igap
1972 i = i + 1
1973 DO 70 j = 1, nmat
1974 work( i ) = ichar( diagval( j ) )
1975 work( i+1 ) = ichar( sideval( j ) )
1976 work( i+2 ) = ichar( trnaval( j ) )
1977 work( i+3 ) = ichar( trnbval( j ) )
1978 work( i+4 ) = ichar( uploval( j ) )
1979 i = i + 5
1980 70 CONTINUE
1981 CALL icopy( ngrids, pval, 1, work( i ), 1 )
1982 i = i + ngrids
1983 CALL icopy( ngrids, qval, 1, work( i ), 1 )
1984 i = i + ngrids
1985 CALL icopy( nmat, mval, 1, work( i ), 1 )
1986 i = i + nmat
1987 CALL icopy( nmat, nval, 1, work( i ), 1 )
1988 i = i + nmat
1989 CALL icopy( nmat, kval, 1, work( i ), 1 )
1990 i = i + nmat
1991 CALL icopy( nmat, maval, 1, work( i ), 1 )
1992 i = i + nmat
1993 CALL icopy( nmat, naval, 1, work( i ), 1 )
1994 i = i + nmat
1995 CALL icopy( nmat, imbaval, 1, work( i ), 1 )
1996 i = i + nmat
1997 CALL icopy( nmat, inbaval, 1, work( i ), 1 )
1998 i = i + nmat
1999 CALL icopy( nmat, mbaval, 1, work( i ), 1 )
2000 i = i + nmat
2001 CALL icopy( nmat, nbaval, 1, work( i ), 1 )
2002 i = i + nmat
2003 CALL icopy( nmat, rscaval, 1, work( i ), 1 )
2004 i = i + nmat
2005 CALL icopy( nmat, cscaval, 1, work( i ), 1 )
2006 i = i + nmat
2007 CALL icopy( nmat, iaval, 1, work( i ), 1 )
2008 i = i + nmat
2009 CALL icopy( nmat, javal, 1, work( i ), 1 )
2010 i = i + nmat
2011 CALL icopy( nmat, mbval, 1, work( i ), 1 )
2012 i = i + nmat
2013 CALL icopy( nmat, nbval, 1, work( i ), 1 )
2014 i = i + nmat
2015 CALL icopy( nmat, imbbval, 1, work( i ), 1 )
2016 i = i + nmat
2017 CALL icopy( nmat, inbbval, 1, work( i ), 1 )
2018 i = i + nmat
2019 CALL icopy( nmat, mbbval, 1, work( i ), 1 )
2020 i = i + nmat
2021 CALL icopy( nmat, nbbval, 1, work( i ), 1 )
2022 i = i + nmat
2023 CALL icopy( nmat, rscbval, 1, work( i ), 1 )
2024 i = i + nmat
2025 CALL icopy( nmat, cscbval, 1, work( i ), 1 )
2026 i = i + nmat
2027 CALL icopy( nmat, ibval, 1, work( i ), 1 )
2028 i = i + nmat
2029 CALL icopy( nmat, jbval, 1, work( i ), 1 )
2030 i = i + nmat
2031 CALL icopy( nmat, mcval, 1, work( i ), 1 )
2032 i = i + nmat
2033 CALL icopy( nmat, ncval, 1, work( i ), 1 )
2034 i = i + nmat
2035 CALL icopy( nmat, imbcval, 1, work( i ), 1 )
2036 i = i + nmat
2037 CALL icopy( nmat, inbcval, 1, work( i ), 1 )
2038 i = i + nmat
2039 CALL icopy( nmat, mbcval, 1, work( i ), 1 )
2040 i = i + nmat
2041 CALL icopy( nmat, nbcval, 1, work( i ), 1 )
2042 i = i + nmat
2043 CALL icopy( nmat, rsccval, 1, work( i ), 1 )
2044 i = i + nmat
2045 CALL icopy( nmat, csccval, 1, work( i ), 1 )
2046 i = i + nmat
2047 CALL icopy( nmat, icval, 1, work( i ), 1 )
2048 i = i + nmat
2049 CALL icopy( nmat, jcval, 1, work( i ), 1 )
2050 i = i + nmat
2051*
2052 DO 80 j = 1, nsubs
2053 IF( ltest( j ) ) THEN
2054 work( i ) = 1
2055 ELSE
2056 work( i ) = 0
2057 END IF
2058 i = i + 1
2059 80 CONTINUE
2060 i = i - 1
2061 CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
2062*
2063* regurgitate input
2064*
2065 WRITE( nout, fmt = 9999 ) 'Level 3 PBLAS testing program.'
2066 WRITE( nout, fmt = 9999 ) usrinfo
2067 WRITE( nout, fmt = * )
2068 WRITE( nout, fmt = 9999 )
2069 $ 'Tests of the complex double precision '//
2070 $ 'Level 3 PBLAS'
2071 WRITE( nout, fmt = * )
2072 WRITE( nout, fmt = 9993 ) nmat
2073 WRITE( nout, fmt = 9979 ) nblog
2074 WRITE( nout, fmt = 9992 ) ngrids
2075 WRITE( nout, fmt = 9990 )
2076 $ 'P', ( pval(i), i = 1, min(ngrids, 5) )
2077 IF( ngrids.GT.5 )
2078 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 6,
2079 $ min( 10, ngrids ) )
2080 IF( ngrids.GT.10 )
2081 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 11,
2082 $ min( 15, ngrids ) )
2083 IF( ngrids.GT.15 )
2084 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 16, ngrids )
2085 WRITE( nout, fmt = 9990 )
2086 $ 'Q', ( qval(i), i = 1, min(ngrids, 5) )
2087 IF( ngrids.GT.5 )
2088 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 6,
2089 $ min( 10, ngrids ) )
2090 IF( ngrids.GT.10 )
2091 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 11,
2092 $ min( 15, ngrids ) )
2093 IF( ngrids.GT.15 )
2094 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 16, ngrids )
2095 WRITE( nout, fmt = 9988 ) sof
2096 WRITE( nout, fmt = 9987 ) tee
2097 WRITE( nout, fmt = 9983 ) igap
2098 WRITE( nout, fmt = 9986 ) iverb
2099 WRITE( nout, fmt = 9980 ) thresh
2100 WRITE( nout, fmt = 9982 ) alpha
2101 WRITE( nout, fmt = 9981 ) beta
2102 IF( ltest( 1 ) ) THEN
2103 WRITE( nout, fmt = 9985 ) snames( 1 ), ' ... Yes'
2104 ELSE
2105 WRITE( nout, fmt = 9985 ) snames( 1 ), ' ... No '
2106 END IF
2107 DO 90 i = 2, nsubs
2108 IF( ltest( i ) ) THEN
2109 WRITE( nout, fmt = 9984 ) snames( i ), ' ... Yes'
2110 ELSE
2111 WRITE( nout, fmt = 9984 ) snames( i ), ' ... No '
2112 END IF
2113 90 CONTINUE
2114 WRITE( nout, fmt = 9994 ) eps
2115 WRITE( nout, fmt = * )
2116*
2117 ELSE
2118*
2119* If in pvm, must participate setting up virtual machine
2120*
2121 IF( nprocs.LT.1 )
2122 $ CALL blacs_setup( iam, nprocs )
2123*
2124* Temporarily define blacs grid to include all processes so
2125* information can be broadcast to all processes
2126*
2127 CALL blacs_get( -1, 0, ictxt )
2128 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
2129*
2130* Compute machine epsilon
2131*
2132 eps = pdlamch( ictxt, 'eps' )
2133*
2134 CALL sgebr2d( ictxt, 'All', ' ', 1, 1, thresh, 1, 0, 0 )
2135 CALL zgebr2d( ictxt, 'All', ' ', 1, 1, alpha, 1, 0, 0 )
2136 CALL zgebr2d( ictxt, 'All', ' ', 1, 1, beta, 1, 0, 0 )
2137*
2138 CALL igebr2d( ictxt, 'All', ' ', 3, 1, work, 3, 0, 0 )
2139 ngrids = work( 1 )
2140 nmat = work( 2 )
2141 nblog = work( 3 )
2142*
2143 i = 2*ngrids + 38*nmat + nsubs + 4
2144 CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
2145*
2146 i = 1
2147 IF( work( i ).EQ.1 ) THEN
2148 sof = .true.
2149 ELSE
2150 sof = .false.
2151 END IF
2152 i = i + 1
2153 IF( work( i ).EQ.1 ) THEN
2154 tee = .true.
2155 ELSE
2156 tee = .false.
2157 END IF
2158 i = i + 1
2159 iverb = work( i )
2160 i = i + 1
2161 igap = work( i )
2162 i = i + 1
2163 DO 100 j = 1, nmat
2164 diagval( j ) = char( work( i ) )
2165 sideval( j ) = char( work( i+1 ) )
2166 trnaval( j ) = char( work( i+2 ) )
2167 trnbval( j ) = char( work( i+3 ) )
2168 uploval( j ) = char( work( i+4 ) )
2169 i = i + 5
2170 100 CONTINUE
2171 CALL icopy( ngrids, work( i ), 1, pval, 1 )
2172 i = i + ngrids
2173 CALL icopy( ngrids, work( i ), 1, qval, 1 )
2174 i = i + ngrids
2175 CALL icopy( nmat, work( i ), 1, mval, 1 )
2176 i = i + nmat
2177 CALL icopy( nmat, work( i ), 1, nval, 1 )
2178 i = i + nmat
2179 CALL icopy( nmat, work( i ), 1, kval, 1 )
2180 i = i + nmat
2181 CALL icopy( nmat, work( i ), 1, maval, 1 )
2182 i = i + nmat
2183 CALL icopy( nmat, work( i ), 1, naval, 1 )
2184 i = i + nmat
2185 CALL icopy( nmat, work( i ), 1, imbaval, 1 )
2186 i = i + nmat
2187 CALL icopy( nmat, work( i ), 1, inbaval, 1 )
2188 i = i + nmat
2189 CALL icopy( nmat, work( i ), 1, mbaval, 1 )
2190 i = i + nmat
2191 CALL icopy( nmat, work( i ), 1, nbaval, 1 )
2192 i = i + nmat
2193 CALL icopy( nmat, work( i ), 1, rscaval, 1 )
2194 i = i + nmat
2195 CALL icopy( nmat, work( i ), 1, cscaval, 1 )
2196 i = i + nmat
2197 CALL icopy( nmat, work( i ), 1, iaval, 1 )
2198 i = i + nmat
2199 CALL icopy( nmat, work( i ), 1, javal, 1 )
2200 i = i + nmat
2201 CALL icopy( nmat, work( i ), 1, mbval, 1 )
2202 i = i + nmat
2203 CALL icopy( nmat, work( i ), 1, nbval, 1 )
2204 i = i + nmat
2205 CALL icopy( nmat, work( i ), 1, imbbval, 1 )
2206 i = i + nmat
2207 CALL icopy( nmat, work( i ), 1, inbbval, 1 )
2208 i = i + nmat
2209 CALL icopy( nmat, work( i ), 1, mbbval, 1 )
2210 i = i + nmat
2211 CALL icopy( nmat, work( i ), 1, nbbval, 1 )
2212 i = i + nmat
2213 CALL icopy( nmat, work( i ), 1, rscbval, 1 )
2214 i = i + nmat
2215 CALL icopy( nmat, work( i ), 1, cscbval, 1 )
2216 i = i + nmat
2217 CALL icopy( nmat, work( i ), 1, ibval, 1 )
2218 i = i + nmat
2219 CALL icopy( nmat, work( i ), 1, jbval, 1 )
2220 i = i + nmat
2221 CALL icopy( nmat, work( i ), 1, mcval, 1 )
2222 i = i + nmat
2223 CALL icopy( nmat, work( i ), 1, ncval, 1 )
2224 i = i + nmat
2225 CALL icopy( nmat, work( i ), 1, imbcval, 1 )
2226 i = i + nmat
2227 CALL icopy( nmat, work( i ), 1, inbcval, 1 )
2228 i = i + nmat
2229 CALL icopy( nmat, work( i ), 1, mbcval, 1 )
2230 i = i + nmat
2231 CALL icopy( nmat, work( i ), 1, nbcval, 1 )
2232 i = i + nmat
2233 CALL icopy( nmat, work( i ), 1, rsccval, 1 )
2234 i = i + nmat
2235 CALL icopy( nmat, work( i ), 1, csccval, 1 )
2236 i = i + nmat
2237 CALL icopy( nmat, work( i ), 1, icval, 1 )
2238 i = i + nmat
2239 CALL icopy( nmat, work( i ), 1, jcval, 1 )
2240 i = i + nmat
2241*
2242 DO 110 j = 1, nsubs
2243 IF( work( i ).EQ.1 ) THEN
2244 ltest( j ) = .true.
2245 ELSE
2246 ltest( j ) = .false.
2247 END IF
2248 i = i + 1
2249 110 CONTINUE
2250*
2251 END IF
2252*
2253 CALL blacs_gridexit( ictxt )
2254*
2255 RETURN
2256*
2257 120 WRITE( nout, fmt = 9997 )
2258 CLOSE( nin )
2259 IF( nout.NE.6 .AND. nout.NE.0 )
2260 $ CLOSE( nout )
2261 CALL blacs_abort( ictxt, 1 )
2262*
2263 stop
2264*
2265 9999 FORMAT( a )
2266 9998 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
2267 $ 'than ', i2 )
2268 9997 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
2269 9996 FORMAT( a7, l2 )
2270 9995 FORMAT( ' Subprogram name ', a7, ' not recognized',
2271 $ /' ******* TESTS ABANDONED *******' )
2272 9994 FORMAT( 2x, 'Relative machine precision (eps) is taken to be ',
2273 $ e18.6 )
2274 9993 FORMAT( 2x, 'Number of Tests : ', i6 )
2275 9992 FORMAT( 2x, 'Number of process grids : ', i6 )
2276 9991 FORMAT( 2x, ' : ', 5i6 )
2277 9990 FORMAT( 2x, a1, ' : ', 5i6 )
2278 9988 FORMAT( 2x, 'Stop on failure flag : ', l6 )
2279 9987 FORMAT( 2x, 'Test for error exits flag : ', l6 )
2280 9986 FORMAT( 2x, 'Verbosity level : ', i6 )
2281 9985 FORMAT( 2x, 'Routines to be tested : ', a, a8 )
2282 9984 FORMAT( 2x, ' ', a, a8 )
2283 9983 FORMAT( 2x, 'Leading dimension gap : ', i6 )
2284 9982 FORMAT( 2x, 'Alpha : (', g16.6,
2285 $ ',', g16.6, ')' )
2286 9981 FORMAT( 2x, 'Beta : (', g16.6,
2287 $ ',', g16.6, ')' )
2288 9980 FORMAT( 2x, 'Threshold value : ', g16.6 )
2289 9979 FORMAT( 2x, 'Logical block size : ', i6 )
2290*
2291* End of PZBLA3TSTINFO
2292*
2293 END
2294 SUBROUTINE pzblas3tstchke( LTEST, INOUT, NPROCS )
2295*
2296* -- PBLAS test routine (version 2.0) --
2297* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2298* and University of California, Berkeley.
2299* April 1, 1998
2300*
2301* .. Scalar Arguments ..
2302 INTEGER INOUT, NPROCS
2303* ..
2304* .. Array Arguments ..
2305 LOGICAL LTEST( * )
2306* ..
2307*
2308* Purpose
2309* =======
2310*
2311* PZBLAS3TSTCHKE tests the error exits of the Level 3 PBLAS.
2312*
2313* Arguments
2314* =========
2315*
2316* LTEST (global input) LOGICAL array
2317* On entry, LTEST is an array of dimension at least 11 (NSUBS).
2318* If LTEST( 1 ) is .TRUE., PZGEMM will be tested;
2319* If LTEST( 2 ) is .TRUE., PZSYMM will be tested;
2320* If LTEST( 3 ) is .TRUE., PZHEMM will be tested;
2321* If LTEST( 4 ) is .TRUE., PZSYRK will be tested;
2322* If LTEST( 5 ) is .TRUE., PZHERK will be tested;
2323* If LTEST( 6 ) is .TRUE., PZSYR2K will be tested;
2324* If LTEST( 7 ) is .TRUE., PZHER2K will be tested;
2325* If LTEST( 8 ) is .TRUE., PZTRMM will be tested;
2326* If LTEST( 9 ) is .TRUE., PZTRSM will be tested;
2327* If LTEST( 10 ) is .TRUE., PZGEADD will be tested;
2328* If LTEST( 11 ) is .TRUE., PZTRADD will be tested;
2329*
2330* INOUT (global input) INTEGER
2331* On entry, INOUT specifies the unit number for output file.
2332* When INOUT is 6, output to screen, when INOUT = 0, output to
2333* stderr. INOUT is only defined in process 0.
2334*
2335* NPROCS (global input) INTEGER
2336* On entry, NPROCS specifies the total number of processes cal-
2337* ling this routine.
2338*
2339* Calling sequence encodings
2340* ==========================
2341*
2342* code Formal argument list Examples
2343*
2344* 11 (n, v1,v2) _SWAP, _COPY
2345* 12 (n,s1, v1 ) _SCAL, _SCAL
2346* 13 (n,s1, v1,v2) _AXPY, _DOT_
2347* 14 (n,s1,i1,v1 ) _AMAX
2348* 15 (n,u1, v1 ) _ASUM, _NRM2
2349*
2350* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
2351* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
2352* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
2353* 24 ( m,n,s1,v1,v2,m1) _GER_
2354* 25 (uplo, n,s1,v1, m1) _SYR
2355* 26 (uplo, n,u1,v1, m1) _HER
2356* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
2357*
2358* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
2359* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
2360* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
2361* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
2362* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
2363* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
2364* 37 ( m,n, s1,m1, s2,m3) _TRAN_
2365* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
2366* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
2367* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
2368*
2369* -- Written on April 1, 1998 by
2370* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2371*
2372* =====================================================================
2373*
2374* .. Parameters ..
2375 INTEGER NSUBS
2376 PARAMETER ( NSUBS = 11 )
2377* ..
2378* .. Local Scalars ..
2379 logical abrtsav
2380 INTEGER I, ICTXT, MYCOL, MYROW, NPCOL, NPROW
2381* ..
2382* .. Local Arrays ..
2383 INTEGER SCODE( NSUBS )
2384* ..
2385* .. External Subroutines ..
2386 EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
2387 $ blacs_gridinit, pzdimee, pzgeadd, pzgemm,
2388 $ pzhemm, pzher2k, pzherk, pzmatee, pzoptee,
2389 $ pzsymm, pzsyr2k, pzsyrk, pztradd, pztrmm,
2390 $ pztrsm
2391* ..
2392* .. Common Blocks ..
2393 LOGICAL ABRTFLG
2394 INTEGER NOUT
2395 CHARACTER*7 SNAMES( NSUBS )
2396 COMMON /SNAMEC/SNAMES
2397 COMMON /PBERRORC/NOUT, ABRTFLG
2398* ..
2399* .. Data Statements ..
2400 DATA scode/31, 32, 32, 33, 34, 35, 36, 38, 38, 39,
2401 $ 40/
2402* ..
2403* .. Executable Statements ..
2404*
2405* Temporarily define blacs grid to include all processes so
2406* information can be broadcast to all processes.
2407*
2408 CALL blacs_get( -1, 0, ictxt )
2409 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
2410 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2411*
2412* Set ABRTFLG to FALSE so that the PBLAS error handler won't abort
2413* on errors during these tests and set the output device unit for
2414* it.
2415*
2416 abrtsav = abrtflg
2417 abrtflg = .false.
2418 nout = inout
2419*
2420* Test PZGEMM
2421*
2422 i = 1
2423 IF( ltest( i ) ) THEN
2424 CALL pzoptee( ictxt, nout, pzgemm, scode( i ), snames( i ) )
2425 CALL pzdimee( ictxt, nout, pzgemm, scode( i ), snames( i ) )
2426 CALL pzmatee( ictxt, nout, pzgemm, scode( i ), snames( i ) )
2427 END IF
2428*
2429* Test PZSYMM
2430*
2431 i = i + 1
2432 IF( ltest( i ) ) THEN
2433 CALL pzoptee( ictxt, nout, pzsymm, scode( i ), snames( i ) )
2434 CALL pzdimee( ictxt, nout, pzsymm, scode( i ), snames( i ) )
2435 CALL pzmatee( ictxt, nout, pzsymm, scode( i ), snames( i ) )
2436 END IF
2437*
2438* Test PZHEMM
2439*
2440 i = i + 1
2441 IF( ltest( i ) ) THEN
2442 CALL pzoptee( ictxt, nout, pzhemm, scode( i ), snames( i ) )
2443 CALL pzdimee( ictxt, nout, pzhemm, scode( i ), snames( i ) )
2444 CALL pzmatee( ictxt, nout, pzhemm, scode( i ), snames( i ) )
2445 END IF
2446*
2447* Test PZSYRK
2448*
2449 i = i + 1
2450 IF( ltest( i ) ) THEN
2451 CALL pzoptee( ictxt, nout, pzsyrk, scode( i ), snames( i ) )
2452 CALL pzdimee( ictxt, nout, pzsyrk, scode( i ), snames( i ) )
2453 CALL pzmatee( ictxt, nout, pzsyrk, scode( i ), snames( i ) )
2454 END IF
2455*
2456* Test PZHERK
2457*
2458 i = i + 1
2459 IF( ltest( i ) ) THEN
2460 CALL pzoptee( ictxt, nout, pzherk, scode( i ), snames( i ) )
2461 CALL pzdimee( ictxt, nout, pzherk, scode( i ), snames( i ) )
2462 CALL pzmatee( ictxt, nout, pzherk, scode( i ), snames( i ) )
2463 END IF
2464*
2465* Test PZSYR2K
2466*
2467 i = i + 1
2468 IF( ltest( i ) ) THEN
2469 CALL pzoptee( ictxt, nout, pzsyr2k, scode( i ), snames( i ) )
2470 CALL pzdimee( ictxt, nout, pzsyr2k, scode( i ), snames( i ) )
2471 CALL pzmatee( ictxt, nout, pzsyr2k, scode( i ), snames( i ) )
2472 END IF
2473*
2474* Test PZHER2K
2475*
2476 i = i + 1
2477 IF( ltest( i ) ) THEN
2478 CALL pzoptee( ictxt, nout, pzher2k, scode( i ), snames( i ) )
2479 CALL pzdimee( ictxt, nout, pzher2k, scode( i ), snames( i ) )
2480 CALL pzmatee( ictxt, nout, pzher2k, scode( i ), snames( i ) )
2481 END IF
2482*
2483* Test PZTRMM
2484*
2485 i = i + 1
2486 IF( ltest( i ) ) THEN
2487 CALL pzoptee( ictxt, nout, pztrmm, scode( i ), snames( i ) )
2488 CALL pzdimee( ictxt, nout, pztrmm, scode( i ), snames( i ) )
2489 CALL pzmatee( ictxt, nout, pztrmm, scode( i ), snames( i ) )
2490 END IF
2491*
2492* Test PZTRSM
2493*
2494 i = i + 1
2495 IF( ltest( i ) ) THEN
2496 CALL pzoptee( ictxt, nout, pztrsm, scode( i ), snames( i ) )
2497 CALL pzdimee( ictxt, nout, pztrsm, scode( i ), snames( i ) )
2498 CALL pzmatee( ictxt, nout, pztrsm, scode( i ), snames( i ) )
2499 END IF
2500*
2501* Test PZGEADD
2502*
2503 i = i + 1
2504 IF( ltest( i ) ) THEN
2505 CALL pzoptee( ictxt, nout, pzgeadd, scode( i ), snames( i ) )
2506 CALL pzdimee( ictxt, nout, pzgeadd, scode( i ), snames( i ) )
2507 CALL pzmatee( ictxt, nout, pzgeadd, scode( i ), snames( i ) )
2508 END IF
2509*
2510* Test PZTRADD
2511*
2512 i = i + 1
2513 IF( ltest( i ) ) THEN
2514 CALL pzoptee( ictxt, nout, pztradd, scode( i ), snames( i ) )
2515 CALL pzdimee( ictxt, nout, pztradd, scode( i ), snames( i ) )
2516 CALL pzmatee( ictxt, nout, pztradd, scode( i ), snames( i ) )
2517 END IF
2518*
2519 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2520 $ WRITE( nout, fmt = 9999 )
2521*
2522 CALL blacs_gridexit( ictxt )
2523*
2524* Reset ABRTFLG to the value it had before calling this routine
2525*
2526 abrtflg = abrtsav
2527*
2528 9999 FORMAT( 2x, 'Error-exit tests completed.' )
2529*
2530 RETURN
2531*
2532* End of PZBLAS3TSTCHKE
2533*
2534 END
2535 SUBROUTINE pzchkarg3( ICTXT, NOUT, SNAME, SIDE, UPLO, TRANSA,
2536 $ TRANSB, DIAG, M, N, K, ALPHA, IA, JA,
2537 $ DESCA, IB, JB, DESCB, BETA, IC, JC, DESCC,
2538 $ INFO )
2539*
2540* -- PBLAS test routine (version 2.0) --
2541* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2542* and University of California, Berkeley.
2543* April 1, 1998
2544*
2545* .. Scalar Arguments ..
2546 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2547 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N,
2548 $ NOUT
2549 COMPLEX*16 ALPHA, BETA
2550* ..
2551* .. Array Arguments ..
2552 CHARACTER*7 SNAME
2553 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
2554* ..
2555*
2556* Purpose
2557* =======
2558*
2559* PZCHKARG3 checks the input-only arguments of the Level 3 PBLAS. When
2560* INFO = 0, this routine makes a copy of its arguments (which are INPUT
2561* only arguments to PBLAS routines). Otherwise, it verifies the values
2562* of these arguments against the saved copies.
2563*
2564* Arguments
2565* =========
2566*
2567* ICTXT (local input) INTEGER
2568* On entry, ICTXT specifies the BLACS context handle, indica-
2569* ting the global context of the operation. The context itself
2570* is global, but the value of ICTXT is local.
2571*
2572* NOUT (global input) INTEGER
2573* On entry, NOUT specifies the unit number for the output file.
2574* When NOUT is 6, output to screen, when NOUT is 0, output to
2575* stderr. NOUT is only defined for process 0.
2576*
2577* SNAME (global input) CHARACTER*(*)
2578* On entry, SNAME specifies the subroutine name calling this
2579* subprogram.
2580*
2581* SIDE (global input) CHARACTER*1
2582* On entry, SIDE specifies the SIDE option in the Level 3 PBLAS
2583* operation.
2584*
2585* UPLO (global input) CHARACTER*1
2586* On entry, UPLO specifies the UPLO option in the Level 3 PBLAS
2587* operation.
2588*
2589* TRANSA (global input) CHARACTER*1
2590* On entry, TRANSA specifies the TRANSA option in the Level 3
2591* PBLAS operation.
2592*
2593* TRANSB (global input) CHARACTER*1
2594* On entry, TRANSB specifies the TRANSB option in the Level 3
2595* PBLAS operation.
2596*
2597* DIAG (global input) CHARACTER*1
2598* On entry, DIAG specifies the DIAG option in the Level 3 PBLAS
2599* operation.
2600*
2601* M (global input) INTEGER
2602* On entry, M specifies the dimension of the submatrix ope-
2603* rands.
2604*
2605* N (global input) INTEGER
2606* On entry, N specifies the dimension of the submatrix ope-
2607* rands.
2608*
2609* K (global input) INTEGER
2610* On entry, K specifies the dimension of the submatrix ope-
2611* rands.
2612*
2613* ALPHA (global input) COMPLEX*16
2614* On entry, ALPHA specifies the scalar alpha.
2615*
2616* IA (global input) INTEGER
2617* On entry, IA specifies A's global row index, which points to
2618* the beginning of the submatrix sub( A ).
2619*
2620* JA (global input) INTEGER
2621* On entry, JA specifies A's global column index, which points
2622* to the beginning of the submatrix sub( A ).
2623*
2624* DESCA (global and local input) INTEGER array
2625* On entry, DESCA is an integer array of dimension DLEN_. This
2626* is the array descriptor for the matrix A.
2627*
2628* IB (global input) INTEGER
2629* On entry, IB specifies B's global row index, which points to
2630* the beginning of the submatrix sub( B ).
2631*
2632* JB (global input) INTEGER
2633* On entry, JB specifies B's global column index, which points
2634* to the beginning of the submatrix sub( B ).
2635*
2636* DESCB (global and local input) INTEGER array
2637* On entry, DESCB is an integer array of dimension DLEN_. This
2638* is the array descriptor for the matrix B.
2639*
2640* BETA (global input) COMPLEX*16
2641* On entry, BETA specifies the scalar beta.
2642*
2643* IC (global input) INTEGER
2644* On entry, IC specifies C's global row index, which points to
2645* the beginning of the submatrix sub( C ).
2646*
2647* JC (global input) INTEGER
2648* On entry, JC specifies C's global column index, which points
2649* to the beginning of the submatrix sub( C ).
2650*
2651* DESCC (global and local input) INTEGER array
2652* On entry, DESCC is an integer array of dimension DLEN_. This
2653* is the array descriptor for the matrix C.
2654*
2655* INFO (global input/global output) INTEGER
2656* When INFO = 0 on entry, the values of the arguments which are
2657* INPUT only arguments to a PBLAS routine are copied into sta-
2658* tic variables and INFO is unchanged on exit. Otherwise, the
2659* values of the arguments are compared against the saved co-
2660* pies. In case no error has been found INFO is zero on return,
2661* otherwise it is non zero.
2662*
2663* -- Written on April 1, 1998 by
2664* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2665*
2666* =====================================================================
2667*
2668* .. Parameters ..
2669 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2670 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2671 $ RSRC_
2672 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
2673 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2674 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2675 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2676* ..
2677* .. Local Scalars ..
2678 CHARACTER*1 DIAGREF, SIDEREF, TRANSAREF, TRANSBREF, UPLOREF
2679 INTEGER I, IAREF, IBREF, ICREF, JAREF, JBREF, JCREF,
2680 $ KREF, MREF, MYCOL, MYROW, NPCOL, NPROW, NREF
2681 COMPLEX*16 ALPHAREF, BETAREF
2682* ..
2683* .. Local Arrays ..
2684 CHARACTER*15 ARGNAME
2685 INTEGER DESCAREF( DLEN_ ), DESCBREF( DLEN_ ),
2686 $ DESCCREF( DLEN_ )
2687* ..
2688* .. External Subroutines ..
2689 EXTERNAL blacs_gridinfo, igsum2d
2690* ..
2691* .. External Functions ..
2692 LOGICAL LSAME
2693 EXTERNAL lsame
2694* ..
2695* .. Save Statements ..
2696 SAVE
2697* ..
2698* .. Executable Statements ..
2699*
2700* Get grid parameters
2701*
2702 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2703*
2704* Check if first call. If yes, then save.
2705*
2706 IF( info.EQ.0 ) THEN
2707*
2708 diagref = diag
2709 sideref = side
2710 transaref = transa
2711 transbref = transb
2712 uploref = uplo
2713 mref = m
2714 nref = n
2715 kref = k
2716 alpharef = alpha
2717 iaref = ia
2718 jaref = ja
2719 DO 10 i = 1, dlen_
2720 descaref( i ) = desca( i )
2721 10 CONTINUE
2722 ibref = ib
2723 jbref = jb
2724 DO 20 i = 1, dlen_
2725 descbref( i ) = descb( i )
2726 20 CONTINUE
2727 betaref = beta
2728 icref = ic
2729 jcref = jc
2730 DO 30 i = 1, dlen_
2731 desccref( i ) = descc( i )
2732 30 CONTINUE
2733*
2734 ELSE
2735*
2736* Test saved args. Return with first mismatch.
2737*
2738 argname = ' '
2739 IF( .NOT. lsame( diag, diagref ) ) THEN
2740 WRITE( argname, fmt = '(A)' ) 'DIAG'
2741 ELSE IF( .NOT. lsame( side, sideref ) ) THEN
2742 WRITE( argname, fmt = '(A)' ) 'SIDE'
2743 ELSE IF( .NOT. lsame( transa, transaref ) ) THEN
2744 WRITE( argname, fmt = '(A)' ) 'TRANSA'
2745 ELSE IF( .NOT. lsame( transb, transbref ) ) THEN
2746 WRITE( argname, fmt = '(A)' ) 'TRANSB'
2747 ELSE IF( .NOT. lsame( uplo, uploref ) ) THEN
2748 WRITE( argname, fmt = '(A)' ) 'UPLO'
2749 ELSE IF( m.NE.mref ) THEN
2750 WRITE( argname, fmt = '(A)' ) 'M'
2751 ELSE IF( n.NE.nref ) THEN
2752 WRITE( argname, fmt = '(A)' ) 'N'
2753 ELSE IF( k.NE.kref ) THEN
2754 WRITE( argname, fmt = '(A)' ) 'K'
2755 ELSE IF( alpha.NE.alpharef ) THEN
2756 WRITE( argname, fmt = '(A)' ) 'ALPHA'
2757 ELSE IF( ia.NE.iaref ) THEN
2758 WRITE( argname, fmt = '(A)' ) 'IA'
2759 ELSE IF( ja.NE.jaref ) THEN
2760 WRITE( argname, fmt = '(A)' ) 'JA'
2761 ELSE IF( desca( dtype_ ).NE.descaref( dtype_ ) ) THEN
2762 WRITE( argname, fmt = '(A)' ) 'DESCA( DTYPE_ )'
2763 ELSE IF( desca( m_ ).NE.descaref( m_ ) ) THEN
2764 WRITE( argname, fmt = '(A)' ) 'DESCA( M_ )'
2765 ELSE IF( desca( n_ ).NE.descaref( n_ ) ) THEN
2766 WRITE( argname, fmt = '(A)' ) 'DESCA( N_ )'
2767 ELSE IF( desca( imb_ ).NE.descaref( imb_ ) ) THEN
2768 WRITE( argname, fmt = '(A)' ) 'DESCA( IMB_ )'
2769 ELSE IF( desca( inb_ ).NE.descaref( inb_ ) ) THEN
2770 WRITE( argname, fmt = '(A)' ) 'DESCA( INB_ )'
2771 ELSE IF( desca( mb_ ).NE.descaref( mb_ ) ) THEN
2772 WRITE( argname, fmt = '(A)' ) 'DESCA( MB_ )'
2773 ELSE IF( desca( nb_ ).NE.descaref( nb_ ) ) THEN
2774 WRITE( argname, fmt = '(A)' ) 'DESCA( NB_ )'
2775 ELSE IF( desca( rsrc_ ).NE.descaref( rsrc_ ) ) THEN
2776 WRITE( argname, fmt = '(A)' ) 'DESCA( RSRC_ )'
2777 ELSE IF( desca( csrc_ ).NE.descaref( csrc_ ) ) THEN
2778 WRITE( argname, fmt = '(A)' ) 'DESCA( CSRC_ )'
2779 ELSE IF( desca( ctxt_ ).NE.descaref( ctxt_ ) ) THEN
2780 WRITE( argname, fmt = '(A)' ) 'DESCA( CTXT_ )'
2781 ELSE IF( desca( lld_ ).NE.descaref( lld_ ) ) THEN
2782 WRITE( argname, fmt = '(A)' ) 'DESCA( LLD_ )'
2783 ELSE IF( ib.NE.ibref ) THEN
2784 WRITE( argname, fmt = '(A)' ) 'IB'
2785 ELSE IF( jb.NE.jbref ) THEN
2786 WRITE( argname, fmt = '(A)' ) 'JB'
2787 ELSE IF( descb( dtype_ ).NE.descbref( dtype_ ) ) THEN
2788 WRITE( argname, fmt = '(A)' ) 'DESCB( DTYPE_ )'
2789 ELSE IF( descb( m_ ).NE.descbref( m_ ) ) THEN
2790 WRITE( argname, fmt = '(A)' ) 'DESCB( M_ )'
2791 ELSE IF( descb( n_ ).NE.descbref( n_ ) ) THEN
2792 WRITE( argname, fmt = '(A)' ) 'DESCB( N_ )'
2793 ELSE IF( descb( imb_ ).NE.descbref( imb_ ) ) THEN
2794 WRITE( argname, fmt = '(A)' ) 'DESCB( IMB_ )'
2795 ELSE IF( descb( inb_ ).NE.descbref( inb_ ) ) THEN
2796 WRITE( argname, fmt = '(A)' ) 'DESCB( INB_ )'
2797 ELSE IF( descb( mb_ ).NE.descbref( mb_ ) ) THEN
2798 WRITE( argname, fmt = '(A)' ) 'DESCB( MB_ )'
2799 ELSE IF( descb( nb_ ).NE.descbref( nb_ ) ) THEN
2800 WRITE( argname, fmt = '(A)' ) 'DESCB( NB_ )'
2801 ELSE IF( descb( rsrc_ ).NE.descbref( rsrc_ ) ) THEN
2802 WRITE( argname, fmt = '(A)' ) 'DESCB( RSRC_ )'
2803 ELSE IF( descb( csrc_ ).NE.descbref( csrc_ ) ) THEN
2804 WRITE( argname, fmt = '(A)' ) 'DESCB( CSRC_ )'
2805 ELSE IF( descb( ctxt_ ).NE.descbref( ctxt_ ) ) THEN
2806 WRITE( argname, fmt = '(A)' ) 'DESCB( CTXT_ )'
2807 ELSE IF( descb( lld_ ).NE.descbref( lld_ ) ) THEN
2808 WRITE( argname, fmt = '(A)' ) 'DESCB( LLD_ )'
2809 ELSE IF( beta.NE.betaref ) THEN
2810 WRITE( argname, fmt = '(A)' ) 'BETA'
2811 ELSE IF( ic.NE.icref ) THEN
2812 WRITE( argname, fmt = '(A)' ) 'IC'
2813 ELSE IF( jc.NE.jcref ) THEN
2814 WRITE( argname, fmt = '(A)' ) 'JC'
2815 ELSE IF( descc( dtype_ ).NE.desccref( dtype_ ) ) THEN
2816 WRITE( argname, fmt = '(A)' ) 'DESCC( DTYPE_ )'
2817 ELSE IF( descc( m_ ).NE.desccref( m_ ) ) THEN
2818 WRITE( argname, fmt = '(A)' ) 'DESCC( M_ )'
2819 ELSE IF( descc( n_ ).NE.desccref( n_ ) ) THEN
2820 WRITE( argname, fmt = '(A)' ) 'DESCC( N_ )'
2821 ELSE IF( descc( imb_ ).NE.desccref( imb_ ) ) THEN
2822 WRITE( argname, fmt = '(A)' ) 'DESCC( IMB_ )'
2823 ELSE IF( descc( inb_ ).NE.desccref( inb_ ) ) THEN
2824 WRITE( argname, fmt = '(A)' ) 'DESCC( INB_ )'
2825 ELSE IF( descc( mb_ ).NE.desccref( mb_ ) ) THEN
2826 WRITE( argname, fmt = '(A)' ) 'DESCC( MB_ )'
2827 ELSE IF( descc( nb_ ).NE.desccref( nb_ ) ) THEN
2828 WRITE( argname, fmt = '(A)' ) 'DESCC( NB_ )'
2829 ELSE IF( descc( rsrc_ ).NE.desccref( rsrc_ ) ) THEN
2830 WRITE( argname, fmt = '(A)' ) 'DESCC( RSRC_ )'
2831 ELSE IF( descc( csrc_ ).NE.desccref( csrc_ ) ) THEN
2832 WRITE( argname, fmt = '(A)' ) 'DESCC( CSRC_ )'
2833 ELSE IF( descc( ctxt_ ).NE.desccref( ctxt_ ) ) THEN
2834 WRITE( argname, fmt = '(A)' ) 'DESCC( CTXT_ )'
2835 ELSE IF( descc( lld_ ).NE.desccref( lld_ ) ) THEN
2836 WRITE( argname, fmt = '(A)' ) 'DESCC( LLD_ )'
2837 ELSE
2838 info = 0
2839 END IF
2840*
2841 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
2842*
2843 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2844*
2845 IF( info.NE.0 ) THEN
2846 WRITE( nout, fmt = 9999 ) argname, sname
2847 ELSE
2848 WRITE( nout, fmt = 9998 ) sname
2849 END IF
2850*
2851 END IF
2852*
2853 END IF
2854*
2855 9999 FORMAT( 2x, ' ***** Input-only parameter check: ', a,
2856 $ ' FAILED changed ', a, ' *****' )
2857 9998 FORMAT( 2x, ' ***** Input-only parameter check: ', a,
2858 $ ' PASSED *****' )
2859*
2860 RETURN
2861*
2862* End of PZCHKARG3
2863*
2864 END
2865 SUBROUTINE pzblas3tstchk( ICTXT, NOUT, NROUT, SIDE, UPLO, TRANSA,
2866 $ TRANSB, DIAG, M, N, K, ALPHA, A, PA, IA,
2867 $ JA, DESCA, B, PB, IB, JB, DESCB, BETA,
2868 $ C, PC, IC, JC, DESCC, THRESH, ROGUE,
2869 $ WORK, RWORK, INFO )
2870*
2871* -- PBLAS test routine (version 2.0) --
2872* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2873* and University of California, Berkeley.
2874* April 1, 1998
2875*
2876* .. Scalar Arguments ..
2877 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2878 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N,
2879 $ nout, nrout
2880 REAL THRESH
2881 COMPLEX*16 ALPHA, BETA, ROGUE
2882* ..
2883* .. Array Arguments ..
2884 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
2885 DOUBLE PRECISION RWORK( * )
2886 COMPLEX*16 A( * ), B( * ), C( * ), PA( * ), PB( * ),
2887 $ PC( * ), WORK( * )
2888* ..
2889*
2890* Purpose
2891* =======
2892*
2893* PZBLAS3TSTCHK performs the computational tests of the Level 3 PBLAS.
2894*
2895* Notes
2896* =====
2897*
2898* A description vector is associated with each 2D block-cyclicly dis-
2899* tributed matrix. This vector stores the information required to
2900* establish the mapping between a matrix entry and its corresponding
2901* process and memory location.
2902*
2903* In the following comments, the character _ should be read as
2904* "of the distributed matrix". Let A be a generic term for any 2D
2905* block cyclicly distributed matrix. Its description vector is DESCA:
2906*
2907* NOTATION STORED IN EXPLANATION
2908* ---------------- --------------- ------------------------------------
2909* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2910* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2911* the NPROW x NPCOL BLACS process grid
2912* A is distributed over. The context
2913* itself is global, but the handle
2914* (the integer value) may vary.
2915* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2916* ted matrix A, M_A >= 0.
2917* N_A (global) DESCA( N_ ) The number of columns in the distri-
2918* buted matrix A, N_A >= 0.
2919* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2920* block of the matrix A, IMB_A > 0.
2921* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2922* left block of the matrix A,
2923* INB_A > 0.
2924* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2925* bute the last M_A-IMB_A rows of A,
2926* MB_A > 0.
2927* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2928* bute the last N_A-INB_A columns of
2929* A, NB_A > 0.
2930* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2931* row of the matrix A is distributed,
2932* NPROW > RSRC_A >= 0.
2933* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2934* first column of A is distributed.
2935* NPCOL > CSRC_A >= 0.
2936* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2937* array storing the local blocks of
2938* the distributed matrix A,
2939* IF( Lc( 1, N_A ) > 0 )
2940* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2941* ELSE
2942* LLD_A >= 1.
2943*
2944* Let K be the number of rows of a matrix A starting at the global in-
2945* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2946* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2947* receive if these K rows were distributed over NPROW processes. If K
2948* is the number of columns of a matrix A starting at the global index
2949* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2950* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2951* these K columns were distributed over NPCOL processes.
2952*
2953* The values of Lr() and Lc() may be determined via a call to the func-
2954* tion PB_NUMROC:
2955* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2956* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2957*
2958* Arguments
2959* =========
2960*
2961* ICTXT (local input) INTEGER
2962* On entry, ICTXT specifies the BLACS context handle, indica-
2963* ting the global context of the operation. The context itself
2964* is global, but the value of ICTXT is local.
2965*
2966* NOUT (global input) INTEGER
2967* On entry, NOUT specifies the unit number for the output file.
2968* When NOUT is 6, output to screen, when NOUT is 0, output to
2969* stderr. NOUT is only defined for process 0.
2970*
2971* NROUT (global input) INTEGER
2972* On entry, NROUT specifies which routine will be tested as
2973* follows:
2974* If NROUT = 1, PZGEMM will be tested;
2975* else if NROUT = 2, PZSYMM will be tested;
2976* else if NROUT = 3, PZHEMM will be tested;
2977* else if NROUT = 4, PZSYRK will be tested;
2978* else if NROUT = 5, PZHERK will be tested;
2979* else if NROUT = 6, PZSYR2K will be tested;
2980* else if NROUT = 7, PZHER2K will be tested;
2981* else if NROUT = 8, PZTRMM will be tested;
2982* else if NROUT = 9, PZTRSM will be tested;
2983* else if NROUT = 10, PZGEADD will be tested;
2984* else if NROUT = 11, PZTRADD will be tested;
2985*
2986* SIDE (global input) CHARACTER*1
2987* On entry, SIDE specifies if the multiplication should be per-
2988* formed from the left or the right.
2989*
2990* UPLO (global input) CHARACTER*1
2991* On entry, UPLO specifies if the upper or lower part of the
2992* matrix operand is to be referenced.
2993*
2994* TRANSA (global input) CHARACTER*1
2995* On entry, TRANSA specifies if the matrix operand A is to be
2996* transposed.
2997*
2998* TRANSB (global input) CHARACTER*1
2999* On entry, TRANSB specifies if the matrix operand B is to be
3000* transposed.
3001*
3002* DIAG (global input) CHARACTER*1
3003* On entry, DIAG specifies if the triangular matrix operand is
3004* unit or non-unit.
3005*
3006* M (global input) INTEGER
3007* On entry, M specifies the number of rows of C.
3008*
3009* N (global input) INTEGER
3010* On entry, N specifies the number of columns of C.
3011*
3012* K (global input) INTEGER
3013* On entry, K specifies the number of columns (resp. rows) of A
3014* when TRANSA = 'N' (resp. TRANSA <> 'N') in PxGEMM, PxSYRK,
3015* PxSYR2K, PxHERK and PxHER2K.
3016*
3017* ALPHA (global input) COMPLEX*16
3018* On entry, ALPHA specifies the scalar alpha.
3019*
3020* A (local input/local output) COMPLEX*16 array
3021* On entry, A is an array of dimension (DESCA( M_ ),*). This
3022* array contains a local copy of the initial entire matrix PA.
3023*
3024* PA (local input) COMPLEX*16 array
3025* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
3026* array contains the local entries of the matrix PA.
3027*
3028* IA (global input) INTEGER
3029* On entry, IA specifies A's global row index, which points to
3030* the beginning of the submatrix sub( A ).
3031*
3032* JA (global input) INTEGER
3033* On entry, JA specifies A's global column index, which points
3034* to the beginning of the submatrix sub( A ).
3035*
3036* DESCA (global and local input) INTEGER array
3037* On entry, DESCA is an integer array of dimension DLEN_. This
3038* is the array descriptor for the matrix A.
3039*
3040* B (local input/local output) COMPLEX*16 array
3041* On entry, B is an array of dimension (DESCB( M_ ),*). This
3042* array contains a local copy of the initial entire matrix PB.
3043*
3044* PB (local input) COMPLEX*16 array
3045* On entry, PB is an array of dimension (DESCB( LLD_ ),*). This
3046* array contains the local entries of the matrix PB.
3047*
3048* IB (global input) INTEGER
3049* On entry, IB specifies B's global row index, which points to
3050* the beginning of the submatrix sub( B ).
3051*
3052* JB (global input) INTEGER
3053* On entry, JB specifies B's global column index, which points
3054* to the beginning of the submatrix sub( B ).
3055*
3056* DESCB (global and local input) INTEGER array
3057* On entry, DESCB is an integer array of dimension DLEN_. This
3058* is the array descriptor for the matrix B.
3059*
3060* BETA (global input) COMPLEX*16
3061* On entry, BETA specifies the scalar beta.
3062*
3063* C (local input/local output) COMPLEX*16 array
3064* On entry, C is an array of dimension (DESCC( M_ ),*). This
3065* array contains a local copy of the initial entire matrix PC.
3066*
3067* PC (local input) COMPLEX*16 array
3068* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
3069* array contains the local pieces of the matrix PC.
3070*
3071* IC (global input) INTEGER
3072* On entry, IC specifies C's global row index, which points to
3073* the beginning of the submatrix sub( C ).
3074*
3075* JC (global input) INTEGER
3076* On entry, JC specifies C's global column index, which points
3077* to the beginning of the submatrix sub( C ).
3078*
3079* DESCC (global and local input) INTEGER array
3080* On entry, DESCC is an integer array of dimension DLEN_. This
3081* is the array descriptor for the matrix C.
3082*
3083* THRESH (global input) REAL
3084* On entry, THRESH is the threshold value for the test ratio.
3085*
3086* ROGUE (global input) COMPLEX*16
3087* On entry, ROGUE specifies the constant used to pad the
3088* non-referenced part of triangular, symmetric or Hermitian ma-
3089* trices.
3090*
3091* WORK (workspace) COMPLEX*16 array
3092* On entry, WORK is an array of dimension LWORK where LWORK is
3093* at least MAX( M, MAX( N, K ) ). This array is used to store
3094* a copy of a column of C (see PZMMCH).
3095*
3096* RWORK (workspace) DOUBLE PRECISION array
3097* On entry, RWORK is an array of dimension LRWORK where LRWORK
3098* is at least MAX( M, MAX( N, K ) ). This array is used to sto-
3099* re the computed gauges (see PZMMCH).
3100*
3101* INFO (global output) INTEGER
3102* On exit, if INFO = 0, no error has been found, otherwise
3103* if( MOD( INFO, 2 ) = 1 ) then an error on A has been found,
3104* if( MOD( INFO/2, 2 ) = 1 ) then an error on B has been found,
3105* if( MOD( INFO/4, 2 ) = 1 ) then an error on C has been found.
3106*
3107* -- Written on April 1, 1998 by
3108* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3109*
3110* =====================================================================
3111*
3112* .. Parameters ..
3113 DOUBLE PRECISION RZERO
3114 PARAMETER ( RZERO = 0.0d+0 )
3115 COMPLEX*16 ONE, ZERO
3116 PARAMETER ( ONE = ( 1.0d+0, 0.0d+0 ),
3117 $ zero = ( 0.0d+0, 0.0d+0 ) )
3118 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3119 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3120 $ RSRC_
3121 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
3122 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3123 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3124 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3125* ..
3126* .. Local Scalars ..
3127 INTEGER I, MYCOL, MYROW, NPCOL, NPROW
3128 DOUBLE PRECISION ERR
3129 COMPLEX*16 ALPHA1, BETA1
3130* ..
3131* .. Local Arrays ..
3132 INTEGER IERR( 3 )
3133* ..
3134* .. External Subroutines ..
3135 EXTERNAL blacs_gridinfo, pb_zlaset, pzchkmin, pzmmch,
3136 $ pzmmch1, pzmmch2, pzmmch3, pztrmm, ztrsm
3137* ..
3138* .. External Functions ..
3139 LOGICAL LSAME
3140 EXTERNAL lsame
3141* ..
3142* .. Intrinsic Functions ..
3143 INTRINSIC dble, dcmplx
3144* ..
3145* .. Executable Statements ..
3146*
3147 info = 0
3148*
3149* Quick return if possible
3150*
3151 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
3152 $ RETURN
3153*
3154* Start the operations
3155*
3156 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3157*
3158 DO 10 i = 1, 3
3159 ierr( i ) = 0
3160 10 CONTINUE
3161*
3162 IF( nrout.EQ.1 ) THEN
3163*
3164* Test PZGEMM
3165*
3166* Check the resulting matrix C
3167*
3168 CALL pzmmch( ictxt, transa, transb, m, n, k, alpha, a, ia, ja,
3169 $ desca, b, ib, jb, descb, beta, c, pc, ic, jc,
3170 $ descc, work, rwork, err, ierr( 3 ) )
3171*
3172 IF( ierr( 3 ).NE.0 ) THEN
3173 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3174 $ WRITE( nout, fmt = 9998 )
3175 ELSE IF( err.GT.dble( thresh ) ) THEN
3176 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3177 $ WRITE( nout, fmt = 9997 ) err
3178 END IF
3179*
3180* Check the input-only arguments
3181*
3182 IF( lsame( transa, 'N' ) ) THEN
3183 CALL pzchkmin( err, m, k, a, pa, ia, ja, desca, ierr( 1 ) )
3184 ELSE
3185 CALL pzchkmin( err, k, m, a, pa, ia, ja, desca, ierr( 1 ) )
3186 END IF
3187 IF( lsame( transb, 'N' ) ) THEN
3188 CALL pzchkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3189 ELSE
3190 CALL pzchkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3191 END IF
3192*
3193 ELSE IF( nrout.EQ.2 ) THEN
3194*
3195* Test PZSYMM
3196*
3197* Check the resulting matrix C
3198*
3199 IF( lsame( side, 'L' ) ) THEN
3200 CALL pzmmch( ictxt, 'No transpose', 'No transpose', m, n, m,
3201 $ alpha, a, ia, ja, desca, b, ib, jb, descb,
3202 $ beta, c, pc, ic, jc, descc, work, rwork, err,
3203 $ ierr( 3 ) )
3204 ELSE
3205 CALL pzmmch( ictxt, 'No transpose', 'No transpose', m, n, n,
3206 $ alpha, b, ib, jb, descb, a, ia, ja, desca,
3207 $ beta, c, pc, ic, jc, descc, work, rwork, err,
3208 $ ierr( 3 ) )
3209 END IF
3210*
3211 IF( ierr( 3 ).NE.0 ) THEN
3212 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3213 $ WRITE( nout, fmt = 9998 )
3214 ELSE IF( err.GT.dble( thresh ) ) THEN
3215 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3216 $ WRITE( nout, fmt = 9997 ) err
3217 END IF
3218*
3219* Check the input-only arguments
3220*
3221 IF( lsame( uplo, 'L' ) ) THEN
3222 IF( lsame( side, 'L' ) ) THEN
3223 CALL pb_zlaset( 'Upper', m-1, m-1, 0, rogue, rogue,
3224 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3225 ELSE
3226 CALL pb_zlaset( 'Upper', n-1, n-1, 0, rogue, rogue,
3227 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3228 END IF
3229 ELSE
3230 IF( lsame( side, 'L' ) ) THEN
3231 CALL pb_zlaset( 'Lower', m-1, m-1, 0, rogue, rogue,
3232 $ a( ia+1+(ja-1)*desca( m_ ) ),
3233 $ desca( m_ ) )
3234 ELSE
3235 CALL pb_zlaset( 'Lower', n-1, n-1, 0, rogue, rogue,
3236 $ a( ia+1+(ja-1)*desca( m_ ) ),
3237 $ desca( m_ ) )
3238 END IF
3239 END IF
3240*
3241 IF( lsame( side, 'L' ) ) THEN
3242 CALL pzchkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3243 ELSE
3244 CALL pzchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3245 END IF
3246 CALL pzchkmin( err, m, n, b, pb, ib, jb, descb, ierr( 2 ) )
3247*
3248 ELSE IF( nrout.EQ.3 ) THEN
3249*
3250* Test PZHEMM
3251*
3252* Check the resulting matrix C
3253*
3254 IF( lsame( side, 'L' ) ) THEN
3255 CALL pzmmch( ictxt, 'No transpose', 'No transpose', m, n, m,
3256 $ alpha, a, ia, ja, desca, b, ib, jb, descb,
3257 $ beta, c, pc, ic, jc, descc, work, rwork, err,
3258 $ ierr( 3 ) )
3259 ELSE
3260 CALL pzmmch( ictxt, 'No transpose', 'No transpose', m, n, n,
3261 $ alpha, b, ib, jb, descb, a, ia, ja, desca,
3262 $ beta, c, pc, ic, jc, descc, work, rwork, err,
3263 $ ierr( 3 ) )
3264 END IF
3265*
3266 IF( ierr( 3 ).NE.0 ) THEN
3267 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3268 $ WRITE( nout, fmt = 9998 )
3269 ELSE IF( err.GT.dble( thresh ) ) THEN
3270 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3271 $ WRITE( nout, fmt = 9997 ) err
3272 END IF
3273*
3274* Check the input-only arguments
3275*
3276 IF( lsame( uplo, 'L' ) ) THEN
3277 IF( lsame( side, 'L' ) ) THEN
3278 CALL pb_zlaset( 'Upper', m-1, m-1, 0, rogue, rogue,
3279 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3280 ELSE
3281 CALL pb_zlaset( 'Upper', n-1, n-1, 0, rogue, rogue,
3282 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3283 END IF
3284 ELSE
3285 IF( lsame( side, 'L' ) ) THEN
3286 CALL pb_zlaset( 'Lower', m-1, m-1, 0, rogue, rogue,
3287 $ a( ia+1+(ja-1)*desca( m_ ) ),
3288 $ desca( m_ ) )
3289 ELSE
3290 CALL pb_zlaset( 'Lower', n-1, n-1, 0, rogue, rogue,
3291 $ a( ia+1+(ja-1)*desca( m_ ) ),
3292 $ desca( m_ ) )
3293 END IF
3294 END IF
3295*
3296 IF( lsame( side, 'L' ) ) THEN
3297 CALL pzchkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3298 ELSE
3299 CALL pzchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3300 END IF
3301 CALL pzchkmin( err, m, n, b, pb, ib, jb, descb, ierr( 2 ) )
3302*
3303 ELSE IF( nrout.EQ.4 ) THEN
3304*
3305* Test PZSYRK
3306*
3307* Check the resulting matrix C
3308*
3309 IF( lsame( transa, 'N' ) ) THEN
3310 CALL pzmmch1( ictxt, uplo, 'No transpose', n, k, alpha, a,
3311 $ ia, ja, desca, beta, c, pc, ic, jc, descc,
3312 $ work, rwork, err, ierr( 3 ) )
3313 ELSE
3314 CALL pzmmch1( ictxt, uplo, 'Transpose', n, k, alpha, a, ia,
3315 $ ja, desca, beta, c, pc, ic, jc, descc, work,
3316 $ rwork, err, ierr( 3 ) )
3317 END IF
3318*
3319 IF( ierr( 3 ).NE.0 ) THEN
3320 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3321 $ WRITE( nout, fmt = 9998 )
3322 ELSE IF( err.GT.dble( thresh ) ) THEN
3323 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3324 $ WRITE( nout, fmt = 9997 ) err
3325 END IF
3326*
3327* Check the input-only arguments
3328*
3329 IF( lsame( transa, 'N' ) ) THEN
3330 CALL pzchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3331 ELSE
3332 CALL pzchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3333 END IF
3334*
3335 ELSE IF( nrout.EQ.5 ) THEN
3336*
3337* Test PZHERK
3338*
3339* Check the resulting matrix C
3340*
3341 beta1 = dcmplx( dble( beta ), rzero )
3342 alpha1 = dcmplx( dble( alpha ), rzero )
3343 IF( lsame( transa, 'N' ) ) THEN
3344 CALL pzmmch1( ictxt, uplo, 'Hermitian', n, k, alpha1, a, ia,
3345 $ ja, desca, beta1, c, pc, ic, jc, descc, work,
3346 $ rwork, err, ierr( 3 ) )
3347 ELSE
3348 CALL pzmmch1( ictxt, uplo, 'Conjugate transpose', n, k,
3349 $ alpha1, a, ia, ja, desca, beta1, c, pc, ic,
3350 $ jc, descc, work, rwork, err, ierr( 3 ) )
3351 END IF
3352*
3353 IF( ierr( 3 ).NE.0 ) THEN
3354 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3355 $ WRITE( nout, fmt = 9998 )
3356 ELSE IF( err.GT.dble( thresh ) ) THEN
3357 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3358 $ WRITE( nout, fmt = 9997 ) err
3359 END IF
3360*
3361* Check the input-only arguments
3362*
3363 IF( lsame( transa, 'N' ) ) THEN
3364 CALL pzchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3365 ELSE
3366 CALL pzchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3367 END IF
3368*
3369 ELSE IF( nrout.EQ.6 ) THEN
3370*
3371* Test PZSYR2K
3372*
3373* Check the resulting matrix C
3374*
3375 IF( lsame( transa, 'N' ) ) THEN
3376 CALL pzmmch2( ictxt, uplo, 'No transpose', n, k, alpha, a,
3377 $ ia, ja, desca, b, ib, jb, descb, beta, c, pc,
3378 $ ic, jc, descc, work, rwork, err, ierr( 3 ) )
3379 ELSE
3380 CALL pzmmch2( ictxt, uplo, 'Transpose', n, k, alpha, a,
3381 $ ia, ja, desca, b, ib, jb, descb, beta, c, pc,
3382 $ ic, jc, descc, work, rwork, err,
3383 $ ierr( 3 ) )
3384 END IF
3385*
3386 IF( ierr( 3 ).NE.0 ) THEN
3387 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3388 $ WRITE( nout, fmt = 9998 )
3389 ELSE IF( err.GT.dble( thresh ) ) THEN
3390 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3391 $ WRITE( nout, fmt = 9997 ) err
3392 END IF
3393*
3394* Check the input-only arguments
3395*
3396 IF( lsame( transa, 'N' ) ) THEN
3397 CALL pzchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3398 CALL pzchkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3399 ELSE
3400 CALL pzchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3401 CALL pzchkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3402 END IF
3403*
3404 ELSE IF( nrout.EQ.7 ) THEN
3405*
3406* Test PZHER2K
3407*
3408* Check the resulting matrix C
3409*
3410 beta1 = dcmplx( dble( beta ), rzero )
3411 IF( lsame( transa, 'N' ) ) THEN
3412 CALL pzmmch2( ictxt, uplo, 'Hermitian', n, k, alpha, a, ia,
3413 $ ja, desca, b, ib, jb, descb, beta1, c, pc, ic,
3414 $ jc, descc, work, rwork, err, ierr( 3 ) )
3415 ELSE
3416 CALL pzmmch2( ictxt, uplo, 'Conjugate transpose', n, k,
3417 $ alpha, a, ia, ja, desca, b, ib, jb, descb,
3418 $ beta1, c, pc, ic, jc, descc, work, rwork, err,
3419 $ ierr( 3 ) )
3420 END IF
3421*
3422 IF( ierr( 3 ).NE.0 ) THEN
3423 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3424 $ WRITE( nout, fmt = 9998 )
3425 ELSE IF( err.GT.dble( thresh ) ) THEN
3426 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3427 $ WRITE( nout, fmt = 9997 ) err
3428 END IF
3429*
3430* Check the input-only arguments
3431*
3432 IF( lsame( transa, 'N' ) ) THEN
3433 CALL pzchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3434 CALL pzchkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3435 ELSE
3436 CALL pzchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3437 CALL pzchkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3438 END IF
3439*
3440 ELSE IF( nrout.EQ.8 ) THEN
3441*
3442* Test PZTRMM
3443*
3444* Check the resulting matrix B
3445*
3446 IF( lsame( side, 'L' ) ) THEN
3447 CALL pzmmch( ictxt, transa, 'No transpose', m, n, m,
3448 $ alpha, a, ia, ja, desca, c, ib, jb, descb,
3449 $ zero, b, pb, ib, jb, descb, work, rwork, err,
3450 $ ierr( 2 ) )
3451 ELSE
3452 CALL pzmmch( ictxt, 'No transpose', transa, m, n, n,
3453 $ alpha, c, ib, jb, descb, a, ia, ja, desca,
3454 $ zero, b, pb, ib, jb, descb, work, rwork, err,
3455 $ ierr( 2 ) )
3456 END IF
3457*
3458 IF( ierr( 2 ).NE.0 ) THEN
3459 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3460 $ WRITE( nout, fmt = 9998 )
3461 ELSE IF( err.GT.dble( thresh ) ) THEN
3462 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3463 $ WRITE( nout, fmt = 9997 ) err
3464 END IF
3465*
3466* Check the input-only arguments
3467*
3468 IF( lsame( side, 'L' ) ) THEN
3469 IF( lsame( uplo, 'L' ) ) THEN
3470 IF( lsame( diag, 'N' ) ) THEN
3471 CALL pb_zlaset( 'Upper', m-1, m-1, 0, rogue, rogue,
3472 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3473 ELSE
3474 CALL pb_zlaset( 'Upper', m, m, 0, rogue, one,
3475 $ a( ia+(ja-1)*desca( m_ ) ),
3476 $ desca( m_ ) )
3477 END IF
3478 ELSE
3479 IF( lsame( diag, 'N' ) ) THEN
3480 CALL pb_zlaset( 'Lower', m-1, m-1, 0, rogue, rogue,
3481 $ a( ia+1+(ja-1)*desca( m_ ) ),
3482 $ desca( m_ ) )
3483 ELSE
3484 CALL pb_zlaset( 'Lower', m, m, 0, rogue, one,
3485 $ a( ia+(ja-1)*desca( m_ ) ),
3486 $ desca( m_ ) )
3487 END IF
3488 END IF
3489 CALL pzchkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3490 ELSE
3491 IF( lsame( uplo, 'L' ) ) THEN
3492 IF( lsame( diag, 'N' ) ) THEN
3493 CALL pb_zlaset( 'Upper', n-1, n-1, 0, rogue, rogue,
3494 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3495 ELSE
3496 CALL pb_zlaset( 'Upper', n, n, 0, rogue, one,
3497 $ a( ia+(ja-1)*desca( m_ ) ),
3498 $ desca( m_ ) )
3499 END IF
3500 ELSE
3501 IF( lsame( diag, 'N' ) ) THEN
3502 CALL pb_zlaset( 'Lower', n-1, n-1, 0, rogue, rogue,
3503 $ a( ia+1+(ja-1)*desca( m_ ) ),
3504 $ desca( m_ ) )
3505 ELSE
3506 CALL pb_zlaset( 'Lower', n, n, 0, rogue, one,
3507 $ a( ia+(ja-1)*desca( m_ ) ),
3508 $ desca( m_ ) )
3509 END IF
3510 END IF
3511 CALL pzchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3512 END IF
3513*
3514 ELSE IF( nrout.EQ.9 ) THEN
3515*
3516* Test PZTRSM
3517*
3518* Check the resulting matrix B
3519*
3520 CALL ztrsm( side, uplo, transa, diag, m, n, alpha,
3521 $ a( ia+(ja-1)*desca( m_ ) ), desca( m_ ),
3522 $ b( ib+(jb-1)*descb( m_ ) ), descb( m_ ) )
3523 CALL pztrmm( side, uplo, transa, diag, m, n, alpha, pa, ia, ja,
3524 $ desca, pb, ib, jb, descb )
3525 IF( lsame( side, 'L' ) ) THEN
3526 CALL pzmmch( ictxt, transa, 'No transpose', m, n, m, alpha,
3527 $ a, ia, ja, desca, b, ib, jb, descb, zero, c,
3528 $ pb, ib, jb, descb, work, rwork, err,
3529 $ ierr( 2 ) )
3530 ELSE
3531 CALL pzmmch( ictxt, 'No transpose', transa, m, n, n, alpha,
3532 $ b, ib, jb, descb, a, ia, ja, desca, zero, c,
3533 $ pb, ib, jb, descb, work, rwork, err,
3534 $ ierr( 2 ) )
3535 END IF
3536*
3537 IF( ierr( 2 ).NE.0 ) THEN
3538 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3539 $ WRITE( nout, fmt = 9998 )
3540 ELSE IF( err.GT.dble( thresh ) ) THEN
3541 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3542 $ WRITE( nout, fmt = 9997 ) err
3543 END IF
3544*
3545* Check the input-only arguments
3546*
3547 IF( lsame( side, 'L' ) ) THEN
3548 IF( lsame( uplo, 'L' ) ) THEN
3549 IF( lsame( diag, 'N' ) ) THEN
3550 CALL pb_zlaset( 'Upper', m-1, m-1, 0, rogue, rogue,
3551 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3552 ELSE
3553 CALL pb_zlaset( 'Upper', m, m, 0, rogue, one,
3554 $ a( ia+(ja-1)*desca( m_ ) ),
3555 $ desca( m_ ) )
3556 END IF
3557 ELSE
3558 IF( lsame( diag, 'N' ) ) THEN
3559 CALL pb_zlaset( 'Lower', m-1, m-1, 0, rogue, rogue,
3560 $ a( ia+1+(ja-1)*desca( m_ ) ),
3561 $ desca( m_ ) )
3562 ELSE
3563 CALL pb_zlaset( 'Lower', m, m, 0, rogue, one,
3564 $ a( ia+(ja-1)*desca( m_ ) ),
3565 $ desca( m_ ) )
3566 END IF
3567 END IF
3568 CALL pzchkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3569 ELSE
3570 IF( lsame( uplo, 'L' ) ) THEN
3571 IF( lsame( diag, 'N' ) ) THEN
3572 CALL pb_zlaset( 'Upper', n-1, n-1, 0, rogue, rogue,
3573 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3574 ELSE
3575 CALL pb_zlaset( 'Upper', n, n, 0, rogue, one,
3576 $ a( ia+(ja-1)*desca( m_ ) ),
3577 $ desca( m_ ) )
3578 END IF
3579 ELSE
3580 IF( lsame( diag, 'N' ) ) THEN
3581 CALL pb_zlaset( 'Lower', n-1, n-1, 0, rogue, rogue,
3582 $ a( ia+1+(ja-1)*desca( m_ ) ),
3583 $ desca( m_ ) )
3584 ELSE
3585 CALL pb_zlaset( 'Lower', n, n, 0, rogue, one,
3586 $ a( ia+(ja-1)*desca( m_ ) ),
3587 $ desca( m_ ) )
3588 END IF
3589 END IF
3590 CALL pzchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3591 END IF
3592 ELSE IF( nrout.EQ.10 ) THEN
3593*
3594* Test PZGEADD
3595*
3596* Check the resulting matrix C
3597*
3598 CALL pzmmch3( 'All', transa, m, n, alpha, a, ia, ja, desca,
3599 $ beta, c, pc, ic, jc, descc, err, ierr( 3 ) )
3600*
3601* Check the input-only arguments
3602*
3603 IF( lsame( transa, 'N' ) ) THEN
3604 CALL pzchkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
3605 ELSE
3606 CALL pzchkmin( err, n, m, a, pa, ia, ja, desca, ierr( 1 ) )
3607 END IF
3608*
3609 ELSE IF( nrout.EQ.11 ) THEN
3610*
3611* Test PZTRADD
3612*
3613* Check the resulting matrix C
3614*
3615 CALL pzmmch3( uplo, transa, m, n, alpha, a, ia, ja, desca,
3616 $ beta, c, pc, ic, jc, descc, err, ierr( 3 ) )
3617*
3618* Check the input-only arguments
3619*
3620 IF( lsame( transa, 'N' ) ) THEN
3621 CALL pzchkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
3622 ELSE
3623 CALL pzchkmin( err, n, m, a, pa, ia, ja, desca, ierr( 1 ) )
3624 END IF
3625*
3626 END IF
3627*
3628 IF( ierr( 1 ).NE.0 ) THEN
3629 info = info + 1
3630 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3631 $ WRITE( nout, fmt = 9999 ) 'A'
3632 END IF
3633*
3634 IF( ierr( 2 ).NE.0 ) THEN
3635 info = info + 2
3636 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3637 $ WRITE( nout, fmt = 9999 ) 'B'
3638 END IF
3639*
3640 IF( ierr( 3 ).NE.0 ) THEN
3641 info = info + 4
3642 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3643 $ WRITE( nout, fmt = 9999 ) 'C'
3644 END IF
3645*
3646 9999 FORMAT( 2x, ' ***** ERROR: Matrix operand ', a,
3647 $ ' is incorrect.' )
3648 9998 FORMAT( 2x, ' ***** FATAL ERROR - Computed result is less ',
3649 $ 'than half accurate *****' )
3650 9997 FORMAT( 2x, ' ***** Test completed with maximum test ratio: ',
3651 $ f11.5, ' SUSPECT *****' )
3652*
3653 RETURN
3654*
3655* End of PZBLAS3TSTCHK
3656*
3657 END
pmdimchk
subroutine pmdimchk(ictxt, nout, m, n, matrix, ia, ja, desca, info)
Definition pblastst.f:202
icopy
subroutine icopy(n, sx, incx, sy, incy)
Definition pblastst.f:1525
pb_descset2
subroutine pb_descset2(desc, m, n, imb, inb, mb, nb, rsrc, csrc, ctxt, lld)
Definition pblastst.f:3172
pmdescchk
subroutine pmdescchk(ictxt, nout, matrix, desca, dta, ma, na, imba, inba, mba, nba, rsrca, csrca, mpa, nqa, iprea, imida, iposta, igap, gapmul, info)
Definition pblastst.f:746
pb_fceil
integer function pb_fceil(num, denom)
Definition pblastst.f:2696
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pdblastst.f:6769
pzbla3tstinfo
subroutine pzbla3tstinfo(summry, nout, nmat, diagval, sideval, trnaval, trnbval, uploval, mval, nval, kval, maval, naval, imbaval, mbaval, inbaval, nbaval, rscaval, cscaval, iaval, javal, mbval, nbval, imbbval, mbbval, inbbval, nbbval, rscbval, cscbval, ibval, jbval, mcval, ncval, imbcval, mbcval, inbcval, nbcval, rsccval, csccval, icval, jcval, ldval, ngrids, pval, ldpval, qval, ldqval, nblog, ltest, sof, tee, iam, igap, iverb, nprocs, thresh, alpha, beta, work)
Definition pzblas3tst.f:1417
pzblas3tstchk
subroutine pzblas3tstchk(ictxt, nout, nrout, side, uplo, transa, transb, diag, m, n, k, alpha, a, pa, ia, ja, desca, b, pb, ib, jb, descb, beta, c, pc, ic, jc, descc, thresh, rogue, work, rwork, info)
Definition pzblas3tst.f:2870
pzchkarg3
subroutine pzchkarg3(ictxt, nout, sname, side, uplo, transa, transb, diag, m, n, k, alpha, ia, ja, desca, ib, jb, descb, beta, ic, jc, descc, info)
Definition pzblas3tst.f:2539
pzbla3tst
program pzbla3tst
Definition pzblas3tst.f:12
pzblas3tstchke
subroutine pzblas3tstchke(ltest, inout, nprocs)
Definition pzblas3tst.f:2295
pzmprnt
subroutine pzmprnt(ictxt, nout, m, n, a, lda, irprnt, icprnt, cmatnm)
Definition pzblastst.f:3955
pzchkmout
subroutine pzchkmout(m, n, a, pa, ia, ja, desca, info)
Definition pzblastst.f:3633
pzipset
subroutine pzipset(toggle, n, a, ia, ja, desca)
Definition pzblastst.f:7045
pzlaset
subroutine pzlaset(uplo, m, n, alpha, beta, a, ia, ja, desca)
Definition pzblastst.f:7509
pb_zlaset
subroutine pb_zlaset(uplo, m, n, ioffd, alpha, beta, a, lda)
Definition pzblastst.f:10049
pzmmch
subroutine pzmmch(ictxt, transa, transb, m, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pzblastst.f:5336
pb_zchekpad
subroutine pb_zchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
Definition pzblastst.f:9875
pzmmch1
subroutine pzmmch1(ictxt, uplo, trans, n, k, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pzblastst.f:5789
pzlascal
subroutine pzlascal(type, m, n, alpha, a, ia, ja, desca)
Definition pzblastst.f:7984
pzmmch2
subroutine pzmmch2(ictxt, uplo, trans, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pzblastst.f:6169
pb_zfillpad
subroutine pb_zfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
Definition pzblastst.f:9762
pzmatee
subroutine pzmatee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:1190
pzmmch3
subroutine pzmmch3(uplo, trans, m, n, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, err, info)
Definition pzblastst.f:6585
pzchkmin
subroutine pzchkmin(errmax, m, n, a, pa, ia, ja, desca, info)
Definition pzblastst.f:3332
pb_pzlaprnt
subroutine pb_pzlaprnt(m, n, a, ia, ja, desca, irprnt, icprnt, cmatnm, nout, work)
Definition pzblastst.f:9304
pb_zlascal
subroutine pb_zlascal(uplo, m, n, ioffd, alpha, a, lda)
Definition pzblastst.f:10246
pzlagen
subroutine pzlagen(inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
Definition pzblastst.f:8492
pzoptee
subroutine pzoptee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:2
pzdimee
subroutine pzdimee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:455
lsame
logical function lsame(ca, cb)
Definition tools.f:1724