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