SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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
pmdimchk
subroutine pmdimchk(ictxt, nout, m, n, matrix, ia, ja, desca, info)
Definition pblastst.f:202
pvdimchk
subroutine pvdimchk(ictxt, nout, n, matrix, ix, jx, descx, incx, info)
Definition pblastst.f:3
icopy
subroutine icopy(n, sx, incx, sy, incy)
Definition pblastst.f:1525
pb_descset2
subroutine pb_descset2(desc, m, n, imb, inb, mb, nb, rsrc, csrc, ctxt, lld)
Definition pblastst.f:3172
pmdescchk
subroutine pmdescchk(ictxt, nout, matrix, desca, dta, ma, na, imba, inba, mba, nba, rsrca, csrca, mpa, nqa, iprea, imida, iposta, igap, gapmul, info)
Definition pblastst.f:746
pb_fceil
integer function pb_fceil(num, denom)
Definition pblastst.f:2696
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
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pdblastst.f:6769
pzbla2tst
program pzbla2tst
Definition pzblas2tst.f:11
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
pzblas2tstchke
subroutine pzblas2tstchke(ltest, inout, nprocs)
Definition pzblas2tst.f:2023
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
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
pzmprnt
subroutine pzmprnt(ictxt, nout, m, n, a, lda, irprnt, icprnt, cmatnm)
Definition pzblastst.f:3955
pzchkvin
subroutine pzchkvin(errmax, n, x, px, ix, jx, descx, incx, info)
Definition pzblastst.f:2582
pzchkmout
subroutine pzchkmout(m, n, a, pa, ia, ja, desca, info)
Definition pzblastst.f:3633
pzipset
subroutine pzipset(toggle, n, a, ia, ja, desca)
Definition pzblastst.f:7045
pzlaset
subroutine pzlaset(uplo, m, n, alpha, beta, a, ia, ja, desca)
Definition pzblastst.f:7509
pzvecee
subroutine pzvecee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:936
pb_zlaset
subroutine pb_zlaset(uplo, m, n, ioffd, alpha, beta, a, lda)
Definition pzblastst.f:10049
pb_zchekpad
subroutine pb_zchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
Definition pzblastst.f:9875
pzlascal
subroutine pzlascal(type, m, n, alpha, a, ia, ja, desca)
Definition pzblastst.f:7984
pb_zfillpad
subroutine pb_zfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
Definition pzblastst.f:9762
pzmatee
subroutine pzmatee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:1190
pzchkmin
subroutine pzchkmin(errmax, m, n, a, pa, ia, ja, desca, info)
Definition pzblastst.f:3332
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
pzchkvout
subroutine pzchkvout(n, x, px, ix, jx, descx, incx, info)
Definition pzblastst.f:2876
pb_pzlaprnt
subroutine pb_pzlaprnt(m, n, a, ia, ja, desca, irprnt, icprnt, cmatnm, nout, work)
Definition pzblastst.f:9304
pb_zlascal
subroutine pb_zlascal(uplo, m, n, ioffd, alpha, a, lda)
Definition pzblastst.f:10246
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
pzvprnt
subroutine pzvprnt(ictxt, nout, n, x, incx, irprnt, icprnt, cvecnm)
Definition pzblastst.f:4067
pzlagen
subroutine pzlagen(inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
Definition pzblastst.f:8492
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
pzoptee
subroutine pzoptee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:2
pzdimee
subroutine pzdimee(ictxt, nout, subptr, scode, sname)
Definition pzblastst.f:455
lsame
logical function lsame(ca, cb)
Definition tools.f:1724