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