ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
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
pdlascal
subroutine pdlascal(TYPE, M, N, ALPHA, A, IA, JA, DESCA)
Definition: pdblastst.f:7337
max
#define max(A, B)
Definition: pcgemr.c:180
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
pdblas3tstchke
subroutine pdblas3tstchke(LTEST, INOUT, NPROCS)
Definition: pdblas3tst.f:2194
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_descset2
subroutine pb_descset2(DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC, CTXT, LLD)
Definition: pblastst.f:3172
pddimee
subroutine pddimee(ICTXT, NOUT, SUBPTR, SCODE, SNAME)
Definition: pdblastst.f:455
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
lsame
logical function lsame(CA, CB)
Definition: tools.f:1724
pb_pdlaprnt
subroutine pb_pdlaprnt(M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT, CMATNM, NOUT, WORK)
Definition: pdblastst.f:8634
pb_dlaset
subroutine pb_dlaset(UPLO, M, N, IOFFD, ALPHA, BETA, A, LDA)
Definition: pdblastst.f:9359
pdoptee
subroutine pdoptee(ICTXT, NOUT, SUBPTR, SCODE, SNAME)
Definition: pdblastst.f:2
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
pdmatee
subroutine pdmatee(ICTXT, NOUT, SUBPTR, SCODE, SNAME)
Definition: pdblastst.f:1190
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
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
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
pdlaset
subroutine pdlaset(UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA)
Definition: pdblastst.f:6862
pdchkmout
subroutine pdchkmout(M, N, A, PA, IA, JA, DESCA, INFO)
Definition: pdblastst.f:3627
pdlagen
subroutine pdlagen(INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA, DESCA, IASEED, A, LDA)
Definition: pdblastst.f:7845
pb_dchekpad
subroutine pb_dchekpad(ICTXT, MESS, M, N, A, LDA, IPRE, IPOST, CHKVAL)
Definition: pdblastst.f:9192
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
pb_dlascal
subroutine pb_dlascal(UPLO, M, N, IOFFD, ALPHA, A, LDA)
Definition: pdblastst.f:9556
icopy
subroutine icopy(N, SX, INCX, SY, INCY)
Definition: pblastst.f:1525
pdba3tst
program pdba3tst
Definition: pdblas3tst.f:11
pdlamch
double precision function pdlamch(ICTXT, CMACH)
Definition: pdblastst.f:6769
pdmprnt
subroutine pdmprnt(ICTXT, NOUT, M, N, A, LDA, IRPRNT, ICPRNT, CMATNM)
Definition: pdblastst.f:3949
pmdimchk
subroutine pmdimchk(ICTXT, NOUT, M, N, MATRIX, IA, JA, DESCA, INFO)
Definition: pblastst.f:202
min
#define min(A, B)
Definition: pcgemr.c:181