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