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