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