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