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