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