ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pzblas1tst.f
Go to the documentation of this file.
1  BLOCK DATA
2  INTEGER NSUBS
3  parameter(nsubs = 10)
4  CHARACTER*7 SNAMES( NSUBS )
5  COMMON /snamec/snames
6  DATA snames/'PZSWAP ', 'PZSCAL ',
7  $ 'PZDSCAL', 'PZCOPY ', 'PZAXPY ',
8  $ 'PZDOTU ', 'PZDOTC ', 'PDZNRM2',
9  $ 'PDZASUM', 'PZAMAX'/
10  END BLOCK DATA
11 
12  PROGRAM pzbla1tst
13 *
14 * -- PBLAS testing driver (version 2.0.2) --
15 * Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
16 * May 1 2012
17 *
18 * Purpose
19 * =======
20 *
21 * PZBLA1TST is the main testing program for the PBLAS Level 1 routines.
22 *
23 * The program must be driven by a short data file. An annotated exam-
24 * ple of a data file can be obtained by deleting the first 3 characters
25 * from the following 46 lines:
26 * 'Level 1 PBLAS, Testing input file'
27 * 'Intel iPSC/860 hypercube, gamma model.'
28 * 'PZBLAS1TST.SUMM' output file name (if any)
29 * 6 device out
30 * F logical flag, T to stop on failures
31 * F logical flag, T to test error exits
32 * 0 verbosity, 0 for pass/fail, 1-3 for matrix dump on errors
33 * 10 the leading dimension gap
34 * 1 number of process grids (ordered pairs of P & Q)
35 * 2 2 1 4 2 3 8 values of P
36 * 2 2 4 1 3 2 1 values of Q
37 * (1.0D0, 0.0D0) value of ALPHA
38 * 2 number of tests problems
39 * 3 4 values of N
40 * 6 10 values of M_X
41 * 6 10 values of N_X
42 * 2 5 values of IMB_X
43 * 2 5 values of INB_X
44 * 2 5 values of MB_X
45 * 2 5 values of NB_X
46 * 0 1 values of RSRC_X
47 * 0 0 values of CSRC_X
48 * 1 1 values of IX
49 * 1 1 values of JX
50 * 1 1 values of INCX
51 * 6 10 values of M_Y
52 * 6 10 values of N_Y
53 * 2 5 values of IMB_Y
54 * 2 5 values of INB_Y
55 * 2 5 values of MB_Y
56 * 2 5 values of NB_Y
57 * 0 1 values of RSRC_Y
58 * 0 0 values of CSRC_Y
59 * 1 1 values of IY
60 * 1 1 values of JY
61 * 6 1 values of INCY
62 * PZSWAP T put F for no test in the same column
63 * PZSCAL T put F for no test in the same column
64 * PZDSCAL T put F for no test in the same column
65 * PZCOPY T put F for no test in the same column
66 * PZAXPY T put F for no test in the same column
67 * PZDOTU T put F for no test in the same column
68 * PZDOTC T put F for no test in the same column
69 * PDZNRM2 T put F for no test in the same column
70 * PDZASUM T put F for no test in the same column
71 * PZAMAX T put F for no test in the same column
72 *
73 * Internal Parameters
74 * ===================
75 *
76 * TOTMEM INTEGER
77 * TOTMEM is a machine-specific parameter indicating the maxi-
78 * mum amount of available memory per process in bytes. The
79 * user should customize TOTMEM to his platform. Remember to
80 * leave room in memory for the operating system, the BLACS
81 * buffer, etc. For example, on a system with 8 MB of memory
82 * per process (e.g., one processor on an Intel iPSC/860), the
83 * parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS,
84 * code, BLACS buffer, etc). However, for PVM, we usually set
85 * TOTMEM = 2000000. Some experimenting with the maximum value
86 * of TOTMEM may be required. By default, TOTMEM is 2000000.
87 *
88 * DBLESZ INTEGER
89 * ZPLXSZ INTEGER
90 * DBLESZ and ZPLXSZ indicate the length in bytes on the given
91 * platform for a double precision real and a double precision
92 * complex. By default, DBLESZ is set to eight and ZPLXSZ is set
93 * to sixteen.
94 *
95 * MEM COMPLEX*16 array
96 * MEM is an array of dimension TOTMEM / ZPLXSZ.
97 * All arrays used by SCALAPACK routines are allocated from this
98 * array MEM and referenced by pointers. The integer IPA, for
99 * example, is a pointer to the starting element of MEM for the
100 * matrix A.
101 *
102 * -- Written on April 1, 1998 by
103 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
104 *
105 * =====================================================================
106 *
107 * .. Parameters ..
108  INTEGER maxtests, maxgrids, gapmul, zplxsz, totmem,
109  $ memsiz, nsubs
110  DOUBLE PRECISION rzero
111  COMPLEX*16 padval, zero
112  parameter( maxtests = 20, maxgrids = 20, gapmul = 10,
113  $ zplxsz = 16, totmem = 2000000,
114  $ memsiz = totmem / zplxsz,
115  $ padval = ( -9923.0d+0, -9923.0d+0 ),
116  $ rzero = 0.0d+0, zero = ( 0.0d+0, 0.0d+0 ),
117  $ nsubs = 10 )
118  INTEGER block_cyclic_2d_inb, csrc_, ctxt_, dlen_,
119  $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
120  $ rsrc_
121  parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
122  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
123  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
124  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
125 * ..
126 * .. Local Scalars ..
127  LOGICAL errflg, sof, tee
128  INTEGER csrcx, csrcy, i, iam, ictxt, igap, imbx, imby,
129  $ imidx, imidy, inbx, inby, incx, incy, ipmatx,
130  $ ipmaty, ipostx, iposty, iprex, iprey, ipw, ipx,
131  $ ipy, iverb, ix, ixseed, iy, iyseed, j, jx, jy,
132  $ k, ldx, ldy, mbx, mby, memreqd, mpx, mpy, mx,
133  $ my, mycol, myrow, n, nbx, nby, ngrids, nout,
134  $ npcol, nprocs, nprow, nqx, nqy, ntests, nx, ny,
135  $ pisclr, rsrcx, rsrcy, tskip, tstcnt
136  DOUBLE PRECISION pusclr
137  COMPLEX*16 alpha, psclr
138 * ..
139 * .. Local Arrays ..
140  CHARACTER*80 outfile
141  LOGICAL ltest( nsubs ), ycheck( nsubs )
142  INTEGER cscxval( maxtests ), cscyval( maxtests ),
143  $ descx( dlen_ ), descxr( dlen_ ),
144  $ descy( dlen_ ), descyr( dlen_ ), ierr( 4 ),
145  $ imbxval( maxtests ), imbyval( maxtests ),
146  $ inbxval( maxtests ), inbyval( maxtests ),
147  $ incxval( maxtests ), incyval( maxtests ),
148  $ ixval( maxtests ), iyval( maxtests ),
149  $ jxval( maxtests ), jyval( maxtests ),
150  $ kfail( nsubs ), kpass( nsubs ), kskip( nsubs ),
151  $ ktests( nsubs ), mbxval( maxtests ),
152  $ mbyval( maxtests ), mxval( maxtests ),
153  $ myval( maxtests ), nbxval( maxtests ),
154  $ nbyval( maxtests ), nval( maxtests ),
155  $ nxval( maxtests ), nyval( maxtests ),
156  $ pval( maxtests ), qval( maxtests ),
157  $ rscxval( maxtests ), rscyval( maxtests )
158  COMPLEX*16 mem( memsiz )
159 * ..
160 * .. External Subroutines ..
161  EXTERNAL blacs_exit, blacs_get, blacs_gridexit,
162  $ blacs_gridinfo, blacs_gridinit, blacs_pinfo,
163  $ igsum2d, pb_descset2, pb_pzlaprnt, pb_zchekpad,
164  $ pb_zfillpad, pdzasum, pdznrm2, pvdescchk,
165  $ pvdimchk, pzamax, pzaxpy, pzbla1tstinfo,
166  $ pzblas1tstchk, pzblas1tstchke, pzchkarg1,
167  $ pzchkvout, pzcopy, pzdotc, pzdotu, pzdscal,
168  $ pzlagen, pzmprnt, pzscal, pzswap, pzvprnt
169 * ..
170 * .. Intrinsic Functions ..
171  INTRINSIC abs, dble, max, mod
172 * ..
173 * .. Common Blocks ..
174  CHARACTER*7 snames( nsubs )
175  LOGICAL abrtflg
176  INTEGER info, nblog
177  COMMON /snamec/snames
178  COMMON /infoc/info, nblog
179  COMMON /pberrorc/nout, abrtflg
180 * ..
181 * .. Data Statements ..
182  DATA ycheck/.true., .false., .false., .true.,
183  $ .true., .true., .true., .false., .false.,
184  $ .false./
185 * ..
186 * .. Executable Statements ..
187 *
188 * Initialization
189 *
190 * Set flag so that the PBLAS error handler will abort on errors.
191 *
192  abrtflg = .false.
193 *
194 * So far no error, will become true as soon as one error is found.
195 *
196  errflg = .false.
197 *
198 * Test counters
199 *
200  tskip = 0
201  tstcnt = 0
202 *
203 * Seeds for random matrix generations.
204 *
205  ixseed = 100
206  iyseed = 200
207 *
208 * So far no tests have been performed.
209 *
210  DO 10 i = 1, nsubs
211  kpass( i ) = 0
212  kskip( i ) = 0
213  kfail( i ) = 0
214  ktests( i ) = 0
215  10 CONTINUE
216 *
217 * Get starting information
218 *
219  CALL blacs_pinfo( iam, nprocs )
220  CALL pzbla1tstinfo( outfile, nout, ntests, nval, mxval, nxval,
221  $ imbxval, mbxval, inbxval, nbxval, rscxval,
222  $ cscxval, ixval, jxval, incxval, myval,
223  $ nyval, imbyval, mbyval, inbyval, nbyval,
224  $ rscyval, cscyval, iyval, jyval, incyval,
225  $ maxtests, ngrids, pval, maxgrids, qval,
226  $ maxgrids, ltest, sof, tee, iam, igap, iverb,
227  $ nprocs, alpha, mem )
228 *
229  IF( iam.EQ.0 ) THEN
230  WRITE( nout, fmt = 9979 )
231  WRITE( nout, fmt = * )
232  END IF
233 *
234 * If TEE is set then Test Error Exits of routines.
235 *
236  IF( tee )
237  $ CALL pzblas1tstchke( ltest, nout, nprocs )
238 *
239 * Loop over different process grids
240 *
241  DO 60 i = 1, ngrids
242 *
243  nprow = pval( i )
244  npcol = qval( i )
245 *
246 * Make sure grid information is correct
247 *
248  ierr( 1 ) = 0
249  IF( nprow.LT.1 ) THEN
250  IF( iam.EQ.0 )
251  $ WRITE( nout, fmt = 9999 ) 'GRID SIZE', 'NPROW', nprow
252  ierr( 1 ) = 1
253  ELSE IF( npcol.LT.1 ) THEN
254  IF( iam.EQ.0 )
255  $ WRITE( nout, fmt = 9999 ) 'GRID SIZE', 'NPCOL', npcol
256  ierr( 1 ) = 1
257  ELSE IF( nprow*npcol.GT.nprocs ) THEN
258  IF( iam.EQ.0 )
259  $ WRITE( nout, fmt = 9998 ) nprow*npcol, nprocs
260  ierr( 1 ) = 1
261  END IF
262 *
263  IF( ierr( 1 ).GT.0 ) THEN
264  IF( iam.EQ.0 )
265  $ WRITE( nout, fmt = 9997 ) 'GRID'
266  tskip = tskip + 1
267  GO TO 60
268  END IF
269 *
270 * Define process grid
271 *
272  CALL blacs_get( -1, 0, ictxt )
273  CALL blacs_gridinit( ictxt, 'Row-major', nprow, npcol )
274  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
275 *
276 * Go to bottom of process grid loop if this case doesn't use my
277 * process
278 *
279  IF( myrow.GE.nprow .OR. mycol.GE.npcol )
280  $ GO TO 60
281 *
282 * Loop over number of tests
283 *
284  DO 50 j = 1, ntests
285 *
286 * Get the test parameters
287 *
288  n = nval( j )
289  mx = mxval( j )
290  nx = nxval( j )
291  imbx = imbxval( j )
292  mbx = mbxval( j )
293  inbx = inbxval( j )
294  nbx = nbxval( j )
295  rsrcx = rscxval( j )
296  csrcx = cscxval( j )
297  ix = ixval( j )
298  jx = jxval( j )
299  incx = incxval( j )
300  my = myval( j )
301  ny = nyval( j )
302  imby = imbyval( j )
303  mby = mbyval( j )
304  inby = inbyval( j )
305  nby = nbyval( j )
306  rsrcy = rscyval( j )
307  csrcy = cscyval( j )
308  iy = iyval( j )
309  jy = jyval( j )
310  incy = incyval( j )
311 *
312  IF( iam.EQ.0 ) THEN
313  tstcnt = tstcnt + 1
314  WRITE( nout, fmt = * )
315  WRITE( nout, fmt = 9996 ) tstcnt, nprow, npcol
316  WRITE( nout, fmt = * )
317 *
318  WRITE( nout, fmt = 9995 )
319  WRITE( nout, fmt = 9994 )
320  WRITE( nout, fmt = 9995 )
321  WRITE( nout, fmt = 9993 ) n, ix, jx, mx, nx, imbx, inbx,
322  $ mbx, nbx, rsrcx, csrcx, incx
323 *
324  WRITE( nout, fmt = 9995 )
325  WRITE( nout, fmt = 9992 )
326  WRITE( nout, fmt = 9995 )
327  WRITE( nout, fmt = 9993 ) n, iy, jy, my, ny, imby, inby,
328  $ mby, nby, rsrcy, csrcy, incy
329  WRITE( nout, fmt = 9995 )
330  END IF
331 *
332 * Check the validity of the input and initialize DESC_
333 *
334  CALL pvdescchk( ictxt, nout, 'X', descx,
335  $ block_cyclic_2d_inb, mx, nx, imbx, inbx,
336  $ mbx, nbx, rsrcx, csrcx, incx, mpx, nqx,
337  $ iprex, imidx, ipostx, igap, gapmul,
338  $ ierr( 1 ) )
339  CALL pvdescchk( ictxt, nout, 'Y', descy,
340  $ block_cyclic_2d_inb, my, ny, imby, inby,
341  $ mby, nby, rsrcy, csrcy, incy, mpy, nqy,
342  $ iprey, imidy, iposty, igap, gapmul,
343  $ ierr( 2 ) )
344 *
345  IF( ierr( 1 ).GT.0 .OR. ierr( 2 ).GT.0 ) THEN
346  tskip = tskip + 1
347  GO TO 40
348  END IF
349 *
350  ldx = max( 1, mx )
351  ldy = max( 1, my )
352 *
353 * Assign pointers into MEM for matrices corresponding to
354 * vectors X and Y. Ex: IPX starts at position MEM( IPREX+1 ).
355 *
356  ipx = iprex + 1
357  ipy = ipx + descx( lld_ ) * nqx + ipostx + iprey
358  ipmatx = ipy + descy( lld_ ) * nqy + iposty
359  ipmaty = ipmatx + mx * nx
360  ipw = ipmaty + my * ny
361 *
362 * Check if sufficient memory.
363 * Requirement = mem for local part of parallel matrices +
364 * mem for whole matrices for comp. check +
365 * mem for recving comp. check error vals.
366 *
367  memreqd = ipw - 1 +
368  $ max( max( imbx, mbx ), max( imby, mby ) )
369  ierr( 1 ) = 0
370  IF( memreqd.GT.memsiz ) THEN
371  IF( iam.EQ.0 )
372  $ WRITE( nout, fmt = 9990 ) memreqd*zplxsz
373  ierr( 1 ) = 1
374  END IF
375 *
376 * Check all processes for an error
377 *
378  CALL igsum2d( ictxt, 'All', ' ', 1, 1, ierr, 1, -1, 0 )
379 *
380  IF( ierr( 1 ).GT.0 ) THEN
381  IF( iam.EQ.0 )
382  $ WRITE( nout, fmt = 9991 )
383  tskip = tskip + 1
384  GO TO 40
385  END IF
386 *
387 * Loop over all PBLAS 1 routines
388 *
389  DO 30 k = 1, nsubs
390 *
391 * Continue only if this sub has to be tested.
392 *
393  IF( .NOT.ltest( k ) )
394  $ GO TO 30
395 *
396  IF( iam.EQ.0 ) THEN
397  WRITE( nout, fmt = * )
398  WRITE( nout, fmt = 9989 ) snames( k )
399  END IF
400 *
401 * Check the validity of the operand sizes
402 *
403  CALL pvdimchk( ictxt, nout, n, 'X', ix, jx, descx, incx,
404  $ ierr( 1 ) )
405  CALL pvdimchk( ictxt, nout, n, 'Y', iy, jy, descy, incy,
406  $ ierr( 2 ) )
407 *
408  IF( ierr( 1 ).NE.0 .OR. ierr( 2 ).NE.0 ) THEN
409  kskip( k ) = kskip( k ) + 1
410  GO TO 30
411  END IF
412 *
413 * Generate distributed matrices X and Y
414 *
415  CALL pzlagen( .false., 'None', 'No diag', 0, mx, nx, 1,
416  $ 1, descx, ixseed, mem( ipx ),
417  $ descx( lld_ ) )
418  IF( ycheck( k ) )
419  $ CALL pzlagen( .false., 'None', 'No diag', 0, my, ny,
420  $ 1, 1, descy, iyseed, mem( ipy ),
421  $ descy( lld_ ) )
422 *
423 * Generate entire matrices on each process.
424 *
425  CALL pb_descset2( descxr, mx, nx, imbx, inbx, mbx, nbx,
426  $ -1, -1, ictxt, max( 1, mx ) )
427  CALL pzlagen( .false., 'None', 'No diag', 0, mx, nx, 1,
428  $ 1, descxr, ixseed, mem( ipmatx ),
429  $ descxr( lld_ ) )
430  IF( ycheck( k ) ) THEN
431  CALL pb_descset2( descyr, my, ny, imby, inby, mby,
432  $ nby, -1, -1, ictxt, max( 1, my ) )
433  CALL pzlagen( .false., 'None', 'No diag', 0, my, ny,
434  $ 1, 1, descyr, iyseed, mem( ipmaty ),
435  $ descyr( lld_ ) )
436  END IF
437 *
438 * Pad the guard zones of X, and Y
439 *
440  CALL pb_zfillpad( ictxt, mpx, nqx, mem( ipx-iprex ),
441  $ descx( lld_ ), iprex, ipostx, padval )
442 *
443  IF( ycheck( k ) ) THEN
444  CALL pb_zfillpad( ictxt, mpy, nqy, mem( ipy-iprey ),
445  $ descy( lld_ ), iprey, iposty,
446  $ padval )
447  END IF
448 *
449 * Initialize the check for INPUT only args.
450 *
451  info = 0
452  CALL pzchkarg1( ictxt, nout, snames( k ), n, alpha, ix,
453  $ jx, descx, incx, iy, jy, descy, incy,
454  $ info )
455 *
456  info = 0
457  psclr = zero
458  pusclr = rzero
459  pisclr = 0
460 *
461 * Print initial parallel data if IVERB >= 2.
462 *
463  IF( iverb.EQ.2 ) THEN
464  IF( incx.EQ.descx( m_ ) ) THEN
465  CALL pb_pzlaprnt( 1, n, mem( ipx ), ix, jx, descx,
466  $ 0, 0, 'PARALLEL_INITIAL_X', nout,
467  $ mem( ipw ) )
468  ELSE
469  CALL pb_pzlaprnt( n, 1, mem( ipx ), ix, jx, descx,
470  $ 0, 0, 'PARALLEL_INITIAL_X', nout,
471  $ mem( ipw ) )
472  END IF
473  IF( ycheck( k ) ) THEN
474  IF( incy.EQ.descy( m_ ) ) THEN
475  CALL pb_pzlaprnt( 1, n, mem( ipy ), iy, jy,
476  $ descy, 0, 0,
477  $ 'PARALLEL_INITIAL_Y', nout,
478  $ mem( ipw ) )
479  ELSE
480  CALL pb_pzlaprnt( n, 1, mem( ipy ), iy, jy,
481  $ descy, 0, 0,
482  $ 'PARALLEL_INITIAL_Y', nout,
483  $ mem( ipw ) )
484  END IF
485  END IF
486  ELSE IF( iverb.GE.3 ) THEN
487  CALL pb_pzlaprnt( mx, nx, mem( ipx ), 1, 1, descx, 0,
488  $ 0, 'PARALLEL_INITIAL_X', nout,
489  $ mem( ipw ) )
490  IF( ycheck( k ) )
491  $ CALL pb_pzlaprnt( my, ny, mem( ipy ), 1, 1, descy,
492  $ 0, 0, 'PARALLEL_INITIAL_Y', nout,
493  $ mem( ipw ) )
494  END IF
495 *
496 * Call the PBLAS routine
497 *
498  IF( k.EQ.1 ) THEN
499 *
500 * Test PZSWAP
501 *
502  CALL pzswap( n, mem( ipx ), ix, jx, descx, incx,
503  $ mem( ipy ), iy, jy, descy, incy )
504 *
505  ELSE IF( k.EQ.2 ) THEN
506 *
507 * Test PZSCAL
508 *
509  psclr = alpha
510  CALL pzscal( n, alpha, mem( ipx ), ix, jx, descx,
511  $ incx )
512 *
513  ELSE IF( k.EQ.3 ) THEN
514 *
515 * Test PZDSCAL
516 *
517  pusclr = dble( alpha )
518  CALL pzdscal( n, dble( alpha ), mem( ipx ), ix, jx,
519  $ descx, incx )
520 *
521  ELSE IF( k.EQ.4 ) THEN
522 *
523 * Test PZCOPY
524 *
525  CALL pzcopy( n, mem( ipx ), ix, jx, descx, incx,
526  $ mem( ipy ), iy, jy, descy, incy )
527 *
528  ELSE IF( k.EQ.5 ) THEN
529 *
530 * Test PZAXPY
531 *
532  psclr = alpha
533  CALL pzaxpy( n, alpha, mem( ipx ), ix, jx, descx,
534  $ incx, mem( ipy ), iy, jy, descy, incy )
535 *
536  ELSE IF( k.EQ.6 ) THEN
537 *
538 * Test PZDOTU
539 *
540  CALL pzdotu( n, psclr, mem( ipx ), ix, jx, descx,
541  $ incx, mem( ipy ), iy, jy, descy, incy )
542 *
543  ELSE IF( k.EQ.7 ) THEN
544 *
545 * Test PZDOTC
546 *
547  CALL pzdotc( n, psclr, mem( ipx ), ix, jx, descx,
548  $ incx, mem( ipy ), iy, jy, descy, incy )
549 *
550  ELSE IF( k.EQ.8 ) THEN
551 *
552 * Test PDZNRM2
553 *
554  CALL pdznrm2( n, pusclr, mem( ipx ), ix, jx, descx,
555  $ incx )
556 *
557  ELSE IF( k.EQ.9 ) THEN
558 *
559 * Test PDZASUM
560 *
561  CALL pdzasum( n, pusclr, mem( ipx ), ix, jx, descx,
562  $ incx )
563 *
564  ELSE IF( k.EQ.10 ) THEN
565 *
566  CALL pzamax( n, psclr, pisclr, mem( ipx ), ix, jx,
567  $ descx, incx )
568 *
569  END IF
570 *
571 * Check if the operation has been performed.
572 *
573  IF( info.NE.0 ) THEN
574  kskip( k ) = kskip( k ) + 1
575  IF( iam.EQ.0 )
576  $ WRITE( nout, fmt = 9978 ) info
577  GO TO 30
578  END IF
579 *
580 * Check the computations
581 *
582  CALL pzblas1tstchk( ictxt, nout, k, n, psclr, pusclr,
583  $ pisclr, mem( ipmatx ), mem( ipx ),
584  $ ix, jx, descx, incx, mem( ipmaty ),
585  $ mem( ipy ), iy, jy, descy, incy,
586  $ info )
587  IF( mod( info, 2 ).EQ.1 ) THEN
588  ierr( 1 ) = 1
589  ELSE IF( mod( info / 2, 2 ).EQ.1 ) THEN
590  ierr( 2 ) = 1
591  ELSE IF( info.NE.0 ) THEN
592  ierr( 1 ) = 1
593  ierr( 2 ) = 1
594  END IF
595 *
596 * Check padding
597 *
598  CALL pb_zchekpad( ictxt, snames( k ), mpx, nqx,
599  $ mem( ipx-iprex ), descx( lld_ ),
600  $ iprex, ipostx, padval )
601  IF( ycheck( k ) ) THEN
602  CALL pb_zchekpad( ictxt, snames( k ), mpy, nqy,
603  $ mem( ipy-iprey ), descy( lld_ ),
604  $ iprey, iposty, padval )
605  END IF
606 *
607 * Check input-only scalar arguments
608 *
609  info = 1
610  CALL pzchkarg1( ictxt, nout, snames( k ), n, alpha, ix,
611  $ jx, descx, incx, iy, jy, descy, incy,
612  $ info )
613 *
614 * Check input-only array arguments
615 *
616  CALL pzchkvout( n, mem( ipmatx ), mem( ipx ), ix, jx,
617  $ descx, incx, ierr( 3 ) )
618 *
619  IF( ierr( 3 ).NE.0 ) THEN
620  IF( iam.EQ.0 )
621  $ WRITE( nout, fmt = 9986 ) 'PARALLEL_X', snames( k )
622  END IF
623 *
624  IF( ycheck( k ) ) THEN
625  CALL pzchkvout( n, mem( ipmaty ), mem( ipy ), iy, jy,
626  $ descy, incy, ierr( 4 ) )
627  IF( ierr( 4 ).NE.0 ) THEN
628  IF( iam.EQ.0 )
629  $ WRITE( nout, fmt = 9986 ) 'PARALLEL_Y',
630  $ snames( k )
631  END IF
632  END IF
633 *
634 * Only node 0 prints computational test result
635 *
636  IF( info.NE.0 .OR. ierr( 1 ).NE.0 .OR.
637  $ ierr( 2 ).NE.0 .OR. ierr( 3 ).NE.0 .OR.
638  $ ierr( 4 ).NE. 0 ) THEN
639  IF( iam.EQ.0 )
640  $ WRITE( nout, fmt = 9988 ) snames( k )
641  kfail( k ) = kfail( k ) + 1
642  errflg = .true.
643  ELSE
644  IF( iam.EQ.0 )
645  $ WRITE( nout, fmt = 9987 ) snames( k )
646  kpass( k ) = kpass( k ) + 1
647  END IF
648 *
649 * Dump matrix if IVERB >= 1 and error.
650 *
651  IF( iverb.GE.1 .AND. errflg ) THEN
652  IF( ierr( 3 ).NE.0 .OR. iverb.GE.3 ) THEN
653  CALL pzmprnt( ictxt, nout, mx, nx, mem( ipmatx ),
654  $ ldx, 0, 0, 'SERIAL_X' )
655  CALL pb_pzlaprnt( mx, nx, mem( ipx ), 1, 1, descx,
656  $ 0, 0, 'PARALLEL_X', nout,
657  $ mem( ipmatx ) )
658  ELSE IF( ierr( 1 ).NE.0 ) THEN
659  IF( n.GT.0 )
660  $ CALL pzvprnt( ictxt, nout, n,
661  $ mem( ipmatx+ix-1+(jx-1)*ldx ),
662  $ incx, 0, 0, 'SERIAL_X' )
663  IF( incx.EQ.descx( m_ ) ) THEN
664  CALL pb_pzlaprnt( 1, n, mem( ipx ), ix, jx,
665  $ descx, 0, 0, 'PARALLEL_X',
666  $ nout, mem( ipmatx ) )
667  ELSE
668  CALL pb_pzlaprnt( n, 1, mem( ipx ), ix, jx,
669  $ descx, 0, 0, 'PARALLEL_X',
670  $ nout, mem( ipmatx ) )
671  END IF
672  END IF
673  IF( ycheck( k ) ) THEN
674  IF( ierr( 4 ).NE.0 .OR. iverb.GE.3 ) THEN
675  CALL pzmprnt( ictxt, nout, my, ny,
676  $ mem( ipmaty ), ldy, 0, 0,
677  $ 'SERIAL_Y' )
678  CALL pb_pzlaprnt( my, ny, mem( ipy ), 1, 1,
679  $ descy, 0, 0, 'PARALLEL_Y',
680  $ nout, mem( ipmatx ) )
681  ELSE IF( ierr( 2 ).NE.0 ) THEN
682  IF( n.GT.0 )
683  $ CALL pzvprnt( ictxt, nout, n,
684  $ mem( ipmaty+iy-1+(jy-1)*ldy ),
685  $ incy, 0, 0, 'SERIAL_Y' )
686  IF( incy.EQ.descy( m_ ) ) THEN
687  CALL pb_pzlaprnt( 1, n, mem( ipy ), iy, jy,
688  $ descy, 0, 0, 'PARALLEL_Y',
689  $ nout, mem( ipmatx ) )
690  ELSE
691  CALL pb_pzlaprnt( n, 1, mem( ipy ), iy, jy,
692  $ descy, 0, 0, 'PARALLEL_Y',
693  $ nout, mem( ipmatx ) )
694  END IF
695  END IF
696  END IF
697  END IF
698 *
699 * Leave if error and "Stop On Failure"
700 *
701  IF( sof.AND.errflg )
702  $ GO TO 70
703 *
704  30 CONTINUE
705 *
706  40 IF( iam.EQ.0 ) THEN
707  WRITE( nout, fmt = * )
708  WRITE( nout, fmt = 9985 ) j
709  END IF
710 *
711  50 CONTINUE
712 *
713  CALL blacs_gridexit( ictxt )
714 *
715  60 CONTINUE
716 *
717 * Come here, if error and "Stop On Failure"
718 *
719  70 CONTINUE
720 *
721 * Before printing out final stats, add TSKIP to all skips
722 *
723  DO 80 i = 1, nsubs
724  IF( ltest( i ) ) THEN
725  kskip( i ) = kskip( i ) + tskip
726  ktests( i ) = kskip( i ) + kfail( i ) + kpass( i )
727  END IF
728  80 CONTINUE
729 *
730 * Print results
731 *
732  IF( iam.EQ.0 ) THEN
733  WRITE( nout, fmt = * )
734  WRITE( nout, fmt = 9981 )
735  WRITE( nout, fmt = * )
736  WRITE( nout, fmt = 9983 )
737  WRITE( nout, fmt = 9982 )
738 *
739  DO 90 i = 1, nsubs
740  WRITE( nout, fmt = 9984 ) '|', snames( i ), ktests( i ),
741  $ kpass( i ), kfail( i ), kskip( i )
742  90 CONTINUE
743  WRITE( nout, fmt = * )
744  WRITE( nout, fmt = 9980 )
745  WRITE( nout, fmt = * )
746 *
747  END IF
748 *
749  CALL blacs_exit( 0 )
750 *
751  9999 FORMAT( 'ILLEGAL ', a, ': ', a, ' = ', i10,
752  $ ' should be at least 1' )
753  9998 FORMAT( 'ILLEGAL GRID: NPROW*NPCOL = ', i4,
754  $ '. It can be at most', i4 )
755  9997 FORMAT( 'Bad ', a, ' parameters: going on to next test case.' )
756  9996 FORMAT( 2x, 'Test number ', i4 , ' started on a ', i6, ' x ',
757  $ i6, ' process grid.' )
758  9995 FORMAT( 2x, '---------------------------------------------------',
759  $ '--------------------------' )
760  9994 FORMAT( 2x, ' N IX JX MX NX IMBX INBX',
761  $ ' MBX NBX RSRCX CSRCX INCX' )
762  9993 FORMAT( 2x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i5,1x,i5,1x,i5,1x,i5,1x,
763  $ i5,1x,i5,1x,i6 )
764  9992 FORMAT( 2x, ' N IY JY MY NY IMBY INBY',
765  $ ' MBY NBY RSRCY CSRCY INCY' )
766  9991 FORMAT( 'Not enough memory for this test: going on to',
767  $ ' next test case.' )
768  9990 FORMAT( 'Not enough memory. Need: ', i12 )
769  9989 FORMAT( 2x, ' Tested Subroutine: ', a )
770  9988 FORMAT( 2x, ' ***** Computational check: ', a, ' ',
771  $ ' FAILED ',' *****' )
772  9987 FORMAT( 2x, ' ***** Computational check: ', a, ' ',
773  $ ' PASSED ',' *****' )
774  9986 FORMAT( 2x, ' ***** ERROR ***** Matrix operand ', a,
775  $ ' modified by ', a, ' *****' )
776  9985 FORMAT( 2x, 'Test number ', i4, ' completed.' )
777  9984 FORMAT( 2x,a1,2x,a7,8x,i4,6x,i4,5x,i4,4x,i4 )
778  9983 FORMAT( 2x, ' SUBROUTINE TOTAL TESTS PASSED FAILED ',
779  $ 'SKIPPED' )
780  9982 FORMAT( 2x, ' ---------- ----------- ------ ------ ',
781  $ '-------' )
782  9981 FORMAT( 2x, 'Testing Summary')
783  9980 FORMAT( 2x, 'End of Tests.' )
784  9979 FORMAT( 2x, 'Tests started.' )
785  9978 FORMAT( 2x, ' ***** Operation not supported, error code: ',
786  $ i5, ' *****' )
787 *
788  stop
789 *
790 * End of PZBLA1TST
791 *
792  END
793  SUBROUTINE pzbla1tstinfo( SUMMRY, NOUT, NMAT, NVAL, MXVAL,
794  $ NXVAL, IMBXVAL, MBXVAL, INBXVAL,
795  $ NBXVAL, RSCXVAL, CSCXVAL, IXVAL,
796  $ JXVAL, INCXVAL, MYVAL, NYVAL, IMBYVAL,
797  $ MBYVAL, INBYVAL, NBYVAL, RSCYVAL,
798  $ CSCYVAL, IYVAL, JYVAL, INCYVAL,
799  $ LDVAL, NGRIDS, PVAL, LDPVAL, QVAL,
800  $ LDQVAL, LTEST, SOF, TEE, IAM, IGAP,
801  $ IVERB, NPROCS, ALPHA, WORK )
802 *
803 * -- PBLAS test routine (version 2.0) --
804 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
805 * and University of California, Berkeley.
806 * April 1, 1998
807 *
808 * .. Scalar Arguments ..
809  LOGICAL SOF, TEE
810  INTEGER IAM, IGAP, IVERB, LDPVAL, LDQVAL, LDVAL,
811  $ NGRIDS, NMAT, NOUT, NPROCS
812  COMPLEX*16 ALPHA
813 * ..
814 * .. Array Arguments ..
815  CHARACTER*( * ) SUMMRY
816  LOGICAL LTEST( * )
817  INTEGER CSCXVAL( LDVAL ), CSCYVAL( LDVAL ),
818  $ imbxval( ldval ), imbyval( ldval ),
819  $ inbxval( ldval ), inbyval( ldval ),
820  $ incxval( ldval ), incyval( ldval ),
821  $ ixval( ldval ), iyval( ldval ), jxval( ldval ),
822  $ jyval( ldval ), mbxval( ldval ),
823  $ mbyval( ldval ), mxval( ldval ),
824  $ myval( ldval ), nbxval( ldval ),
825  $ nbyval( ldval ), nval( ldval ), nxval( ldval ),
826  $ nyval( ldval ), pval( ldpval ), qval( ldqval ),
827  $ rscxval( ldval ), rscyval( ldval ), work( * )
828 * ..
829 *
830 * Purpose
831 * =======
832 *
833 * PZBLA1TSTINFO get the needed startup information for testing various
834 * Level 1 PBLAS routines, and transmits it to all processes.
835 *
836 * Notes
837 * =====
838 *
839 * For packing the information we assumed that the length in bytes of an
840 * integer is equal to the length in bytes of a real single precision.
841 *
842 * Arguments
843 * =========
844 *
845 * SUMMRY (global output) CHARACTER*(*)
846 * On exit, SUMMRY is the name of output (summary) file (if
847 * any). SUMMRY is only defined for process 0.
848 *
849 * NOUT (global output) INTEGER
850 * On exit, NOUT specifies the unit number for the output file.
851 * When NOUT is 6, output to screen, when NOUT is 0, output to
852 * stderr. NOUT is only defined for process 0.
853 *
854 * NMAT (global output) INTEGER
855 * On exit, NMAT specifies the number of different test cases.
856 *
857 * NVAL (global output) INTEGER array
858 * On entry, NVAL is an array of dimension LDVAL. On exit, this
859 * array contains the values of N to run the code with.
860 *
861 * MXVAL (global output) INTEGER array
862 * On entry, MXVAL is an array of dimension LDVAL. On exit, this
863 * array contains the values of DESCX( M_ ) to run the code
864 * with.
865 *
866 * NXVAL (global output) INTEGER array
867 * On entry, NXVAL is an array of dimension LDVAL. On exit, this
868 * array contains the values of DESCX( N_ ) to run the code
869 * with.
870 *
871 * IMBXVAL (global output) INTEGER array
872 * On entry, IMBXVAL is an array of dimension LDVAL. On exit,
873 * this array contains the values of DESCX( IMB_ ) to run the
874 * code with.
875 *
876 * MBXVAL (global output) INTEGER array
877 * On entry, MBXVAL is an array of dimension LDVAL. On exit,
878 * this array contains the values of DESCX( MB_ ) to run the
879 * code with.
880 *
881 * INBXVAL (global output) INTEGER array
882 * On entry, INBXVAL is an array of dimension LDVAL. On exit,
883 * this array contains the values of DESCX( INB_ ) to run the
884 * code with.
885 *
886 * NBXVAL (global output) INTEGER array
887 * On entry, NBXVAL is an array of dimension LDVAL. On exit,
888 * this array contains the values of DESCX( NB_ ) to run the
889 * code with.
890 *
891 * RSCXVAL (global output) INTEGER array
892 * On entry, RSCXVAL is an array of dimension LDVAL. On exit,
893 * this array contains the values of DESCX( RSRC_ ) to run the
894 * code with.
895 *
896 * CSCXVAL (global output) INTEGER array
897 * On entry, CSCXVAL is an array of dimension LDVAL. On exit,
898 * this array contains the values of DESCX( CSRC_ ) to run the
899 * code with.
900 *
901 * IXVAL (global output) INTEGER array
902 * On entry, IXVAL is an array of dimension LDVAL. On exit, this
903 * array contains the values of IX to run the code with.
904 *
905 * JXVAL (global output) INTEGER array
906 * On entry, JXVAL is an array of dimension LDVAL. On exit, this
907 * array contains the values of JX to run the code with.
908 *
909 * INCXVAL (global output) INTEGER array
910 * On entry, INCXVAL is an array of dimension LDVAL. On exit,
911 * this array contains the values of INCX to run the code with.
912 *
913 * MYVAL (global output) INTEGER array
914 * On entry, MYVAL is an array of dimension LDVAL. On exit, this
915 * array contains the values of DESCY( M_ ) to run the code
916 * with.
917 *
918 * NYVAL (global output) INTEGER array
919 * On entry, NYVAL is an array of dimension LDVAL. On exit, this
920 * array contains the values of DESCY( N_ ) to run the code
921 * with.
922 *
923 * IMBYVAL (global output) INTEGER array
924 * On entry, IMBYVAL is an array of dimension LDVAL. On exit,
925 * this array contains the values of DESCY( IMB_ ) to run the
926 * code with.
927 *
928 * MBYVAL (global output) INTEGER array
929 * On entry, MBYVAL is an array of dimension LDVAL. On exit,
930 * this array contains the values of DESCY( MB_ ) to run the
931 * code with.
932 *
933 * INBYVAL (global output) INTEGER array
934 * On entry, INBYVAL is an array of dimension LDVAL. On exit,
935 * this array contains the values of DESCY( INB_ ) to run the
936 * code with.
937 *
938 * NBYVAL (global output) INTEGER array
939 * On entry, NBYVAL is an array of dimension LDVAL. On exit,
940 * this array contains the values of DESCY( NB_ ) to run the
941 * code with.
942 *
943 * RSCYVAL (global output) INTEGER array
944 * On entry, RSCYVAL is an array of dimension LDVAL. On exit,
945 * this array contains the values of DESCY( RSRC_ ) to run the
946 * code with.
947 *
948 * CSCYVAL (global output) INTEGER array
949 * On entry, CSCYVAL is an array of dimension LDVAL. On exit,
950 * this array contains the values of DESCY( CSRC_ ) to run the
951 * code with.
952 *
953 * IYVAL (global output) INTEGER array
954 * On entry, IYVAL is an array of dimension LDVAL. On exit, this
955 * array contains the values of IY to run the code with.
956 *
957 * JYVAL (global output) INTEGER array
958 * On entry, JYVAL is an array of dimension LDVAL. On exit, this
959 * array contains the values of JY to run the code with.
960 *
961 * INCYVAL (global output) INTEGER array
962 * On entry, INCYVAL is an array of dimension LDVAL. On exit,
963 * this array contains the values of INCY to run the code with.
964 *
965 * LDVAL (global input) INTEGER
966 * On entry, LDVAL specifies the maximum number of different va-
967 * lues that can be used for DESCX(:), IX, JX, INCX, DESCY(:),
968 * IY, JY and INCY. This is also the maximum number of test
969 * cases.
970 *
971 * NGRIDS (global output) INTEGER
972 * On exit, NGRIDS specifies the number of different values that
973 * can be used for P and Q.
974 *
975 * PVAL (global output) INTEGER array
976 * On entry, PVAL is an array of dimension LDPVAL. On exit, this
977 * array contains the values of P to run the code with.
978 *
979 * LDPVAL (global input) INTEGER
980 * On entry, LDPVAL specifies the maximum number of different
981 * values that can be used for P.
982 *
983 * QVAL (global output) INTEGER array
984 * On entry, QVAL is an array of dimension LDQVAL. On exit, this
985 * array contains the values of Q to run the code with.
986 *
987 * LDQVAL (global input) INTEGER
988 * On entry, LDQVAL specifies the maximum number of different
989 * values that can be used for Q.
990 *
991 * LTEST (global output) LOGICAL array
992 * On entry, LTEST is an array of dimension at least ten. On
993 * exit, if LTEST( i ) is .TRUE., the i-th Level 1 PBLAS routine
994 * will be tested. See the input file for the ordering of the
995 * routines.
996 *
997 * SOF (global output) LOGICAL
998 * On exit, if SOF is .TRUE., the tester will stop on the first
999 * detected failure. Otherwise, it won't.
1000 *
1001 * TEE (global output) LOGICAL
1002 * On exit, if TEE is .TRUE., the tester will perform the error
1003 * exit tests. These tests won't be performed otherwise.
1004 *
1005 * IAM (local input) INTEGER
1006 * On entry, IAM specifies the number of the process executing
1007 * this routine.
1008 *
1009 * IGAP (global output) INTEGER
1010 * On exit, IGAP specifies the user-specified gap used for pad-
1011 * ding. IGAP must be at least zero.
1012 *
1013 * IVERB (global output) INTEGER
1014 * On exit, IVERB specifies the output verbosity level: 0 for
1015 * pass/fail, 1, 2 or 3 for matrix dump on errors.
1016 *
1017 * NPROCS (global input) INTEGER
1018 * On entry, NPROCS specifies the total number of processes.
1019 *
1020 * ALPHA (global output) COMPLEX*16
1021 * On exit, ALPHA specifies the value of alpha to be used in all
1022 * the test cases.
1023 *
1024 * WORK (local workspace) INTEGER array
1025 * On entry, WORK is an array of dimension at least
1026 * MAX( 2, 2*NGRIDS+23*NMAT+NSUBS+4 ) with NSUBS equal to 10.
1027 * This array is used to pack all output arrays in order to send
1028 * the information in one message.
1029 *
1030 * -- Written on April 1, 1998 by
1031 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1032 *
1033 * =====================================================================
1034 *
1035 * .. Parameters ..
1036  INTEGER NIN, NSUBS
1037  PARAMETER ( NIN = 11, nsubs = 10 )
1038 * ..
1039 * .. Local Scalars ..
1040  LOGICAL LTESTT
1041  INTEGER I, ICTXT, J
1042  DOUBLE PRECISION EPS
1043 * ..
1044 * .. Local Arrays ..
1045  CHARACTER*7 SNAMET
1046  CHARACTER*79 USRINFO
1047 * ..
1048 * .. External Subroutines ..
1049  EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
1050  $ blacs_gridinit, blacs_setup, icopy, igebr2d,
1051  $ igebs2d, sgebr2d, sgebs2d, zgebr2d, zgebs2d
1052 * ..
1053 * .. External Functions ..
1054  DOUBLE PRECISION PDLAMCH
1055  EXTERNAL PDLAMCH
1056 * ..
1057 * .. Intrinsic Functions ..
1058  INTRINSIC max, min
1059 * ..
1060 * .. Common Blocks ..
1061  CHARACTER*7 SNAMES( NSUBS )
1062  COMMON /snamec/snames
1063 * ..
1064 * .. Executable Statements ..
1065 *
1066 * Process 0 reads the input data, broadcasts to other processes and
1067 * writes needed information to NOUT
1068 *
1069  IF( iam.EQ.0 ) THEN
1070 *
1071 * Open file and skip data file header
1072 *
1073  OPEN( nin, file='PZBLAS1TST.dat', status='OLD' )
1074  READ( nin, fmt = * ) summry
1075  summry = ' '
1076 *
1077 * Read in user-supplied info about machine type, compiler, etc.
1078 *
1079  READ( nin, fmt = 9999 ) usrinfo
1080 *
1081 * Read name and unit number for summary output file
1082 *
1083  READ( nin, fmt = * ) summry
1084  READ( nin, fmt = * ) nout
1085  IF( nout.NE.0 .AND. nout.NE.6 )
1086  $ OPEN( nout, file = summry, status = 'UNKNOWN' )
1087 *
1088 * Read and check the parameter values for the tests.
1089 *
1090 * Read the flag that indicates if Stop on Failure
1091 *
1092  READ( nin, fmt = * ) sof
1093 *
1094 * Read the flag that indicates if Test Error Exits
1095 *
1096  READ( nin, fmt = * ) tee
1097 *
1098 * Read the verbosity level
1099 *
1100  READ( nin, fmt = * ) iverb
1101  IF( iverb.LT.0 .OR. iverb.GT.3 )
1102  $ iverb = 0
1103 *
1104 * Read the leading dimension gap
1105 *
1106  READ( nin, fmt = * ) igap
1107  IF( igap.LT.0 )
1108  $ igap = 0
1109 *
1110 * Get number of grids
1111 *
1112  READ( nin, fmt = * ) ngrids
1113  IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
1114  WRITE( nout, fmt = 9998 ) 'Grids', ldpval
1115  GO TO 100
1116  ELSE IF( ngrids.GT.ldqval ) THEN
1117  WRITE( nout, fmt = 9998 ) 'Grids', ldqval
1118  GO TO 100
1119  END IF
1120 *
1121 * Get values of P and Q
1122 *
1123  READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
1124  READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
1125 *
1126 * Read ALPHA
1127 *
1128  READ( nin, fmt = * ) alpha
1129 *
1130 * Read number of tests.
1131 *
1132  READ( nin, fmt = * ) nmat
1133  IF( nmat.LT.1 .OR. nmat.GT.ldval ) THEN
1134  WRITE( nout, fmt = 9998 ) 'Tests', ldval
1135  GO TO 100
1136  END IF
1137 *
1138 * Read in input data into arrays.
1139 *
1140  READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
1141  READ( nin, fmt = * ) ( mxval( i ), i = 1, nmat )
1142  READ( nin, fmt = * ) ( nxval( i ), i = 1, nmat )
1143  READ( nin, fmt = * ) ( imbxval( i ), i = 1, nmat )
1144  READ( nin, fmt = * ) ( inbxval( i ), i = 1, nmat )
1145  READ( nin, fmt = * ) ( mbxval( i ), i = 1, nmat )
1146  READ( nin, fmt = * ) ( nbxval( i ), i = 1, nmat )
1147  READ( nin, fmt = * ) ( rscxval( i ), i = 1, nmat )
1148  READ( nin, fmt = * ) ( cscxval( i ), i = 1, nmat )
1149  READ( nin, fmt = * ) ( ixval( i ), i = 1, nmat )
1150  READ( nin, fmt = * ) ( jxval( i ), i = 1, nmat )
1151  READ( nin, fmt = * ) ( incxval( i ), i = 1, nmat )
1152  READ( nin, fmt = * ) ( myval( i ), i = 1, nmat )
1153  READ( nin, fmt = * ) ( nyval( i ), i = 1, nmat )
1154  READ( nin, fmt = * ) ( imbyval( i ), i = 1, nmat )
1155  READ( nin, fmt = * ) ( inbyval( i ), i = 1, nmat )
1156  READ( nin, fmt = * ) ( mbyval( i ), i = 1, nmat )
1157  READ( nin, fmt = * ) ( nbyval( i ), i = 1, nmat )
1158  READ( nin, fmt = * ) ( rscyval( i ), i = 1, nmat )
1159  READ( nin, fmt = * ) ( cscyval( i ), i = 1, nmat )
1160  READ( nin, fmt = * ) ( iyval( i ), i = 1, nmat )
1161  READ( nin, fmt = * ) ( jyval( i ), i = 1, nmat )
1162  READ( nin, fmt = * ) ( incyval( i ), i = 1, nmat )
1163 *
1164 * Read names of subroutines and flags which indicate
1165 * whether they are to be tested.
1166 *
1167  DO 10 i = 1, nsubs
1168  ltest( i ) = .false.
1169  10 CONTINUE
1170  20 CONTINUE
1171  READ( nin, fmt = 9996, END = 50 ) SNAMET, ltestt
1172  DO 30 i = 1, nsubs
1173  IF( snamet.EQ.snames( i ) )
1174  $ GO TO 40
1175  30 CONTINUE
1176 *
1177  WRITE( nout, fmt = 9995 )snamet
1178  GO TO 100
1179 *
1180  40 CONTINUE
1181  ltest( i ) = ltestt
1182  GO TO 20
1183 *
1184  50 CONTINUE
1185 *
1186 * Close input file
1187 *
1188  CLOSE ( nin )
1189 *
1190 * For pvm only: if virtual machine not set up, allocate it and
1191 * spawn the correct number of processes.
1192 *
1193  IF( nprocs.LT.1 ) THEN
1194  nprocs = 0
1195  DO 60 i = 1, ngrids
1196  nprocs = max( nprocs, pval( i )*qval( i ) )
1197  60 CONTINUE
1198  CALL blacs_setup( iam, nprocs )
1199  END IF
1200 *
1201 * Temporarily define blacs grid to include all processes so
1202 * information can be broadcast to all processes
1203 *
1204  CALL blacs_get( -1, 0, ictxt )
1205  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1206 *
1207 * Compute machine epsilon
1208 *
1209  eps = pdlamch( ictxt, 'eps' )
1210 *
1211 * Pack information arrays and broadcast
1212 *
1213  CALL zgebs2d( ictxt, 'All', ' ', 1, 1, alpha, 1 )
1214 *
1215  work( 1 ) = ngrids
1216  work( 2 ) = nmat
1217  CALL igebs2d( ictxt, 'All', ' ', 2, 1, work, 2 )
1218 *
1219  i = 1
1220  IF( sof ) THEN
1221  work( i ) = 1
1222  ELSE
1223  work( i ) = 0
1224  END IF
1225  i = i + 1
1226  IF( tee ) THEN
1227  work( i ) = 1
1228  ELSE
1229  work( i ) = 0
1230  END IF
1231  i = i + 1
1232  work( i ) = iverb
1233  i = i + 1
1234  work( i ) = igap
1235  i = i + 1
1236  CALL icopy( ngrids, pval, 1, work( i ), 1 )
1237  i = i + ngrids
1238  CALL icopy( ngrids, qval, 1, work( i ), 1 )
1239  i = i + ngrids
1240  CALL icopy( nmat, nval, 1, work( i ), 1 )
1241  i = i + nmat
1242  CALL icopy( nmat, mxval, 1, work( i ), 1 )
1243  i = i + nmat
1244  CALL icopy( nmat, nxval, 1, work( i ), 1 )
1245  i = i + nmat
1246  CALL icopy( nmat, imbxval, 1, work( i ), 1 )
1247  i = i + nmat
1248  CALL icopy( nmat, inbxval, 1, work( i ), 1 )
1249  i = i + nmat
1250  CALL icopy( nmat, mbxval, 1, work( i ), 1 )
1251  i = i + nmat
1252  CALL icopy( nmat, nbxval, 1, work( i ), 1 )
1253  i = i + nmat
1254  CALL icopy( nmat, rscxval, 1, work( i ), 1 )
1255  i = i + nmat
1256  CALL icopy( nmat, cscxval, 1, work( i ), 1 )
1257  i = i + nmat
1258  CALL icopy( nmat, ixval, 1, work( i ), 1 )
1259  i = i + nmat
1260  CALL icopy( nmat, jxval, 1, work( i ), 1 )
1261  i = i + nmat
1262  CALL icopy( nmat, incxval, 1, work( i ), 1 )
1263  i = i + nmat
1264  CALL icopy( nmat, myval, 1, work( i ), 1 )
1265  i = i + nmat
1266  CALL icopy( nmat, nyval, 1, work( i ), 1 )
1267  i = i + nmat
1268  CALL icopy( nmat, imbyval, 1, work( i ), 1 )
1269  i = i + nmat
1270  CALL icopy( nmat, inbyval, 1, work( i ), 1 )
1271  i = i + nmat
1272  CALL icopy( nmat, mbyval, 1, work( i ), 1 )
1273  i = i + nmat
1274  CALL icopy( nmat, nbyval, 1, work( i ), 1 )
1275  i = i + nmat
1276  CALL icopy( nmat, rscyval, 1, work( i ), 1 )
1277  i = i + nmat
1278  CALL icopy( nmat, cscyval, 1, work( i ), 1 )
1279  i = i + nmat
1280  CALL icopy( nmat, iyval, 1, work( i ), 1 )
1281  i = i + nmat
1282  CALL icopy( nmat, jyval, 1, work( i ), 1 )
1283  i = i + nmat
1284  CALL icopy( nmat, incyval, 1, work( i ), 1 )
1285  i = i + nmat
1286 *
1287  DO 70 j = 1, nsubs
1288  IF( ltest( j ) ) THEN
1289  work( i ) = 1
1290  ELSE
1291  work( i ) = 0
1292  END IF
1293  i = i + 1
1294  70 CONTINUE
1295  i = i - 1
1296  CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
1297 *
1298 * regurgitate input
1299 *
1300  WRITE( nout, fmt = 9999 ) 'Level 1 PBLAS testing program.'
1301  WRITE( nout, fmt = 9999 ) usrinfo
1302  WRITE( nout, fmt = * )
1303  WRITE( nout, fmt = 9999 )
1304  $ 'Tests of the complex double precision '//
1305  $ 'Level 1 PBLAS'
1306  WRITE( nout, fmt = * )
1307  WRITE( nout, fmt = 9999 )
1308  $ 'The following parameter values will be used:'
1309  WRITE( nout, fmt = * )
1310  WRITE( nout, fmt = 9993 ) nmat
1311  WRITE( nout, fmt = 9992 ) ngrids
1312  WRITE( nout, fmt = 9990 )
1313  $ 'P', ( pval(i), i = 1, min(ngrids, 5) )
1314  IF( ngrids.GT.5 )
1315  $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 6,
1316  $ min( 10, ngrids ) )
1317  IF( ngrids.GT.10 )
1318  $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 11,
1319  $ min( 15, ngrids ) )
1320  IF( ngrids.GT.15 )
1321  $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 16, ngrids )
1322  WRITE( nout, fmt = 9990 )
1323  $ 'Q', ( qval(i), i = 1, min(ngrids, 5) )
1324  IF( ngrids.GT.5 )
1325  $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 6,
1326  $ min( 10, ngrids ) )
1327  IF( ngrids.GT.10 )
1328  $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 11,
1329  $ min( 15, ngrids ) )
1330  IF( ngrids.GT.15 )
1331  $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 16, ngrids )
1332  WRITE( nout, fmt = 9988 ) sof
1333  WRITE( nout, fmt = 9987 ) tee
1334  WRITE( nout, fmt = 9983 ) igap
1335  WRITE( nout, fmt = 9986 ) iverb
1336  WRITE( nout, fmt = 9982 ) alpha
1337  IF( ltest( 1 ) ) THEN
1338  WRITE( nout, fmt = 9985 ) snames( 1 ), ' ... Yes'
1339  ELSE
1340  WRITE( nout, fmt = 9985 ) snames( 1 ), ' ... No '
1341  END IF
1342  DO 80 i = 2, nsubs
1343  IF( ltest( i ) ) THEN
1344  WRITE( nout, fmt = 9984 ) snames( i ), ' ... Yes'
1345  ELSE
1346  WRITE( nout, fmt = 9984 ) snames( i ), ' ... No '
1347  END IF
1348  80 CONTINUE
1349  WRITE( nout, fmt = 9994 ) eps
1350  WRITE( nout, fmt = * )
1351 *
1352  ELSE
1353 *
1354 * If in pvm, must participate setting up virtual machine
1355 *
1356  IF( nprocs.LT.1 )
1357  $ CALL blacs_setup( iam, nprocs )
1358 *
1359 * Temporarily define blacs grid to include all processes so
1360 * information can be broadcast to all processes
1361 *
1362  CALL blacs_get( -1, 0, ictxt )
1363  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1364 *
1365 * Compute machine epsilon
1366 *
1367  eps = pdlamch( ictxt, 'eps' )
1368 *
1369  CALL zgebr2d( ictxt, 'All', ' ', 1, 1, alpha, 1, 0, 0 )
1370 *
1371  CALL igebr2d( ictxt, 'All', ' ', 2, 1, work, 2, 0, 0 )
1372  ngrids = work( 1 )
1373  nmat = work( 2 )
1374 *
1375  i = 2*ngrids + 23*nmat + nsubs + 4
1376  CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
1377 *
1378  i = 1
1379  IF( work( i ).EQ.1 ) THEN
1380  sof = .true.
1381  ELSE
1382  sof = .false.
1383  END IF
1384  i = i + 1
1385  IF( work( i ).EQ.1 ) THEN
1386  tee = .true.
1387  ELSE
1388  tee = .false.
1389  END IF
1390  i = i + 1
1391  iverb = work( i )
1392  i = i + 1
1393  igap = work( i )
1394  i = i + 1
1395  CALL icopy( ngrids, work( i ), 1, pval, 1 )
1396  i = i + ngrids
1397  CALL icopy( ngrids, work( i ), 1, qval, 1 )
1398  i = i + ngrids
1399  CALL icopy( nmat, work( i ), 1, nval, 1 )
1400  i = i + nmat
1401  CALL icopy( nmat, work( i ), 1, mxval, 1 )
1402  i = i + nmat
1403  CALL icopy( nmat, work( i ), 1, nxval, 1 )
1404  i = i + nmat
1405  CALL icopy( nmat, work( i ), 1, imbxval, 1 )
1406  i = i + nmat
1407  CALL icopy( nmat, work( i ), 1, inbxval, 1 )
1408  i = i + nmat
1409  CALL icopy( nmat, work( i ), 1, mbxval, 1 )
1410  i = i + nmat
1411  CALL icopy( nmat, work( i ), 1, nbxval, 1 )
1412  i = i + nmat
1413  CALL icopy( nmat, work( i ), 1, rscxval, 1 )
1414  i = i + nmat
1415  CALL icopy( nmat, work( i ), 1, cscxval, 1 )
1416  i = i + nmat
1417  CALL icopy( nmat, work( i ), 1, ixval, 1 )
1418  i = i + nmat
1419  CALL icopy( nmat, work( i ), 1, jxval, 1 )
1420  i = i + nmat
1421  CALL icopy( nmat, work( i ), 1, incxval, 1 )
1422  i = i + nmat
1423  CALL icopy( nmat, work( i ), 1, myval, 1 )
1424  i = i + nmat
1425  CALL icopy( nmat, work( i ), 1, nyval, 1 )
1426  i = i + nmat
1427  CALL icopy( nmat, work( i ), 1, imbyval, 1 )
1428  i = i + nmat
1429  CALL icopy( nmat, work( i ), 1, inbyval, 1 )
1430  i = i + nmat
1431  CALL icopy( nmat, work( i ), 1, mbyval, 1 )
1432  i = i + nmat
1433  CALL icopy( nmat, work( i ), 1, nbyval, 1 )
1434  i = i + nmat
1435  CALL icopy( nmat, work( i ), 1, rscyval, 1 )
1436  i = i + nmat
1437  CALL icopy( nmat, work( i ), 1, cscyval, 1 )
1438  i = i + nmat
1439  CALL icopy( nmat, work( i ), 1, iyval, 1 )
1440  i = i + nmat
1441  CALL icopy( nmat, work( i ), 1, jyval, 1 )
1442  i = i + nmat
1443  CALL icopy( nmat, work( i ), 1, incyval, 1 )
1444  i = i + nmat
1445 *
1446  DO 90 j = 1, nsubs
1447  IF( work( i ).EQ.1 ) THEN
1448  ltest( j ) = .true.
1449  ELSE
1450  ltest( j ) = .false.
1451  END IF
1452  i = i + 1
1453  90 CONTINUE
1454 *
1455  END IF
1456 *
1457  CALL blacs_gridexit( ictxt )
1458 *
1459  RETURN
1460 *
1461  100 WRITE( nout, fmt = 9997 )
1462  CLOSE( nin )
1463  IF( nout.NE.6 .AND. nout.NE.0 )
1464  $ CLOSE( nout )
1465  CALL blacs_abort( ictxt, 1 )
1466 *
1467  stop
1468 *
1469  9999 FORMAT( a )
1470  9998 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
1471  $ 'than ', i2 )
1472  9997 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
1473  9996 FORMAT( a7, l2 )
1474  9995 FORMAT( ' Subprogram name ', a7, ' not recognized',
1475  $ /' ******* TESTS ABANDONED *******' )
1476  9994 FORMAT( 2x, 'Relative machine precision (eps) is taken to be ',
1477  $ e18.6 )
1478  9993 FORMAT( 2x, 'Number of Tests : ', i6 )
1479  9992 FORMAT( 2x, 'Number of process grids : ', i6 )
1480  9991 FORMAT( 2x, ' : ', 5i6 )
1481  9990 FORMAT( 2x, a1, ' : ', 5i6 )
1482  9988 FORMAT( 2x, 'Stop on failure flag : ', l6 )
1483  9987 FORMAT( 2x, 'Test for error exits flag : ', l6 )
1484  9986 FORMAT( 2x, 'Verbosity level : ', i6 )
1485  9985 FORMAT( 2x, 'Routines to be tested : ', a, a8 )
1486  9984 FORMAT( 2x, ' ', a, a8 )
1487  9983 FORMAT( 2x, 'Leading dimension gap : ', i6 )
1488  9982 FORMAT( 2x, 'Alpha : (', g16.6,
1489  $ ',', g16.6, ')' )
1490 *
1491 * End of PZBLA1TSTINFO
1492 *
1493  END
1494  SUBROUTINE pzblas1tstchke( LTEST, INOUT, NPROCS )
1495 *
1496 * -- PBLAS test routine (version 2.0) --
1497 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1498 * and University of California, Berkeley.
1499 * April 1, 1998
1500 *
1501 * .. Scalar Arguments ..
1502  INTEGER INOUT, NPROCS
1503 * ..
1504 * .. Array Arguments ..
1505  LOGICAL LTEST( * )
1506 * ..
1507 *
1508 * Purpose
1509 * =======
1510 *
1511 * PZBLAS1TSTCHKE tests the error exits of the Level 1 PBLAS.
1512 *
1513 * Notes
1514 * =====
1515 *
1516 * A description vector is associated with each 2D block-cyclicly dis-
1517 * tributed matrix. This vector stores the information required to
1518 * establish the mapping between a matrix entry and its corresponding
1519 * process and memory location.
1520 *
1521 * In the following comments, the character _ should be read as
1522 * "of the distributed matrix". Let A be a generic term for any 2D
1523 * block cyclicly distributed matrix. Its description vector is DESCA:
1524 *
1525 * NOTATION STORED IN EXPLANATION
1526 * ---------------- --------------- ------------------------------------
1527 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1528 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1529 * the NPROW x NPCOL BLACS process grid
1530 * A is distributed over. The context
1531 * itself is global, but the handle
1532 * (the integer value) may vary.
1533 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
1534 * ted matrix A, M_A >= 0.
1535 * N_A (global) DESCA( N_ ) The number of columns in the distri-
1536 * buted matrix A, N_A >= 0.
1537 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1538 * block of the matrix A, IMB_A > 0.
1539 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
1540 * left block of the matrix A,
1541 * INB_A > 0.
1542 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1543 * bute the last M_A-IMB_A rows of A,
1544 * MB_A > 0.
1545 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1546 * bute the last N_A-INB_A columns of
1547 * A, NB_A > 0.
1548 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1549 * row of the matrix A is distributed,
1550 * NPROW > RSRC_A >= 0.
1551 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1552 * first column of A is distributed.
1553 * NPCOL > CSRC_A >= 0.
1554 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1555 * array storing the local blocks of
1556 * the distributed matrix A,
1557 * IF( Lc( 1, N_A ) > 0 )
1558 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
1559 * ELSE
1560 * LLD_A >= 1.
1561 *
1562 * Let K be the number of rows of a matrix A starting at the global in-
1563 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1564 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1565 * receive if these K rows were distributed over NPROW processes. If K
1566 * is the number of columns of a matrix A starting at the global index
1567 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1568 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1569 * these K columns were distributed over NPCOL processes.
1570 *
1571 * The values of Lr() and Lc() may be determined via a call to the func-
1572 * tion PB_NUMROC:
1573 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1574 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1575 *
1576 * Arguments
1577 * =========
1578 *
1579 * LTEST (global input) LOGICAL array
1580 * On entry, LTEST is an array of dimension at least 10 (NSUBS).
1581 * If LTEST( 1 ) is .TRUE., PZSWAP will be tested;
1582 * If LTEST( 2 ) is .TRUE., PZSCAL will be tested;
1583 * If LTEST( 3 ) is .TRUE., PZDSCAL will be tested;
1584 * If LTEST( 4 ) is .TRUE., PZCOPY will be tested;
1585 * If LTEST( 5 ) is .TRUE., PZAXPY will be tested;
1586 * If LTEST( 6 ) is .TRUE., PZDOTU will be tested;
1587 * If LTEST( 7 ) is .TRUE., PZDOTC will be tested;
1588 * If LTEST( 8 ) is .TRUE., PDZNRM2 will be tested;
1589 * If LTEST( 9 ) is .TRUE., PDZASUM will be tested;
1590 * If LTEST( 10 ) is .TRUE., PZAMAX will be tested.
1591 *
1592 * INOUT (global input) INTEGER
1593 * On entry, INOUT specifies the unit number for output file.
1594 * When INOUT is 6, output to screen, when INOUT = 0, output to
1595 * stderr. INOUT is only defined in process 0.
1596 *
1597 * NPROCS (global input) INTEGER
1598 * On entry, NPROCS specifies the total number of processes cal-
1599 * ling this routine.
1600 *
1601 * Calling sequence encodings
1602 * ==========================
1603 *
1604 * code Formal argument list Examples
1605 *
1606 * 11 (n, v1,v2) _SWAP, _COPY
1607 * 12 (n,s1, v1 ) _SCAL, _SCAL
1608 * 13 (n,s1, v1,v2) _AXPY, _DOT_
1609 * 14 (n,s1,i1,v1 ) _AMAX
1610 * 15 (n,u1, v1 ) _ASUM, _NRM2
1611 *
1612 * 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
1613 * 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
1614 * 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
1615 * 24 ( m,n,s1,v1,v2,m1) _GER_
1616 * 25 (uplo, n,s1,v1, m1) _SYR
1617 * 26 (uplo, n,u1,v1, m1) _HER
1618 * 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
1619 *
1620 * 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
1621 * 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
1622 * 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
1623 * 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
1624 * 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
1625 * 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
1626 * 37 ( m,n, s1,m1, s2,m3) _TRAN_
1627 * 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
1628 * 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
1629 * 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
1630 *
1631 * -- Written on April 1, 1998 by
1632 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1633 *
1634 * =====================================================================
1635 *
1636 * .. Parameters ..
1637  INTEGER NSUBS
1638  PARAMETER ( NSUBS = 10 )
1639 * ..
1640 * .. Local Scalars ..
1641  logical abrtsav
1642  INTEGER I, ICTXT, MYCOL, MYROW, NPCOL, NPROW
1643 * ..
1644 * .. Local Arrays ..
1645  INTEGER SCODE( NSUBS )
1646 * ..
1647 * .. External Subroutines ..
1648  EXTERNAL blacs_get, blacs_gridexit, blacs_gridinfo,
1649  $ blacs_gridinit, pdzasum, pdznrm2, pzamax,
1650  $ pzaxpy, pzcopy, pzdimee, pzdotc, pzdotu,
1651  $ pzdscal, pzscal, pzswap, pzvecee
1652 * ..
1653 * .. Common Blocks ..
1654  LOGICAL ABRTFLG
1655  INTEGER NOUT
1656  CHARACTER*7 SNAMES( NSUBS )
1657  COMMON /SNAMEC/SNAMES
1658  COMMON /PBERRORC/NOUT, ABRTFLG
1659 * ..
1660 * .. Data Statements ..
1661  DATA SCODE/11, 12, 12, 11, 13, 13, 13, 15, 15, 14/
1662 * ..
1663 * .. Executable Statements ..
1664 *
1665 * Temporarily define blacs grid to include all processes so
1666 * information can be broadcast to all processes.
1667 *
1668  CALL blacs_get( -1, 0, ictxt )
1669  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1670  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
1671 *
1672 * Set ABRTFLG to FALSE so that the PBLAS error handler won't abort
1673 * on errors during these tests and set the output device unit for
1674 * it.
1675 *
1676  abrtsav = abrtflg
1677  abrtflg = .false.
1678  nout = inout
1679 *
1680 * Test PZSWAP
1681 *
1682  i = 1
1683  IF( ltest( i ) ) THEN
1684  CALL pzdimee( ictxt, nout, pzswap, scode( i ), snames( i ) )
1685  CALL pzvecee( ictxt, nout, pzswap, scode( i ), snames( i ) )
1686  END IF
1687 *
1688 * Test PZSCAL
1689 *
1690  i = i + 1
1691  IF( ltest( i ) ) THEN
1692  CALL pzdimee( ictxt, nout, pzscal, scode( i ), snames( i ) )
1693  CALL pzvecee( ictxt, nout, pzscal, scode( i ), snames( i ) )
1694  END IF
1695 *
1696 * Test PZDSCAL
1697 *
1698  i = i + 1
1699  IF( ltest( i ) ) THEN
1700  CALL pzdimee( ictxt, nout, pzdscal, scode( i ), snames( i ) )
1701  CALL pzvecee( ictxt, nout, pzdscal, scode( i ), snames( i ) )
1702  END IF
1703 *
1704 * Test PZCOPY
1705 *
1706  i = i + 1
1707  IF( ltest( i ) ) THEN
1708  CALL pzdimee( ictxt, nout, pzcopy, scode( i ), snames( i ) )
1709  CALL pzvecee( ictxt, nout, pzcopy, scode( i ), snames( i ) )
1710  END IF
1711 *
1712 * Test PZAXPY
1713 *
1714  i = i + 1
1715  IF( ltest( i ) ) THEN
1716  CALL pzdimee( ictxt, nout, pzaxpy, scode( i ), snames( i ) )
1717  CALL pzvecee( ictxt, nout, pzaxpy, scode( i ), snames( i ) )
1718  END IF
1719 *
1720 * Test PZDOTU
1721 *
1722  i = i + 1
1723  IF( ltest( i ) ) THEN
1724  CALL pzdimee( ictxt, nout, pzdotu, scode( i ), snames( i ) )
1725  CALL pzvecee( ictxt, nout, pzdotu, scode( i ), snames( i ) )
1726  END IF
1727 *
1728 * Test PZDOTC
1729 *
1730  i = i + 1
1731  IF( ltest( i ) ) THEN
1732  CALL pzdimee( ictxt, nout, pzdotc, scode( i ), snames( i ) )
1733  CALL pzvecee( ictxt, nout, pzdotc, scode( i ), snames( i ) )
1734  END IF
1735 *
1736 * PDZNRM2
1737 *
1738  i = i + 1
1739  IF( ltest( i ) ) THEN
1740  CALL pzdimee( ictxt, nout, pdznrm2, scode( i ), snames( i ) )
1741  CALL pzvecee( ictxt, nout, pdznrm2, scode( i ), snames( i ) )
1742  END IF
1743 *
1744 * Test PDZASUM
1745 *
1746  i = i + 1
1747  IF( ltest( i ) ) THEN
1748  CALL pzdimee( ictxt, nout, pdzasum, scode( i ), snames( i ) )
1749  CALL pzvecee( ictxt, nout, pdzasum, scode( i ), snames( i ) )
1750  END IF
1751 *
1752 * Test PZAMAX
1753 *
1754  i = i + 1
1755  IF( ltest( i ) ) THEN
1756  CALL pzdimee( ictxt, nout, pzamax, scode( i ), snames( i ) )
1757  CALL pzvecee( ictxt, nout, pzamax, scode( i ), snames( i ) )
1758  END IF
1759 *
1760  IF( myrow.EQ.0 .AND. mycol.EQ.0 )
1761  $ WRITE( nout, fmt = 9999 )
1762 *
1763  CALL blacs_gridexit( ictxt )
1764 *
1765 * Reset ABRTFLG to the value it had before calling this routine
1766 *
1767  abrtflg = abrtsav
1768 *
1769  9999 FORMAT( 2x, 'Error-exit tests completed.' )
1770 *
1771  RETURN
1772 *
1773 * End of PZBLAS1TSTCHKE
1774 *
1775  END
1776  SUBROUTINE pzchkarg1( ICTXT, NOUT, SNAME, N, ALPHA, IX, JX,
1777  $ DESCX, INCX, IY, JY, DESCY, INCY, INFO )
1778 *
1779 * -- PBLAS test routine (version 2.0) --
1780 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1781 * and University of California, Berkeley.
1782 * April 1, 1998
1783 *
1784 * .. Scalar Arguments ..
1785  INTEGER ICTXT, INCX, INCY, INFO, IX, IY, JX, JY, N,
1786  $ NOUT
1787  COMPLEX*16 ALPHA
1788 * ..
1789 * .. Array Arguments ..
1790  CHARACTER*(*) SNAME
1791  INTEGER DESCX( * ), DESCY( * )
1792 * ..
1793 *
1794 * Purpose
1795 * =======
1796 *
1797 * PZCHKARG1 checks the input-only arguments of the Level 1 PBLAS. When
1798 * INFO = 0, this routine makes a copy of its arguments (which are INPUT
1799 * only arguments to PBLAS routines). Otherwise, it verifies the values
1800 * of these arguments against the saved copies.
1801 *
1802 * Notes
1803 * =====
1804 *
1805 * A description vector is associated with each 2D block-cyclicly dis-
1806 * tributed matrix. This vector stores the information required to
1807 * establish the mapping between a matrix entry and its corresponding
1808 * process and memory location.
1809 *
1810 * In the following comments, the character _ should be read as
1811 * "of the distributed matrix". Let A be a generic term for any 2D
1812 * block cyclicly distributed matrix. Its description vector is DESCA:
1813 *
1814 * NOTATION STORED IN EXPLANATION
1815 * ---------------- --------------- ------------------------------------
1816 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1817 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1818 * the NPROW x NPCOL BLACS process grid
1819 * A is distributed over. The context
1820 * itself is global, but the handle
1821 * (the integer value) may vary.
1822 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
1823 * ted matrix A, M_A >= 0.
1824 * N_A (global) DESCA( N_ ) The number of columns in the distri-
1825 * buted matrix A, N_A >= 0.
1826 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1827 * block of the matrix A, IMB_A > 0.
1828 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
1829 * left block of the matrix A,
1830 * INB_A > 0.
1831 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1832 * bute the last M_A-IMB_A rows of A,
1833 * MB_A > 0.
1834 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1835 * bute the last N_A-INB_A columns of
1836 * A, NB_A > 0.
1837 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1838 * row of the matrix A is distributed,
1839 * NPROW > RSRC_A >= 0.
1840 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1841 * first column of A is distributed.
1842 * NPCOL > CSRC_A >= 0.
1843 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1844 * array storing the local blocks of
1845 * the distributed matrix A,
1846 * IF( Lc( 1, N_A ) > 0 )
1847 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
1848 * ELSE
1849 * LLD_A >= 1.
1850 *
1851 * Let K be the number of rows of a matrix A starting at the global in-
1852 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1853 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1854 * receive if these K rows were distributed over NPROW processes. If K
1855 * is the number of columns of a matrix A starting at the global index
1856 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1857 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1858 * these K columns were distributed over NPCOL processes.
1859 *
1860 * The values of Lr() and Lc() may be determined via a call to the func-
1861 * tion PB_NUMROC:
1862 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1863 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1864 *
1865 * Arguments
1866 * =========
1867 *
1868 * ICTXT (local input) INTEGER
1869 * On entry, ICTXT specifies the BLACS context handle, indica-
1870 * ting the global context of the operation. The context itself
1871 * is global, but the value of ICTXT is local.
1872 *
1873 * NOUT (global input) INTEGER
1874 * On entry, NOUT specifies the unit number for the output file.
1875 * When NOUT is 6, output to screen, when NOUT is 0, output to
1876 * stderr. NOUT is only defined for process 0.
1877 *
1878 * SNAME (global input) CHARACTER*(*)
1879 * On entry, SNAME specifies the subroutine name calling this
1880 * subprogram.
1881 *
1882 * N (global input) INTEGER
1883 * On entry, N specifies the length of the subvector operands.
1884 *
1885 * ALPHA (global input) COMPLEX*16
1886 * On entry, ALPHA specifies the scalar alpha.
1887 *
1888 * IX (global input) INTEGER
1889 * On entry, IX specifies X's global row index, which points to
1890 * the beginning of the submatrix sub( X ).
1891 *
1892 * JX (global input) INTEGER
1893 * On entry, JX specifies X's global column index, which points
1894 * to the beginning of the submatrix sub( X ).
1895 *
1896 * DESCX (global and local input) INTEGER array
1897 * On entry, DESCX is an integer array of dimension DLEN_. This
1898 * is the array descriptor for the matrix X.
1899 *
1900 * INCX (global input) INTEGER
1901 * On entry, INCX specifies the global increment for the
1902 * elements of X. Only two values of INCX are supported in
1903 * this version, namely 1 and M_X. INCX must not be zero.
1904 *
1905 * IY (global input) INTEGER
1906 * On entry, IY specifies Y's global row index, which points to
1907 * the beginning of the submatrix sub( Y ).
1908 *
1909 * JY (global input) INTEGER
1910 * On entry, JY specifies Y's global column index, which points
1911 * to the beginning of the submatrix sub( Y ).
1912 *
1913 * DESCY (global and local input) INTEGER array
1914 * On entry, DESCY is an integer array of dimension DLEN_. This
1915 * is the array descriptor for the matrix Y.
1916 *
1917 * INCY (global input) INTEGER
1918 * On entry, INCY specifies the global increment for the
1919 * elements of Y. Only two values of INCY are supported in
1920 * this version, namely 1 and M_Y. INCY must not be zero.
1921 *
1922 * INFO (global input/global output) INTEGER
1923 * When INFO = 0 on entry, the values of the arguments which are
1924 * INPUT only arguments to a PBLAS routine are copied into sta-
1925 * tic variables and INFO is unchanged on exit. Otherwise, the
1926 * values of the arguments are compared against the saved co-
1927 * pies. In case no error has been found INFO is zero on return,
1928 * otherwise it is non zero.
1929 *
1930 * -- Written on April 1, 1998 by
1931 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1932 *
1933 * =====================================================================
1934 *
1935 * .. Parameters ..
1936  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1937  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
1938  $ RSRC_
1939  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
1940  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
1941  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
1942  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
1943 * ..
1944 * .. Local Scalars ..
1945  INTEGER I, INCXREF, INCYREF, IXREF, IYREF, JXREF,
1946  $ JYREF, MYCOL, MYROW, NPCOL, NPROW, NREF
1947  COMPLEX*16 ALPHAREF
1948 * ..
1949 * .. Local Arrays ..
1950  CHARACTER*15 ARGNAME
1951  INTEGER DESCXREF( DLEN_ ), DESCYREF( DLEN_ )
1952 * ..
1953 * .. External Subroutines ..
1954  EXTERNAL blacs_gridinfo, igsum2d
1955 * ..
1956 * .. Save Statements ..
1957  SAVE
1958 * ..
1959 * .. Executable Statements ..
1960 *
1961 * Get grid parameters
1962 *
1963  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
1964 *
1965 * Check if first call. If yes, then save.
1966 *
1967  IF( info.EQ.0 ) THEN
1968 *
1969  nref = n
1970  ixref = ix
1971  jxref = jx
1972  DO 10 i = 1, dlen_
1973  descxref( i ) = descx( i )
1974  10 CONTINUE
1975  incxref = incx
1976  iyref = iy
1977  jyref = jy
1978  DO 20 i = 1, dlen_
1979  descyref( i ) = descy( i )
1980  20 CONTINUE
1981  incyref = incy
1982  alpharef = alpha
1983 *
1984  ELSE
1985 *
1986 * Test saved args. Return with first mismatch.
1987 *
1988  argname = ' '
1989  IF( n.NE.nref ) THEN
1990  WRITE( argname, fmt = '(A)' ) 'N'
1991  ELSE IF( ix.NE.ixref ) THEN
1992  WRITE( argname, fmt = '(A)' ) 'IX'
1993  ELSE IF( jx.NE.jxref ) THEN
1994  WRITE( argname, fmt = '(A)' ) 'JX'
1995  ELSE IF( descx( dtype_ ).NE.descxref( dtype_ ) ) THEN
1996  WRITE( argname, fmt = '(A)' ) 'DESCX( DTYPE_ )'
1997  ELSE IF( descx( m_ ).NE.descxref( m_ ) ) THEN
1998  WRITE( argname, fmt = '(A)' ) 'DESCX( M_ )'
1999  ELSE IF( descx( n_ ).NE.descxref( n_ ) ) THEN
2000  WRITE( argname, fmt = '(A)' ) 'DESCX( N_ )'
2001  ELSE IF( descx( imb_ ).NE.descxref( imb_ ) ) THEN
2002  WRITE( argname, fmt = '(A)' ) 'DESCX( IMB_ )'
2003  ELSE IF( descx( inb_ ).NE.descxref( inb_ ) ) THEN
2004  WRITE( argname, fmt = '(A)' ) 'DESCX( INB_ )'
2005  ELSE IF( descx( mb_ ).NE.descxref( mb_ ) ) THEN
2006  WRITE( argname, fmt = '(A)' ) 'DESCX( MB_ )'
2007  ELSE IF( descx( nb_ ).NE.descxref( nb_ ) ) THEN
2008  WRITE( argname, fmt = '(A)' ) 'DESCX( NB_ )'
2009  ELSE IF( descx( rsrc_ ).NE.descxref( rsrc_ ) ) THEN
2010  WRITE( argname, fmt = '(A)' ) 'DESCX( RSRC_ )'
2011  ELSE IF( descx( csrc_ ).NE.descxref( csrc_ ) ) THEN
2012  WRITE( argname, fmt = '(A)' ) 'DESCX( CSRC_ )'
2013  ELSE IF( descx( ctxt_ ).NE.descxref( ctxt_ ) ) THEN
2014  WRITE( argname, fmt = '(A)' ) 'DESCX( CTXT_ )'
2015  ELSE IF( descx( lld_ ).NE.descxref( lld_ ) ) THEN
2016  WRITE( argname, fmt = '(A)' ) 'DESCX( LLD_ )'
2017  ELSE IF( incx.NE.incxref ) THEN
2018  WRITE( argname, fmt = '(A)' ) 'INCX'
2019  ELSE IF( iy.NE.iyref ) THEN
2020  WRITE( argname, fmt = '(A)' ) 'IY'
2021  ELSE IF( jy.NE.jyref ) THEN
2022  WRITE( argname, fmt = '(A)' ) 'JY'
2023  ELSE IF( descy( dtype_ ).NE.descyref( dtype_ ) ) THEN
2024  WRITE( argname, fmt = '(A)' ) 'DESCY( DTYPE_ )'
2025  ELSE IF( descy( m_ ).NE.descyref( m_ ) ) THEN
2026  WRITE( argname, fmt = '(A)' ) 'DESCY( M_ )'
2027  ELSE IF( descy( n_ ).NE.descyref( n_ ) ) THEN
2028  WRITE( argname, fmt = '(A)' ) 'DESCY( N_ )'
2029  ELSE IF( descy( imb_ ).NE.descyref( imb_ ) ) THEN
2030  WRITE( argname, fmt = '(A)' ) 'DESCY( IMB_ )'
2031  ELSE IF( descy( inb_ ).NE.descyref( inb_ ) ) THEN
2032  WRITE( argname, fmt = '(A)' ) 'DESCY( INB_ )'
2033  ELSE IF( descy( mb_ ).NE.descyref( mb_ ) ) THEN
2034  WRITE( argname, fmt = '(A)' ) 'DESCY( MB_ )'
2035  ELSE IF( descy( nb_ ).NE.descyref( nb_ ) ) THEN
2036  WRITE( argname, fmt = '(A)' ) 'DESCY( NB_ )'
2037  ELSE IF( descy( rsrc_ ).NE.descyref( rsrc_ ) ) THEN
2038  WRITE( argname, fmt = '(A)' ) 'DESCY( RSRC_ )'
2039  ELSE IF( descy( csrc_ ).NE.descyref( csrc_ ) ) THEN
2040  WRITE( argname, fmt = '(A)' ) 'DESCY( CSRC_ )'
2041  ELSE IF( descy( ctxt_ ).NE.descyref( ctxt_ ) ) THEN
2042  WRITE( argname, fmt = '(A)' ) 'DESCY( CTXT_ )'
2043  ELSE IF( descy( lld_ ).NE.descyref( lld_ ) ) THEN
2044  WRITE( argname, fmt = '(A)' ) 'DESCY( LLD_ )'
2045  ELSE IF( incy.NE.incyref ) THEN
2046  WRITE( argname, fmt = '(A)' ) 'INCY'
2047  ELSE IF( alpha.NE.alpharef ) THEN
2048  WRITE( argname, fmt = '(A)' ) 'ALPHA'
2049  ELSE
2050  info = 0
2051  END IF
2052 *
2053  CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
2054 *
2055  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2056 *
2057  IF( info.GT.0 ) THEN
2058  WRITE( nout, fmt = 9999 ) argname, sname
2059  ELSE
2060  WRITE( nout, fmt = 9998 ) sname
2061  END IF
2062 *
2063  END IF
2064 *
2065  END IF
2066 *
2067  9999 FORMAT( 2x, ' ***** Input-only parameter check: ', a,
2068  $ ' FAILED changed ', a, ' *****' )
2069  9998 FORMAT( 2x, ' ***** Input-only parameter check: ', a,
2070  $ ' PASSED *****' )
2071 *
2072  RETURN
2073 *
2074 * End of PZCHKARG1
2075 *
2076  END
2077  LOGICAL FUNCTION pisinscope( ICTXT, N, IX, JX, DESCX, INCX )
2078 *
2079 * -- PBLAS test routine (version 2.0) --
2080 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2081 * and University of California, Berkeley.
2082 * April 1, 1998
2083 *
2084 * .. Scalar Arguments ..
2085  INTEGER ictxt, incx, ix, jx, n
2086 * ..
2087 * .. Array Arguments ..
2088  INTEGER descx( * )
2089 * ..
2090 *
2091 * Purpose
2092 * =======
2093 *
2094 * PISINSCOPE returns .TRUE. if the calling process is in the scope of
2095 * sub( X ) = X( IX+(JX-1)*DESCX(M_)+(i-1)*INCX ) and .FALSE. if it is
2096 * not. This routine is used to determine which processes should check
2097 * the answer returned by some Level 1 PBLAS routines.
2098 *
2099 * Notes
2100 * =====
2101 *
2102 * A description vector is associated with each 2D block-cyclicly dis-
2103 * tributed matrix. This vector stores the information required to
2104 * establish the mapping between a matrix entry and its corresponding
2105 * process and memory location.
2106 *
2107 * In the following comments, the character _ should be read as
2108 * "of the distributed matrix". Let A be a generic term for any 2D
2109 * block cyclicly distributed matrix. Its description vector is DESCA:
2110 *
2111 * NOTATION STORED IN EXPLANATION
2112 * ---------------- --------------- ------------------------------------
2113 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2114 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2115 * the NPROW x NPCOL BLACS process grid
2116 * A is distributed over. The context
2117 * itself is global, but the handle
2118 * (the integer value) may vary.
2119 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
2120 * ted matrix A, M_A >= 0.
2121 * N_A (global) DESCA( N_ ) The number of columns in the distri-
2122 * buted matrix A, N_A >= 0.
2123 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2124 * block of the matrix A, IMB_A > 0.
2125 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
2126 * left block of the matrix A,
2127 * INB_A > 0.
2128 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2129 * bute the last M_A-IMB_A rows of A,
2130 * MB_A > 0.
2131 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2132 * bute the last N_A-INB_A columns of
2133 * A, NB_A > 0.
2134 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2135 * row of the matrix A is distributed,
2136 * NPROW > RSRC_A >= 0.
2137 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2138 * first column of A is distributed.
2139 * NPCOL > CSRC_A >= 0.
2140 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2141 * array storing the local blocks of
2142 * the distributed matrix A,
2143 * IF( Lc( 1, N_A ) > 0 )
2144 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
2145 * ELSE
2146 * LLD_A >= 1.
2147 *
2148 * Let K be the number of rows of a matrix A starting at the global in-
2149 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2150 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2151 * receive if these K rows were distributed over NPROW processes. If K
2152 * is the number of columns of a matrix A starting at the global index
2153 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2154 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2155 * these K columns were distributed over NPCOL processes.
2156 *
2157 * The values of Lr() and Lc() may be determined via a call to the func-
2158 * tion PB_NUMROC:
2159 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2160 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2161 *
2162 * Arguments
2163 * =========
2164 *
2165 * ICTXT (local input) INTEGER
2166 * On entry, ICTXT specifies the BLACS context handle, indica-
2167 * ting the global context of the operation. The context itself
2168 * is global, but the value of ICTXT is local.
2169 *
2170 * N (global input) INTEGER
2171 * The length of the subvector sub( X ).
2172 *
2173 * IX (global input) INTEGER
2174 * On entry, IX specifies X's global row index, which points to
2175 * the beginning of the submatrix sub( X ).
2176 *
2177 * JX (global input) INTEGER
2178 * On entry, JX specifies X's global column index, which points
2179 * to the beginning of the submatrix sub( X ).
2180 *
2181 * DESCX (global and local input) INTEGER array
2182 * On entry, DESCX is an integer array of dimension DLEN_. This
2183 * is the array descriptor for the matrix X.
2184 *
2185 * INCX (global input) INTEGER
2186 * On entry, INCX specifies the global increment for the
2187 * elements of X. Only two values of INCX are supported in
2188 * this version, namely 1 and M_X. INCX must not be zero.
2189 *
2190 * -- Written on April 1, 1998 by
2191 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2192 *
2193 * =====================================================================
2194 *
2195 * .. Parameters ..
2196  INTEGER block_cyclic_2d_inb, csrc_, ctxt_, dlen_,
2197  $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
2198  $ rsrc_
2199  PARAMETER ( block_cyclic_2d_inb = 2, dlen_ = 11,
2200  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2201  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2202  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2203 * ..
2204 * .. Local Scalars ..
2205  LOGICAL colrep, rowrep
2206  INTEGER iix, ixcol, ixrow, jjx, mycol, myrow, npcol,
2207  $ nprow
2208 * ..
2209 * .. External Subroutines ..
2210  EXTERNAL blacs_gridinfo, pb_infog2l
2211 * ..
2212 * .. Executable Statements ..
2213 *
2214  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2215 *
2216  CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol,
2217  $ iix, jjx, ixrow, ixcol )
2218  rowrep = ( ixrow.EQ.-1 )
2219  colrep = ( ixcol.EQ.-1 )
2220 *
2221  IF( descx( m_ ).EQ.1 .AND. n.EQ.1 ) THEN
2222 *
2223 * This is the special case, find process owner of IX, JX, and
2224 * only this process is the scope.
2225 *
2226  pisinscope = ( ( ixrow.EQ.myrow .OR. rowrep ) .AND.
2227  $ ( ixcol.EQ.mycol .OR. colrep ) )
2228 *
2229  ELSE
2230 *
2231  IF( incx.EQ.descx( m_ ) ) THEN
2232 *
2233 * row vector
2234 *
2235  pisinscope = ( myrow.EQ.ixrow .OR. rowrep )
2236 *
2237  ELSE
2238 *
2239 * column vector
2240 *
2241  pisinscope = ( mycol.EQ.ixcol .OR. colrep )
2242 *
2243  END IF
2244 *
2245  END IF
2246 *
2247  RETURN
2248 *
2249 * End of PISINSCOPE
2250 *
2251  END
2252  SUBROUTINE pzblas1tstchk( ICTXT, NOUT, NROUT, N, PSCLR, PUSCLR,
2253  $ PISCLR, X, PX, IX, JX, DESCX, INCX, Y,
2254  $ PY, IY, JY, DESCY, INCY, INFO )
2255 *
2256 * -- PBLAS test routine (version 2.0) --
2257 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2258 * and University of California, Berkeley.
2259 * April 1, 1998
2260 *
2261 * .. Scalar Arguments ..
2262  INTEGER ICTXT, INCX, INCY, INFO, IX, IY, JX, JY, N,
2263  $ nout, nrout, pisclr
2264  DOUBLE PRECISION PUSCLR
2265  COMPLEX*16 PSCLR
2266 * ..
2267 * .. Array Arguments ..
2268  INTEGER DESCX( * ), DESCY( * )
2269  COMPLEX*16 PX( * ), PY( * ), X( * ), Y( * )
2270 * ..
2271 *
2272 * Purpose
2273 * =======
2274 *
2275 * PZBLAS1TSTCHK performs the computational tests of the Level 1 PBLAS.
2276 *
2277 * Notes
2278 * =====
2279 *
2280 * A description vector is associated with each 2D block-cyclicly dis-
2281 * tributed matrix. This vector stores the information required to
2282 * establish the mapping between a matrix entry and its corresponding
2283 * process and memory location.
2284 *
2285 * In the following comments, the character _ should be read as
2286 * "of the distributed matrix". Let A be a generic term for any 2D
2287 * block cyclicly distributed matrix. Its description vector is DESCA:
2288 *
2289 * NOTATION STORED IN EXPLANATION
2290 * ---------------- --------------- ------------------------------------
2291 * DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2292 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2293 * the NPROW x NPCOL BLACS process grid
2294 * A is distributed over. The context
2295 * itself is global, but the handle
2296 * (the integer value) may vary.
2297 * M_A (global) DESCA( M_ ) The number of rows in the distribu-
2298 * ted matrix A, M_A >= 0.
2299 * N_A (global) DESCA( N_ ) The number of columns in the distri-
2300 * buted matrix A, N_A >= 0.
2301 * IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2302 * block of the matrix A, IMB_A > 0.
2303 * INB_A (global) DESCA( INB_ ) The number of columns of the upper
2304 * left block of the matrix A,
2305 * INB_A > 0.
2306 * MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2307 * bute the last M_A-IMB_A rows of A,
2308 * MB_A > 0.
2309 * NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2310 * bute the last N_A-INB_A columns of
2311 * A, NB_A > 0.
2312 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2313 * row of the matrix A is distributed,
2314 * NPROW > RSRC_A >= 0.
2315 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2316 * first column of A is distributed.
2317 * NPCOL > CSRC_A >= 0.
2318 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2319 * array storing the local blocks of
2320 * the distributed matrix A,
2321 * IF( Lc( 1, N_A ) > 0 )
2322 * LLD_A >= MAX( 1, Lr( 1, M_A ) )
2323 * ELSE
2324 * LLD_A >= 1.
2325 *
2326 * Let K be the number of rows of a matrix A starting at the global in-
2327 * dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2328 * that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2329 * receive if these K rows were distributed over NPROW processes. If K
2330 * is the number of columns of a matrix A starting at the global index
2331 * JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2332 * lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2333 * these K columns were distributed over NPCOL processes.
2334 *
2335 * The values of Lr() and Lc() may be determined via a call to the func-
2336 * tion PB_NUMROC:
2337 * Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2338 * Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2339 *
2340 * Arguments
2341 * =========
2342 *
2343 * ICTXT (local input) INTEGER
2344 * On entry, ICTXT specifies the BLACS context handle, indica-
2345 * ting the global context of the operation. The context itself
2346 * is global, but the value of ICTXT is local.
2347 *
2348 * NOUT (global input) INTEGER
2349 * On entry, NOUT specifies the unit number for the output file.
2350 * When NOUT is 6, output to screen, when NOUT is 0, output to
2351 * stderr. NOUT is only defined for process 0.
2352 *
2353 * NROUT (global input) INTEGER
2354 * On entry, NROUT specifies which routine will be tested as
2355 * follows:
2356 * If NROUT = 1, PZSWAP will be tested;
2357 * else if NROUT = 2, PZSCAL will be tested;
2358 * else if NROUT = 3, PZDSCAL will be tested;
2359 * else if NROUT = 4, PZCOPY will be tested;
2360 * else if NROUT = 5, PZAXPY will be tested;
2361 * else if NROUT = 6, PZDOTU will be tested;
2362 * else if NROUT = 7, PZDOTC will be tested;
2363 * else if NROUT = 8, PDZNRM2 will be tested;
2364 * else if NROUT = 9, PDZASUM will be tested;
2365 * else if NROUT = 10, PZAMAX will be tested.
2366 *
2367 * N (global input) INTEGER
2368 * On entry, N specifies the length of the subvector operands.
2369 *
2370 * PSCLR (global input) COMPLEX*16
2371 * On entry, depending on the value of NROUT, PSCLR specifies
2372 * the scalar ALPHA, or the output scalar returned by the PBLAS,
2373 * i.e., the dot product, the 2-norm, the absolute sum or the
2374 * value of AMAX.
2375 *
2376 * PUSCLR (global input) DOUBLE PRECISION
2377 * On entry, PUSCLR specifies the real part of the scalar ALPHA
2378 * used by the real scaling, the 2-norm, or the absolute sum
2379 * routines. PUSCLR is not used in the real versions of this
2380 * routine.
2381 *
2382 * PISCLR (global input) DOUBLE PRECISION
2383 * On entry, PISCLR specifies the value of the global index re-
2384 * turned by PZAMAX, otherwise PISCLR is not used.
2385 *
2386 * X (local input/local output) COMPLEX*16 array
2387 * On entry, X is an array of dimension (DESCX( M_ ),*). This
2388 * array contains a local copy of the initial entire matrix PX.
2389 *
2390 * PX (local input) COMPLEX*16 array
2391 * On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2392 * array contains the local entries of the matrix PX.
2393 *
2394 * IX (global input) INTEGER
2395 * On entry, IX specifies X's global row index, which points to
2396 * the beginning of the submatrix sub( X ).
2397 *
2398 * JX (global input) INTEGER
2399 * On entry, JX specifies X's global column index, which points
2400 * to the beginning of the submatrix sub( X ).
2401 *
2402 * DESCX (global and local input) INTEGER array
2403 * On entry, DESCX is an integer array of dimension DLEN_. This
2404 * is the array descriptor for the matrix X.
2405 *
2406 * INCX (global input) INTEGER
2407 * On entry, INCX specifies the global increment for the
2408 * elements of X. Only two values of INCX are supported in
2409 * this version, namely 1 and M_X. INCX must not be zero.
2410 *
2411 * Y (local input/local output) COMPLEX*16 array
2412 * On entry, Y is an array of dimension (DESCY( M_ ),*). This
2413 * array contains a local copy of the initial entire matrix PY.
2414 *
2415 * PY (local input) COMPLEX*16 array
2416 * On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
2417 * array contains the local entries of the matrix PY.
2418 *
2419 * IY (global input) INTEGER
2420 * On entry, IY specifies Y's global row index, which points to
2421 * the beginning of the submatrix sub( Y ).
2422 *
2423 * JY (global input) INTEGER
2424 * On entry, JY specifies Y's global column index, which points
2425 * to the beginning of the submatrix sub( Y ).
2426 *
2427 * DESCY (global and local input) INTEGER array
2428 * On entry, DESCY is an integer array of dimension DLEN_. This
2429 * is the array descriptor for the matrix Y.
2430 *
2431 * INCY (global input) INTEGER
2432 * On entry, INCY specifies the global increment for the
2433 * elements of Y. Only two values of INCY are supported in
2434 * this version, namely 1 and M_Y. INCY must not be zero.
2435 *
2436 * INFO (global output) INTEGER
2437 * On exit, if INFO = 0, no error has been found, otherwise
2438 * if( MOD( INFO, 2 ) = 1 ) then an error on X has been found,
2439 * if( MOD( INFO/2, 2 ) = 1 ) then an error on Y has been found.
2440 *
2441 * -- Written on April 1, 1998 by
2442 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2443 *
2444 * =====================================================================
2445 *
2446 * .. Parameters ..
2447  DOUBLE PRECISION RZERO
2448  COMPLEX*16 ZERO
2449  PARAMETER ( ZERO = ( 0.0d+0, 0.0d+0 ),
2450  $ rzero = 0.0d+0 )
2451  INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2452  $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2453  $ RSRC_
2454  PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
2455  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2456  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2457  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2458 * ..
2459 * .. Local Scalars ..
2460  LOGICAL COLREP, INXSCOPE, INYSCOPE, ROWREP
2461  INTEGER I, IB, ICURCOL, ICURROW, IDUMM, IIX, IIY, IN,
2462  $ ioffx, ioffy, isclr, ixcol, ixrow, iycol,
2463  $ iyrow, j, jb, jjx, jjy, jn, kk, ldx, ldy,
2464  $ mycol, myrow, npcol, nprow
2465  DOUBLE PRECISION ERR, ERRMAX, PREC, USCLR
2466  COMPLEX*16 SCLR
2467 * ..
2468 * .. Local Arrays ..
2469  INTEGER IERR( 6 )
2470  CHARACTER*5 ARGIN1, ARGIN2, ARGOUT1, ARGOUT2
2471 * ..
2472 * .. External Subroutines ..
2473  EXTERNAL blacs_gridinfo, igamx2d, pb_infog2l, pzchkvin,
2474  $ pzderrscal, pzerrasum, pzerraxpy, pzerrdotc,
2475  $ pzerrdotu, pzerrnrm2, pzerrscal, zcopy, zswap
2476 * ..
2477 * .. External Functions ..
2478  LOGICAL PISINSCOPE
2479  INTEGER IZAMAX
2480  DOUBLE PRECISION PDLAMCH
2481  EXTERNAL izamax, pdlamch, pisinscope
2482 * ..
2483 * .. Intrinsic Functions ..
2484  INTRINSIC min
2485 * ..
2486 * .. Executable Statements ..
2487 *
2488  info = 0
2489 *
2490 * Quick return if possible
2491 *
2492  IF( n.LE.0 )
2493  $ RETURN
2494 *
2495  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2496 *
2497  argin1 = ' '
2498  argin2 = ' '
2499  argout1 = ' '
2500  argout2 = ' '
2501  DO 10 i = 1, 6
2502  ierr( i ) = 0
2503  10 CONTINUE
2504 *
2505  prec = pdlamch( ictxt, 'precision' )
2506 *
2507  IF( nrout.EQ.1 ) THEN
2508 *
2509 * Test PZSWAP
2510 *
2511  ioffx = ix + ( jx - 1 ) * descx( m_ )
2512  ioffy = iy + ( jy - 1 ) * descy( m_ )
2513  CALL zswap( n, x( ioffx ), incx, y( ioffy ), incy )
2514  CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2515  $ ierr( 1 ) )
2516  CALL pzchkvin( errmax, n, y, py, iy, jy, descy, incy,
2517  $ ierr( 2 ) )
2518 *
2519  ELSE IF( nrout.EQ.2 ) THEN
2520 *
2521 * Test PZSCAL
2522 *
2523  ldx = descx( lld_ )
2524  ioffx = ix + ( jx - 1 ) * descx( m_ )
2525  CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol,
2526  $ iix, jjx, ixrow, ixcol )
2527  icurrow = ixrow
2528  icurcol = ixcol
2529  rowrep = ( ixrow.EQ.-1 )
2530  colrep = ( ixcol.EQ.-1 )
2531 *
2532  IF( incx.EQ.descx( m_ ) ) THEN
2533 *
2534 * sub( X ) is a row vector
2535 *
2536  jb = descx( inb_ ) - jx + 1
2537  IF( jb.LE.0 )
2538  $ jb = ( (-jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2539  jb = min( jb, n )
2540  jn = jx + jb - 1
2541 *
2542  DO 20 j = jx, jn
2543 *
2544  CALL pzerrscal( err, psclr, x( ioffx ), prec )
2545 *
2546  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2547  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2548  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2549  $ err )
2550  $ ierr( 1 ) = 1
2551  jjx = jjx + 1
2552  END IF
2553 *
2554  ioffx = ioffx + incx
2555 *
2556  20 CONTINUE
2557 *
2558  icurcol = mod( icurcol+1, npcol )
2559 *
2560  DO 40 j = jn+1, jx+n-1, descx( nb_ )
2561  jb = min( jx+n-j, descx( nb_ ) )
2562 *
2563  DO 30 kk = 0, jb-1
2564 *
2565  CALL pzerrscal( err, psclr, x( ioffx ), prec )
2566 *
2567  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2568  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2569  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2570  $ err )
2571  $ ierr( 1 ) = 1
2572  jjx = jjx + 1
2573  END IF
2574 *
2575  ioffx = ioffx + incx
2576 *
2577  30 CONTINUE
2578 *
2579  icurcol = mod( icurcol+1, npcol )
2580 *
2581  40 CONTINUE
2582 *
2583  ELSE
2584 *
2585 * sub( X ) is a column vector
2586 *
2587  ib = descx( imb_ ) - ix + 1
2588  IF( ib.LE.0 )
2589  $ ib = ( (-ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2590  ib = min( ib, n )
2591  in = ix + ib - 1
2592 *
2593  DO 50 i = ix, in
2594 *
2595  CALL pzerrscal( err, psclr, x( ioffx ), prec )
2596 *
2597  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2598  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2599  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2600  $ err )
2601  $ ierr( 1 ) = 1
2602  iix = iix + 1
2603  END IF
2604 *
2605  ioffx = ioffx + incx
2606 *
2607  50 CONTINUE
2608 *
2609  icurrow = mod( icurrow+1, nprow )
2610 *
2611  DO 70 i = in+1, ix+n-1, descx( mb_ )
2612  ib = min( ix+n-i, descx( mb_ ) )
2613 *
2614  DO 60 kk = 0, ib-1
2615 *
2616  CALL pzerrscal( err, psclr, x( ioffx ), prec )
2617 *
2618  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2619  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2620  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2621  $ err )
2622  $ ierr( 1 ) = 1
2623  iix = iix + 1
2624  END IF
2625 *
2626  ioffx = ioffx + incx
2627  60 CONTINUE
2628 *
2629  icurrow = mod( icurrow+1, nprow )
2630 *
2631  70 CONTINUE
2632 *
2633  END IF
2634 *
2635  ELSE IF( nrout.EQ.3 ) THEN
2636 *
2637 * Test PZDSCAL
2638 *
2639  ldx = descx( lld_ )
2640  ioffx = ix + ( jx - 1 ) * descx( m_ )
2641  CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol,
2642  $ iix, jjx, ixrow, ixcol )
2643  icurrow = ixrow
2644  icurcol = ixcol
2645  rowrep = ( ixrow.EQ.-1 )
2646  colrep = ( ixcol.EQ.-1 )
2647 *
2648  IF( incx.EQ.descx( m_ ) ) THEN
2649 *
2650 * sub( X ) is a row vector
2651 *
2652  jb = descx( inb_ ) - jx + 1
2653  IF( jb.LE.0 )
2654  $ jb = ( (-jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2655  jb = min( jb, n )
2656  jn = jx + jb - 1
2657 *
2658  DO 80 j = jx, jn
2659 *
2660  CALL pzderrscal( err, pusclr, x( ioffx ), prec )
2661 *
2662  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2663  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2664  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2665  $ err )
2666  $ ierr( 1 ) = 1
2667  jjx = jjx + 1
2668  END IF
2669 *
2670  ioffx = ioffx + incx
2671 *
2672  80 CONTINUE
2673 *
2674  icurcol = mod( icurcol+1, npcol )
2675 *
2676  DO 100 j = jn+1, jx+n-1, descx( nb_ )
2677  jb = min( jx+n-j, descx( nb_ ) )
2678 *
2679  DO 90 kk = 0, jb-1
2680 *
2681  CALL pzderrscal( err, pusclr, x( ioffx ), prec )
2682 *
2683  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2684  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2685  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2686  $ err )
2687  $ ierr( 1 ) = 1
2688  jjx = jjx + 1
2689  END IF
2690 *
2691  ioffx = ioffx + incx
2692 *
2693  90 CONTINUE
2694 *
2695  icurcol = mod( icurcol+1, npcol )
2696 *
2697  100 CONTINUE
2698 *
2699  ELSE
2700 *
2701 * sub( X ) is a column vector
2702 *
2703  ib = descx( imb_ ) - ix + 1
2704  IF( ib.LE.0 )
2705  $ ib = ( (-ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2706  ib = min( ib, n )
2707  in = ix + ib - 1
2708 *
2709  DO 110 i = ix, in
2710 *
2711  CALL pzderrscal( err, pusclr, x( ioffx ), prec )
2712 *
2713  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2714  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2715  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2716  $ err )
2717  $ ierr( 1 ) = 1
2718  iix = iix + 1
2719  END IF
2720 *
2721  ioffx = ioffx + incx
2722 *
2723  110 CONTINUE
2724 *
2725  icurrow = mod( icurrow+1, nprow )
2726 *
2727  DO 130 i = in+1, ix+n-1, descx( mb_ )
2728  ib = min( ix+n-i, descx( mb_ ) )
2729 *
2730  DO 120 kk = 0, ib-1
2731 *
2732  CALL pzderrscal( err, pusclr, x( ioffx ), prec )
2733 *
2734  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2735  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2736  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2737  $ err )
2738  $ ierr( 1 ) = 1
2739  iix = iix + 1
2740  END IF
2741 *
2742  ioffx = ioffx + incx
2743  120 CONTINUE
2744 *
2745  icurrow = mod( icurrow+1, nprow )
2746 *
2747  130 CONTINUE
2748 *
2749  END IF
2750 *
2751  ELSE IF( nrout.EQ.4 ) THEN
2752 *
2753 * Test PZCOPY
2754 *
2755  ioffx = ix + ( jx - 1 ) * descx( m_ )
2756  ioffy = iy + ( jy - 1 ) * descy( m_ )
2757  CALL zcopy( n, x( ioffx ), incx, y( ioffy ), incy )
2758  CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2759  $ ierr( 1 ) )
2760  CALL pzchkvin( errmax, n, y, py, iy, jy, descy, incy,
2761  $ ierr( 2 ) )
2762 *
2763  ELSE IF( nrout.EQ.5 ) THEN
2764 *
2765 * Test PZAXPY
2766 *
2767  CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2768  $ ierr( 1 ) )
2769  ldy = descy( lld_ )
2770  ioffx = ix + ( jx - 1 ) * descx( m_ )
2771  ioffy = iy + ( jy - 1 ) * descy( m_ )
2772  CALL pb_infog2l( iy, jy, descy, nprow, npcol, myrow, mycol,
2773  $ iiy, jjy, iyrow, iycol )
2774  icurrow = iyrow
2775  icurcol = iycol
2776  rowrep = ( iyrow.EQ.-1 )
2777  colrep = ( iycol.EQ.-1 )
2778 *
2779  IF( incy.EQ.descy( m_ ) ) THEN
2780 *
2781 * sub( Y ) is a row vector
2782 *
2783  jb = descy( inb_ ) - jy + 1
2784  IF( jb.LE.0 )
2785  $ jb = ( (-jb ) / descy( nb_ ) + 1 ) * descy( nb_ ) + jb
2786  jb = min( jb, n )
2787  jn = jy + jb - 1
2788 *
2789  DO 140 j = jy, jn
2790 *
2791  CALL pzerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2792  $ prec )
2793 *
2794  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2795  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2796  IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2797  $ err ) THEN
2798  ierr( 2 ) = 1
2799  END IF
2800  jjy = jjy + 1
2801  END IF
2802 *
2803  ioffx = ioffx + incx
2804  ioffy = ioffy + incy
2805 *
2806  140 CONTINUE
2807 *
2808  icurcol = mod( icurcol+1, npcol )
2809 *
2810  DO 160 j = jn+1, jy+n-1, descy( nb_ )
2811  jb = min( jy+n-j, descy( nb_ ) )
2812 *
2813  DO 150 kk = 0, jb-1
2814 *
2815  CALL pzerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2816  $ prec )
2817 *
2818  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2819  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2820  IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2821  $ err ) THEN
2822  ierr( 2 ) = 1
2823  END IF
2824  jjy = jjy + 1
2825  END IF
2826 *
2827  ioffx = ioffx + incx
2828  ioffy = ioffy + incy
2829 *
2830  150 CONTINUE
2831 *
2832  icurcol = mod( icurcol+1, npcol )
2833 *
2834  160 CONTINUE
2835 *
2836  ELSE
2837 *
2838 * sub( Y ) is a column vector
2839 *
2840  ib = descy( imb_ ) - iy + 1
2841  IF( ib.LE.0 )
2842  $ ib = ( (-ib ) / descy( mb_ ) + 1 ) * descy( mb_ ) + ib
2843  ib = min( ib, n )
2844  in = iy + ib - 1
2845 *
2846  DO 170 i = iy, in
2847 *
2848  CALL pzerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2849  $ prec )
2850 *
2851  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2852  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2853  IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2854  $ err ) THEN
2855  ierr( 2 ) = 1
2856  END IF
2857  iiy = iiy + 1
2858  END IF
2859 *
2860  ioffx = ioffx + incx
2861  ioffy = ioffy + incy
2862 *
2863  170 CONTINUE
2864 *
2865  icurrow = mod( icurrow+1, nprow )
2866 *
2867  DO 190 i = in+1, iy+n-1, descy( mb_ )
2868  ib = min( iy+n-i, descy( mb_ ) )
2869 *
2870  DO 180 kk = 0, ib-1
2871 *
2872  CALL pzerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2873  $ prec )
2874 *
2875  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2876  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2877  IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2878  $ err ) THEN
2879  ierr( 2 ) = 1
2880  END IF
2881  iiy = iiy + 1
2882  END IF
2883 *
2884  ioffx = ioffx + incx
2885  ioffy = ioffy + incy
2886 *
2887  180 CONTINUE
2888 *
2889  icurrow = mod( icurrow+1, nprow )
2890 *
2891  190 CONTINUE
2892 *
2893  END IF
2894 *
2895  ELSE IF( nrout.EQ.6 ) THEN
2896 *
2897 * Test PZDOTU
2898 *
2899  CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2900  $ ierr( 1 ) )
2901  CALL pzchkvin( errmax, n, y, py, iy, jy, descy, incy,
2902  $ ierr( 2 ) )
2903  ioffx = ix + ( jx - 1 ) * descx( m_ )
2904  ioffy = iy + ( jy - 1 ) * descy( m_ )
2905  CALL pzerrdotu( err, n, sclr, x( ioffx ), incx, y( ioffy ),
2906  $ incy, prec )
2907  inxscope = pisinscope( ictxt, n, ix, jx, descx, incx )
2908  inyscope = pisinscope( ictxt, n, iy, jy, descy, incy )
2909  IF( inxscope.OR.inyscope ) THEN
2910  IF( abs( psclr - sclr ).GT.err ) THEN
2911  ierr( 3 ) = 1
2912  WRITE( argin1, fmt = '(A)' ) 'DOTU'
2913  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2914  WRITE( nout, fmt = 9998 ) argin1
2915  WRITE( nout, fmt = 9996 ) sclr, psclr
2916  END IF
2917  END IF
2918  ELSE
2919  sclr = zero
2920  IF( psclr.NE.sclr ) THEN
2921  ierr( 4 ) = 1
2922  WRITE( argout1, fmt = '(A)' ) 'DOTU'
2923  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2924  WRITE( nout, fmt = 9997 ) argout1
2925  WRITE( nout, fmt = 9996 ) sclr, psclr
2926  END IF
2927  END IF
2928  END IF
2929 *
2930  ELSE IF( nrout.EQ.7 ) THEN
2931 *
2932 * Test PZDOTC
2933 *
2934  CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2935  $ ierr( 1 ) )
2936  CALL pzchkvin( errmax, n, y, py, iy, jy, descy, incy,
2937  $ ierr( 2 ) )
2938  ioffx = ix + ( jx - 1 ) * descx( m_ )
2939  ioffy = iy + ( jy - 1 ) * descy( m_ )
2940  CALL pzerrdotc( err, n, sclr, x( ioffx ), incx, y( ioffy ),
2941  $ incy, prec )
2942  inxscope = pisinscope( ictxt, n, ix, jx, descx, incx )
2943  inyscope = pisinscope( ictxt, n, iy, jy, descy, incy )
2944  IF( inxscope.OR.inyscope ) THEN
2945  IF( abs( psclr - sclr ).GT.err ) THEN
2946  ierr( 3 ) = 1
2947  WRITE( argin1, fmt = '(A)' ) 'DOTC'
2948  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2949  WRITE( nout, fmt = 9998 ) argin1
2950  WRITE( nout, fmt = 9996 ) sclr, psclr
2951  END IF
2952  END IF
2953  ELSE
2954  sclr = zero
2955  IF( psclr.NE.sclr ) THEN
2956  ierr( 4 ) = 1
2957  WRITE( argout1, fmt = '(A)' ) 'DOTC'
2958  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2959  WRITE( nout, fmt = 9997 ) argout1
2960  WRITE( nout, fmt = 9996 ) sclr, psclr
2961  END IF
2962  END IF
2963  END IF
2964 *
2965  ELSE IF( nrout.EQ.8 ) THEN
2966 *
2967 * Test PDZNRM2
2968 *
2969  CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2970  $ ierr( 1 ) )
2971  ioffx = ix + ( jx - 1 ) * descx( m_ )
2972  CALL pzerrnrm2( err, n, usclr, x( ioffx ), incx, prec )
2973  IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
2974  IF( abs( pusclr - usclr ).GT.err ) THEN
2975  ierr( 3 ) = 1
2976  WRITE( argin1, fmt = '(A)' ) 'NRM2'
2977  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2978  WRITE( nout, fmt = 9998 ) argin1
2979  WRITE( nout, fmt = 9994 ) usclr, pusclr
2980  END IF
2981  END IF
2982  ELSE
2983  usclr = rzero
2984  IF( pusclr.NE.usclr ) THEN
2985  ierr( 4 ) = 1
2986  WRITE( argout1, fmt = '(A)' ) 'NRM2'
2987  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2988  WRITE( nout, fmt = 9997 ) argout1
2989  WRITE( nout, fmt = 9994 ) usclr, pusclr
2990  END IF
2991  END IF
2992  END IF
2993 *
2994  ELSE IF( nrout.EQ.9 ) THEN
2995 *
2996 * Test PDZASUM
2997 *
2998  CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
2999  $ ierr( 1 ) )
3000  ioffx = ix + ( jx - 1 ) * descx( m_ )
3001  CALL pzerrasum( err, n, usclr, x( ioffx ), incx, prec )
3002  IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
3003  IF( abs( pusclr - usclr ) .GT. err ) THEN
3004  ierr( 3 ) = 1
3005  WRITE( argin1, fmt = '(A)' ) 'ASUM'
3006  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3007  WRITE( nout, fmt = 9998 ) argin1
3008  WRITE( nout, fmt = 9994 ) usclr, pusclr
3009  END IF
3010  END IF
3011  ELSE
3012  usclr = rzero
3013  IF( pusclr.NE.usclr ) THEN
3014  ierr( 4 ) = 1
3015  WRITE( argout1, fmt = '(A)' ) 'ASUM'
3016  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3017  WRITE( nout, fmt = 9997 ) argout1
3018  WRITE( nout, fmt = 9994 ) usclr, pusclr
3019  END IF
3020  END IF
3021  END IF
3022 *
3023  ELSE IF( nrout.EQ.10 ) THEN
3024 *
3025 * Test PZAMAX
3026 *
3027  CALL pzchkvin( errmax, n, x, px, ix, jx, descx, incx,
3028  $ ierr( 1 ) )
3029  ioffx = ix + ( jx - 1 ) * descx( m_ )
3030  IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
3031  isclr = izamax( n, x( ioffx ), incx )
3032  IF( n.LT.1 ) THEN
3033  sclr = zero
3034  ELSE IF( ( incx.EQ.1 ).AND.( descx( m_ ).EQ.1 ).AND.
3035  $ ( n.EQ.1 ) ) THEN
3036  isclr = jx
3037  sclr = x( ioffx )
3038  ELSE IF( incx.EQ.descx( m_ ) ) THEN
3039  isclr = jx + isclr - 1
3040  sclr = x( ix + ( isclr - 1 ) * descx( m_ ) )
3041  ELSE
3042  isclr = ix + isclr - 1
3043  sclr = x( isclr + ( jx - 1 ) * descx( m_ ) )
3044  END IF
3045 *
3046  IF( psclr.NE.sclr ) THEN
3047  ierr( 3 ) = 1
3048  WRITE( argin1, fmt = '(A)' ) 'AMAX'
3049  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3050  WRITE( nout, fmt = 9998 ) argin1
3051  WRITE( nout, fmt = 9996 ) sclr, psclr
3052  END IF
3053  END IF
3054 *
3055  IF( pisclr.NE.isclr ) THEN
3056  ierr( 5 ) = 1
3057  WRITE( argin2, fmt = '(A)' ) 'INDX'
3058  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3059  WRITE( nout, fmt = 9998 ) argin2
3060  WRITE( nout, fmt = 9995 ) isclr, pisclr
3061  END IF
3062  END IF
3063  ELSE
3064  isclr = 0
3065  sclr = zero
3066  IF( psclr.NE.sclr ) THEN
3067  ierr( 4 ) = 1
3068  WRITE( argout1, fmt = '(A)' ) 'AMAX'
3069  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3070  WRITE( nout, fmt = 9997 ) argout1
3071  WRITE( nout, fmt = 9996 ) sclr, psclr
3072  END IF
3073  END IF
3074  IF( pisclr.NE.isclr ) THEN
3075  ierr( 6 ) = 1
3076  WRITE( argout2, fmt = '(A)' ) 'INDX'
3077  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3078  WRITE( nout, fmt = 9997 ) argout2
3079  WRITE( nout, fmt = 9995 ) isclr, pisclr
3080  END IF
3081  END IF
3082  END IF
3083 *
3084  END IF
3085 *
3086 * Find IERR across all processes
3087 *
3088  CALL igamx2d( ictxt, 'All', ' ', 6, 1, ierr, 6, idumm, idumm, -1,
3089  $ -1, 0 )
3090 *
3091 * Encode the errors found in INFO
3092 *
3093  IF( ierr( 1 ).NE.0 ) THEN
3094  info = info + 1
3095  IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3096  $ WRITE( nout, fmt = 9999 ) 'X'
3097  END IF
3098 *
3099  IF( ierr( 2 ).NE.0 ) THEN
3100  info = info + 2
3101  IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3102  $ WRITE( nout, fmt = 9999 ) 'Y'
3103  END IF
3104 *
3105  IF( ierr( 3 ).NE.0 )
3106  $ info = info + 4
3107 *
3108  IF( ierr( 4 ).NE.0 )
3109  $ info = info + 8
3110 *
3111  IF( ierr( 5 ).NE.0 )
3112  $ info = info + 16
3113 *
3114  IF( ierr( 6 ).NE.0 )
3115  $ info = info + 32
3116 *
3117  9999 FORMAT( 2x, ' ***** ERROR: Vector operand ', a,
3118  $ ' is incorrect.' )
3119  9998 FORMAT( 2x, ' ***** ERROR: Output scalar result ', a,
3120  $ ' in scope is incorrect.' )
3121  9997 FORMAT( 2x, ' ***** ERROR: Output scalar result ', a,
3122  $ ' out of scope is incorrect.' )
3123  9996 FORMAT( 2x, ' ***** Expected value is: ', d30.18, '+i*(',
3124  $ d30.18, '),', /2x, ' Obtained value is: ',
3125  $ d30.18, '+i*(', d30.18, ')' )
3126  9995 FORMAT( 2x, ' ***** Expected value is: ', i6, /2x,
3127  $ ' Obtained value is: ', i6 )
3128  9994 FORMAT( 2x, ' ***** Expected value is: ', d30.18, /2x,
3129  $ ' Obtained value is: ', d30.18 )
3130 *
3131  RETURN
3132 *
3133 * End of PZBLAS1TSTCHK
3134 *
3135  END
3136  SUBROUTINE pzerrdotu( ERRBND, N, SCLR, X, INCX, Y, INCY, PREC )
3137 *
3138 * -- PBLAS test routine (version 2.0) --
3139 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3140 * and University of California, Berkeley.
3141 * April 1, 1998
3142 *
3143 * .. Scalar Arguments ..
3144  INTEGER INCX, INCY, N
3145  DOUBLE PRECISION ERRBND, PREC
3146  COMPLEX*16 SCLR
3147 * ..
3148 * .. Array Arguments ..
3149  COMPLEX*16 X( * ), Y( * )
3150 * ..
3151 *
3152 * Purpose
3153 * =======
3154 *
3155 * PZERRDOTU serially computes the dot product X**T * Y and returns a
3156 * scaled relative acceptable error bound on the result.
3157 *
3158 * Notes
3159 * =====
3160 *
3161 * If dot1 = SCLR and dot2 are two different computed results, and dot1
3162 * is being assumed to be correct, we require
3163 *
3164 * abs( dot1 - dot2 ) <= ERRBND = ERRFACT * abs( dot1 ),
3165 *
3166 * where ERRFACT is computed as the maximum of the positive and negative
3167 * partial sums multiplied by a constant proportional to the machine
3168 * precision.
3169 *
3170 * Arguments
3171 * =========
3172 *
3173 * ERRBND (global output) DOUBLE PRECISION
3174 * On exit, ERRBND specifies the scaled relative acceptable er-
3175 * ror bound.
3176 *
3177 * N (global input) INTEGER
3178 * On entry, N specifies the length of the vector operands.
3179 *
3180 * SCLR (global output) COMPLEX*16
3181 * On exit, SCLR specifies the dot product of the two vectors
3182 * X and Y.
3183 *
3184 * X (global input) COMPLEX*16 array
3185 * On entry, X is an array of dimension at least
3186 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
3187 * ted array X must contain the vector x.
3188 *
3189 * INCX (global input) INTEGER.
3190 * On entry, INCX specifies the increment for the elements of X.
3191 * INCX must not be zero.
3192 *
3193 * Y (global input) COMPLEX*16 array
3194 * On entry, Y is an array of dimension at least
3195 * ( 1 + ( n - 1 )*abs( INCY ) ). Before entry, the incremen-
3196 * ted array Y must contain the vector y.
3197 *
3198 * INCY (global input) INTEGER.
3199 * On entry, INCY specifies the increment for the elements of Y.
3200 * INCY must not be zero.
3201 *
3202 * PREC (global input) DOUBLE PRECISION
3203 * On entry, PREC specifies the machine precision.
3204 *
3205 * -- Written on April 1, 1998 by
3206 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3207 *
3208 * =====================================================================
3209 *
3210 * .. Parameters ..
3211  DOUBLE PRECISION ONE, TWO, ZERO
3212  PARAMETER ( ONE = 1.0d+0, two = 2.0d+0,
3213  $ zero = 0.0d+0 )
3214 * ..
3215 * .. Local Scalars ..
3216  INTEGER I, IX, IY
3217  DOUBLE PRECISION ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
3218  $ SUMRPOS, TMP
3219 * ..
3220 * .. Intrinsic Functions ..
3221  INTRINSIC ABS, DBLE, DIMAG, MAX
3222 * ..
3223 * .. Executable Statements ..
3224 *
3225  ix = 1
3226  iy = 1
3227  sclr = zero
3228  sumipos = zero
3229  sumineg = zero
3230  sumrpos = zero
3231  sumrneg = zero
3232  fact = two * ( one + prec )
3233  addbnd = two * two * two * prec
3234 *
3235  DO 10 i = 1, n
3236 *
3237  sclr = sclr + x( ix ) * y( iy )
3238 *
3239  tmp = dble( x( ix ) ) * dble( y( iy ) )
3240  IF( tmp.GE.zero ) THEN
3241  sumrpos = sumrpos + tmp * fact
3242  ELSE
3243  sumrneg = sumrneg - tmp * fact
3244  END IF
3245 *
3246  tmp = - dimag( x( ix ) ) * dimag( y( iy ) )
3247  IF( tmp.GE.zero ) THEN
3248  sumrpos = sumrpos + tmp * fact
3249  ELSE
3250  sumrneg = sumrneg - tmp * fact
3251  END IF
3252 *
3253  tmp = dimag( x( ix ) ) * dble( y( iy ) )
3254  IF( tmp.GE.zero ) THEN
3255  sumipos = sumipos + tmp * fact
3256  ELSE
3257  sumineg = sumineg - tmp * fact
3258  END IF
3259 *
3260  tmp = dble( x( ix ) ) * dimag( y( iy ) )
3261  IF( tmp.GE.zero ) THEN
3262  sumipos = sumipos + tmp * fact
3263  ELSE
3264  sumineg = sumineg - tmp * fact
3265  END IF
3266 *
3267  ix = ix + incx
3268  iy = iy + incy
3269 *
3270  10 CONTINUE
3271 *
3272  errbnd = addbnd * max( max( sumrpos, sumrneg ),
3273  $ max( sumipos, sumineg ) )
3274 *
3275  RETURN
3276 *
3277 * End of PZERRDOTU
3278 *
3279  END
3280  SUBROUTINE pzerrdotc( ERRBND, N, SCLR, X, INCX, Y, INCY, PREC )
3281 *
3282 * -- PBLAS test routine (version 2.0) --
3283 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3284 * and University of California, Berkeley.
3285 * April 1, 1998
3286 *
3287 * .. Scalar Arguments ..
3288  INTEGER INCX, INCY, N
3289  DOUBLE PRECISION ERRBND, PREC
3290  COMPLEX*16 SCLR
3291 * ..
3292 * .. Array Arguments ..
3293  COMPLEX*16 X( * ), Y( * )
3294 * ..
3295 *
3296 * Purpose
3297 * =======
3298 *
3299 * PZERRDOTC serially computes the dot product X**H * Y and returns a
3300 * scaled relative acceptable error bound on the result.
3301 *
3302 * Notes
3303 * =====
3304 *
3305 * If dot1 = SCLR and dot2 are two different computed results, and dot1
3306 * is being assumed to be correct, we require
3307 *
3308 * abs( dot1 - dot2 ) <= ERRBND = ERRFACT * abs( dot1 ),
3309 *
3310 * where ERRFACT is computed as the maximum of the positive and negative
3311 * partial sums multiplied by a constant proportional to the machine
3312 * precision.
3313 *
3314 * Arguments
3315 * =========
3316 *
3317 * ERRBND (global output) DOUBLE PRECISION
3318 * On exit, ERRBND specifies the scaled relative acceptable er-
3319 * ror bound.
3320 *
3321 * N (global input) INTEGER
3322 * On entry, N specifies the length of the vector operands.
3323 *
3324 * SCLR (global output) COMPLEX*16
3325 * On exit, SCLR specifies the dot product of the two vectors
3326 * X and Y.
3327 *
3328 * X (global input) COMPLEX*16 array
3329 * On entry, X is an array of dimension at least
3330 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
3331 * ted array X must contain the vector x.
3332 *
3333 * INCX (global input) INTEGER.
3334 * On entry, INCX specifies the increment for the elements of X.
3335 * INCX must not be zero.
3336 *
3337 * Y (global input) COMPLEX*16 array
3338 * On entry, Y is an array of dimension at least
3339 * ( 1 + ( n - 1 )*abs( INCY ) ). Before entry, the incremen-
3340 * ted array Y must contain the vector y.
3341 *
3342 * INCY (global input) INTEGER.
3343 * On entry, INCY specifies the increment for the elements of Y.
3344 * INCY must not be zero.
3345 *
3346 * PREC (global input) DOUBLE PRECISION
3347 * On entry, PREC specifies the machine precision.
3348 *
3349 * -- Written on April 1, 1998 by
3350 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3351 *
3352 * =====================================================================
3353 *
3354 * .. Parameters ..
3355  DOUBLE PRECISION ONE, TWO, ZERO
3356  PARAMETER ( ONE = 1.0d+0, two = 2.0d+0,
3357  $ zero = 0.0d+0 )
3358 * ..
3359 * .. Local Scalars ..
3360  INTEGER I, IX, IY
3361  DOUBLE PRECISION ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
3362  $ SUMRPOS, TMP
3363 * ..
3364 * .. Intrinsic Functions ..
3365  INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX
3366 * ..
3367 * .. Executable Statements ..
3368 *
3369  ix = 1
3370  iy = 1
3371  sclr = zero
3372  sumipos = zero
3373  sumineg = zero
3374  sumrpos = zero
3375  sumrneg = zero
3376  fact = two * ( one + prec )
3377  addbnd = two * two * two * prec
3378 *
3379  DO 10 i = 1, n
3380 *
3381  sclr = sclr + dconjg( x( ix ) ) * y( iy )
3382 *
3383  tmp = dble( x( ix ) ) * dble( y( iy ) )
3384  IF( tmp.GE.zero ) THEN
3385  sumrpos = sumrpos + tmp * fact
3386  ELSE
3387  sumrneg = sumrneg - tmp * fact
3388  END IF
3389 *
3390  tmp = dimag( x( ix ) ) * dimag( y( iy ) )
3391  IF( tmp.GE.zero ) THEN
3392  sumrpos = sumrpos + tmp * fact
3393  ELSE
3394  sumrneg = sumrneg - tmp * fact
3395  END IF
3396 *
3397  tmp = - dimag( x( ix ) ) * dble( y( iy ) )
3398  IF( tmp.GE.zero ) THEN
3399  sumipos = sumipos + tmp * fact
3400  ELSE
3401  sumineg = sumineg - tmp * fact
3402  END IF
3403 *
3404  tmp = dble( x( ix ) ) * dimag( y( iy ) )
3405  IF( tmp.GE.zero ) THEN
3406  sumipos = sumipos + tmp * fact
3407  ELSE
3408  sumineg = sumineg - tmp * fact
3409  END IF
3410 *
3411  ix = ix + incx
3412  iy = iy + incy
3413 *
3414  10 CONTINUE
3415 *
3416  errbnd = addbnd * max( max( sumrpos, sumrneg ),
3417  $ max( sumipos, sumineg ) )
3418 *
3419  RETURN
3420 *
3421 * End of PZERRDOTC
3422 *
3423  END
3424  SUBROUTINE pzerrnrm2( ERRBND, N, USCLR, X, INCX, PREC )
3425 *
3426 * -- PBLAS test routine (version 2.0) --
3427 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3428 * and University of California, Berkeley.
3429 * April 1, 1998
3430 *
3431 * .. Scalar Arguments ..
3432  INTEGER INCX, N
3433  DOUBLE PRECISION ERRBND, PREC, USCLR
3434 * ..
3435 * .. Array Arguments ..
3436  COMPLEX*16 X( * )
3437 * ..
3438 *
3439 * Purpose
3440 * =======
3441 *
3442 * PZERRNRM2 serially computes the 2-norm the vector X and returns a
3443 * scaled relative acceptable error bound on the result.
3444 *
3445 * Notes
3446 * =====
3447 *
3448 * If norm1 = SCLR and norm2 are two different computed results, and
3449 * norm1 being assumed to be correct, we require
3450 *
3451 * abs( norm1 - norm2 ) <= ERRBND = ERRFACT * abs( norm1 ),
3452 *
3453 * where ERRFACT is computed as the maximum of the positive and negative
3454 * partial sums multiplied by a constant proportional to the machine
3455 * precision.
3456 *
3457 * Arguments
3458 * =========
3459 *
3460 * ERRBND (global output) DOUBLE PRECISION
3461 * On exit, ERRBND specifies the scaled relative acceptable er-
3462 * ror bound.
3463 *
3464 * N (global input) INTEGER
3465 * On entry, N specifies the length of the vector operand.
3466 *
3467 * USCLR (global output) DOUBLE PRECISION
3468 * On exit, USCLR specifies the 2-norm of the vector X.
3469 *
3470 * X (global input) COMPLEX*16 array
3471 * On entry, X is an array of dimension at least
3472 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
3473 * ted array X must contain the vector x.
3474 *
3475 * INCX (global input) INTEGER.
3476 * On entry, INCX specifies the increment for the elements of X.
3477 * INCX must not be zero.
3478 *
3479 * PREC (global input) DOUBLE PRECISION
3480 * On entry, PREC specifies the machine precision.
3481 *
3482 * -- Written on April 1, 1998 by
3483 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3484 *
3485 * =====================================================================
3486 *
3487 * .. Parameters ..
3488  DOUBLE PRECISION ONE, TWO, ZERO
3489  PARAMETER ( ONE = 1.0d+0, two = 2.0d+0,
3490  $ zero = 0.0d+0 )
3491 * ..
3492 * .. Local Scalars ..
3493  INTEGER IX
3494  DOUBLE PRECISION ABSXI, ADDBND, FACT, SCALE, SSQ, SUMSCA, SUMSSQ
3495 * ..
3496 * .. Intrinsic Functions ..
3497  INTRINSIC ABS, DBLE, DIMAG
3498 * ..
3499 * .. Executable Statements ..
3500 *
3501  usclr = zero
3502  sumssq = one
3503  sumsca = zero
3504  addbnd = two * two * two * prec
3505  fact = one + two * ( ( one + prec )**3 - one )
3506 *
3507  scale = zero
3508  ssq = one
3509  DO 10 ix = 1, 1 + ( n - 1 )*incx, incx
3510  IF( dble( x( ix ) ).NE.zero ) THEN
3511  absxi = abs( dble( x( ix ) ) )
3512  IF( scale.LT.absxi )THEN
3513  sumssq = one + ( ssq*( scale/absxi )**2 ) * fact
3514  errbnd = addbnd * sumssq
3515  sumssq = sumssq + errbnd
3516  ssq = one + ssq*( scale/absxi )**2
3517  sumsca = absxi
3518  scale = absxi
3519  ELSE
3520  sumssq = ssq + ( ( absxi/scale )**2 ) * fact
3521  errbnd = addbnd * sumssq
3522  sumssq = sumssq + errbnd
3523  ssq = ssq + ( absxi/scale )**2
3524  END IF
3525  END IF
3526  IF( dimag( x( ix ) ).NE.zero ) THEN
3527  absxi = abs( dimag( x( ix ) ) )
3528  IF( scale.LT.absxi )THEN
3529  sumssq = one + ( ssq*( scale/absxi )**2 ) * fact
3530  errbnd = addbnd * sumssq
3531  sumssq = sumssq + errbnd
3532  ssq = one + ssq*( scale/absxi )**2
3533  sumsca = absxi
3534  scale = absxi
3535  ELSE
3536  sumssq = ssq + ( ( absxi/scale )**2 ) * fact
3537  errbnd = addbnd * sumssq
3538  sumssq = sumssq + errbnd
3539  ssq = ssq + ( absxi/scale )**2
3540  END IF
3541  END IF
3542  10 CONTINUE
3543 *
3544  usclr = scale * sqrt( ssq )
3545 *
3546 * Error on square root
3547 *
3548  errbnd = sqrt( sumssq ) * ( one + two * ( 1.00001d+0 * prec ) )
3549 *
3550  errbnd = ( sumsca * errbnd ) - usclr
3551 *
3552  RETURN
3553 *
3554 * End of PZERRNRM2
3555 *
3556  END
3557  SUBROUTINE pzerrasum( ERRBND, N, USCLR, X, INCX, PREC )
3558 *
3559 * -- PBLAS test routine (version 2.0) --
3560 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3561 * and University of California, Berkeley.
3562 * April 1, 1998
3563 *
3564 * .. Scalar Arguments ..
3565  INTEGER INCX, N
3566  DOUBLE PRECISION ERRBND, PREC, USCLR
3567 * ..
3568 * .. Array Arguments ..
3569  COMPLEX*16 X( * )
3570 * ..
3571 *
3572 * Purpose
3573 * =======
3574 *
3575 * PZERRASUM serially computes the sum of absolute values of the vector
3576 * X and returns a scaled relative acceptable error bound on the result.
3577 *
3578 * Arguments
3579 * =========
3580 *
3581 * ERRBND (global output) DOUBLE PRECISION
3582 * On exit, ERRBND specifies a scaled relative acceptable error
3583 * bound. In this case the error bound is just the absolute sum
3584 * multiplied by a constant proportional to the machine preci-
3585 * sion.
3586 *
3587 * N (global input) INTEGER
3588 * On entry, N specifies the length of the vector operand.
3589 *
3590 * USCLR (global output) DOUBLE PRECISION
3591 * On exit, USCLR specifies the sum of absolute values of the
3592 * vector X.
3593 *
3594 * X (global input) COMPLEX*16 array
3595 * On entry, X is an array of dimension at least
3596 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
3597 * ted array X must contain the vector x.
3598 *
3599 * INCX (global input) INTEGER.
3600 * On entry, INCX specifies the increment for the elements of X.
3601 * INCX must not be zero.
3602 *
3603 * PREC (global input) DOUBLE PRECISION
3604 * On entry, PREC specifies the machine precision.
3605 *
3606 * -- Written on April 1, 1998 by
3607 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3608 *
3609 * =====================================================================
3610 *
3611 * .. Parameters ..
3612  DOUBLE PRECISION TWO, ZERO
3613  PARAMETER ( TWO = 2.0d+0, zero = 0.0d+0 )
3614 * ..
3615 * .. Local Scalars ..
3616  INTEGER IX
3617  DOUBLE PRECISION ADDBND
3618 * ..
3619 * .. Intrinsic Functions ..
3620  INTRINSIC ABS, DBLE, DIMAG
3621 * ..
3622 * .. Executable Statements ..
3623 *
3624  ix = 1
3625  usclr = zero
3626  addbnd = two * two * two * prec
3627 *
3628  DO 10 ix = 1, 1 + ( n - 1 )*incx, incx
3629  usclr = usclr + abs( dble( x( ix ) ) ) +
3630  $ abs( dimag( x( ix ) ) )
3631  10 CONTINUE
3632 *
3633  errbnd = addbnd * usclr
3634 *
3635  RETURN
3636 *
3637 * End of PZERRASUM
3638 *
3639  END
3640  SUBROUTINE pzerrscal( ERRBND, PSCLR, X, PREC )
3641 *
3642 * -- PBLAS test routine (version 2.0) --
3643 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3644 * and University of California, Berkeley.
3645 * April 1, 1998
3646 *
3647 * .. Scalar Arguments ..
3648  DOUBLE PRECISION ERRBND, PREC
3649  COMPLEX*16 PSCLR, X
3650 * ..
3651 *
3652 * Purpose
3653 * =======
3654 *
3655 * PZERRSCAL serially computes the product PSCLR * X and returns a sca-
3656 * led relative acceptable error bound on the result.
3657 *
3658 * Notes
3659 * =====
3660 *
3661 * If s1 = PSCLR*X and s2 are two different computed results, and s1 is
3662 * being assumed to be correct, we require
3663 *
3664 * abs( s1 - s2 ) <= ERRBND = ERRFACT * abs( s1 ),
3665 *
3666 * where ERRFACT is computed as two times the machine precision.
3667 *
3668 * Arguments
3669 * =========
3670 *
3671 * ERRBND (global output) DOUBLE PRECISION
3672 * On exit, ERRBND specifies the scaled relative acceptable er-
3673 * ror bound.
3674 *
3675 * PSCLR (global input) COMPLEX*16
3676 * On entry, PSCLR specifies the scale factor.
3677 *
3678 * X (global input/global output) COMPLEX*16
3679 * On entry, X specifies the scalar to be scaled. On exit, X is
3680 * the scaled entry.
3681 *
3682 * PREC (global input) DOUBLE PRECISION
3683 * On entry, PREC specifies the machine precision.
3684 *
3685 * -- Written on April 1, 1998 by
3686 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3687 *
3688 * =====================================================================
3689 *
3690 * .. Parameters ..
3691  DOUBLE PRECISION TWO
3692  PARAMETER ( TWO = 2.0d+0 )
3693 * ..
3694 * .. Intrinsic Functions ..
3695  INTRINSIC abs
3696 * ..
3697 * .. Executable Statements ..
3698 *
3699  x = psclr * x
3700 *
3701  errbnd = ( two * prec ) * abs( x )
3702 *
3703  RETURN
3704 *
3705 * End of PZERRSCAL
3706 *
3707  END
3708  SUBROUTINE pzderrscal( ERRBND, PUSCLR, X, PREC )
3709 *
3710 * -- PBLAS test routine (version 2.0) --
3711 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3712 * and University of California, Berkeley.
3713 * April 1, 1998
3714 *
3715 * .. Scalar Arguments ..
3716  DOUBLE PRECISION ERRBND, PREC, PUSCLR
3717  COMPLEX*16 X
3718 * ..
3719 *
3720 * Purpose
3721 * =======
3722 *
3723 * PZDERRSCAL serially computes the product PUSCLR * X and returns a
3724 * scaled relative acceptable error bound on the result.
3725 *
3726 * Notes
3727 * =====
3728 *
3729 * If s1 = PUSCLR*X and s2 are two different computed results, and s1 is
3730 * being assumed to be correct, we require
3731 *
3732 * abs( s1 - s2 ) <= ERRBND = ERRFACT * abs( s1 ),
3733 *
3734 * where ERRFACT is computed as two times the machine precision.
3735 *
3736 * Arguments
3737 * =========
3738 *
3739 * ERRBND (global output) DOUBLE PRECISION
3740 * On exit, ERRBND specifies the scaled relative acceptable er-
3741 * ror bound.
3742 *
3743 * PUSCLR (global input) DOUBLE PRECISION
3744 * On entry, PUSCLR specifies the real scale factor.
3745 *
3746 * X (global input/global output) COMPLEX*16
3747 * On entry, X specifies the scalar to be scaled. On exit, X is
3748 * the scaled entry.
3749 *
3750 * PREC (global input) DOUBLE PRECISION
3751 * On entry, PREC specifies the machine precision.
3752 *
3753 * -- Written on April 1, 1998 by
3754 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3755 *
3756 * =====================================================================
3757 *
3758 * .. Parameters ..
3759  DOUBLE PRECISION TWO
3760  PARAMETER ( TWO = 2.0d+0 )
3761 * ..
3762 * .. Intrinsic Functions ..
3763  INTRINSIC abs, dble, dcmplx, dimag
3764 * ..
3765 * .. Executable Statements ..
3766 *
3767  x = dcmplx( pusclr * dble( x ), pusclr * dimag( x ) )
3768 *
3769  errbnd = ( two * prec ) * abs( x )
3770 *
3771  RETURN
3772 *
3773 * End of PZDERRSCAL
3774 *
3775  END
3776  SUBROUTINE pzerraxpy( ERRBND, PSCLR, X, Y, PREC )
3777 *
3778 * -- PBLAS test routine (version 2.0) --
3779 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3780 * and University of California, Berkeley.
3781 * April 1, 1998
3782 *
3783 * .. Scalar Arguments ..
3784  DOUBLE PRECISION ERRBND, PREC
3785  COMPLEX*16 PSCLR, X, Y
3786 * ..
3787 *
3788 * Purpose
3789 * =======
3790 *
3791 * PZERRAXPY serially computes Y := Y + PSCLR * X and returns a scaled
3792 * relative acceptable error bound on the result.
3793 *
3794 * Arguments
3795 * =========
3796 *
3797 * ERRBND (global output) DOUBLE PRECISION
3798 * On exit, ERRBND specifies the scaled relative acceptable er-
3799 * ror bound.
3800 *
3801 * PSCLR (global input) COMPLEX*16
3802 * On entry, PSCLR specifies the scale factor.
3803 *
3804 * X (global input) COMPLEX*16
3805 * On entry, X specifies the scalar to be scaled.
3806 *
3807 * Y (global input/global output) COMPLEX*16
3808 * On entry, Y specifies the scalar to be added. On exit, Y con-
3809 * tains the resulting scalar.
3810 *
3811 * PREC (global input) DOUBLE PRECISION
3812 * On entry, PREC specifies the machine precision.
3813 *
3814 * -- Written on April 1, 1998 by
3815 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3816 *
3817 * =====================================================================
3818 *
3819 * .. Parameters ..
3820  DOUBLE PRECISION ONE, TWO, ZERO
3821  PARAMETER ( ONE = 1.0d+0, two = 2.0d+0,
3822  $ zero = 0.0d+0 )
3823 * ..
3824 * .. Local Scalars ..
3825  DOUBLE PRECISION ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
3826  $ SUMRPOS
3827  COMPLEX*16 TMP
3828 * ..
3829 * .. Intrinsic Functions ..
3830  INTRINSIC DBLE, DIMAG, MAX
3831 * ..
3832 * .. Executable Statements ..
3833 *
3834  sumipos = zero
3835  sumineg = zero
3836  sumrpos = zero
3837  sumrneg = zero
3838  fact = one + two * prec
3839  addbnd = two * two * two * prec
3840 *
3841  tmp = psclr * x
3842  IF( dble( tmp ).GE.zero ) THEN
3843  sumrpos = sumrpos + dble( tmp ) * fact
3844  ELSE
3845  sumrneg = sumrneg - dble( tmp ) * fact
3846  END IF
3847  IF( dimag( tmp ).GE.zero ) THEN
3848  sumipos = sumipos + dimag( tmp ) * fact
3849  ELSE
3850  sumineg = sumineg - dimag( tmp ) * fact
3851  END IF
3852 *
3853  tmp = y
3854  IF( dble( tmp ).GE.zero ) THEN
3855  sumrpos = sumrpos + dble( tmp )
3856  ELSE
3857  sumrneg = sumrneg - dble( tmp )
3858  END IF
3859  IF( dimag( tmp ).GE.zero ) THEN
3860  sumipos = sumipos + dimag( tmp )
3861  ELSE
3862  sumineg = sumineg - dimag( tmp )
3863  END IF
3864 *
3865  y = y + ( psclr * x )
3866 *
3867  errbnd = addbnd * max( max( sumrpos, sumrneg ),
3868  $ max( sumipos, sumineg ) )
3869 *
3870  RETURN
3871 *
3872 * End of PZERRAXPY
3873 *
3874  END
pzchkvin
subroutine pzchkvin(ERRMAX, N, X, PX, IX, JX, DESCX, INCX, INFO)
Definition: pzblastst.f:2582
pisinscope
logical function pisinscope(ICTXT, N, IX, JX, DESCX, INCX)
Definition: pcblas1tst.f:2078
max
#define max(A, B)
Definition: pcgemr.c:180
pb_descset2
subroutine pb_descset2(DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC, CTXT, LLD)
Definition: pblastst.f:3172
pzerrdotu
subroutine pzerrdotu(ERRBND, N, SCLR, X, INCX, Y, INCY, PREC)
Definition: pzblas1tst.f:3137
pzderrscal
subroutine pzderrscal(ERRBND, PUSCLR, X, PREC)
Definition: pzblas1tst.f:3709
pzmprnt
subroutine pzmprnt(ICTXT, NOUT, M, N, A, LDA, IRPRNT, ICPRNT, CMATNM)
Definition: pzblastst.f:3955
pb_zchekpad
subroutine pb_zchekpad(ICTXT, MESS, M, N, A, LDA, IPRE, IPOST, CHKVAL)
Definition: pzblastst.f:9875
pzchkvout
subroutine pzchkvout(N, X, PX, IX, JX, DESCX, INCX, INFO)
Definition: pzblastst.f:2876
pzdimee
subroutine pzdimee(ICTXT, NOUT, SUBPTR, SCODE, SNAME)
Definition: pzblastst.f:455
pb_pzlaprnt
subroutine pb_pzlaprnt(M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT, CMATNM, NOUT, WORK)
Definition: pzblastst.f:9304
pzvecee
subroutine pzvecee(ICTXT, NOUT, SUBPTR, SCODE, SNAME)
Definition: pzblastst.f:936
pzchkarg1
subroutine pzchkarg1(ICTXT, NOUT, SNAME, N, ALPHA, IX, JX, DESCX, INCX, IY, JY, DESCY, INCY, INFO)
Definition: pzblas1tst.f:1778
pzvprnt
subroutine pzvprnt(ICTXT, NOUT, N, X, INCX, IRPRNT, ICPRNT, CVECNM)
Definition: pzblastst.f:4067
pzblas1tstchke
subroutine pzblas1tstchke(LTEST, INOUT, NPROCS)
Definition: pzblas1tst.f:1495
pzerrdotc
subroutine pzerrdotc(ERRBND, N, SCLR, X, INCX, Y, INCY, PREC)
Definition: pzblas1tst.f:3281
pb_infog2l
subroutine pb_infog2l(I, J, DESC, NPROW, NPCOL, MYROW, MYCOL, II, JJ, PROW, PCOL)
Definition: pblastst.f:1673
pzerraxpy
subroutine pzerraxpy(ERRBND, PSCLR, X, Y, PREC)
Definition: pzblas1tst.f:3777
pzbla1tst
program pzbla1tst
Definition: pzblas1tst.f:12
pzlagen
subroutine pzlagen(INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA, DESCA, IASEED, A, LDA)
Definition: pzblastst.f:8492
pzerrscal
subroutine pzerrscal(ERRBND, PSCLR, X, PREC)
Definition: pzblas1tst.f:3641
pzbla1tstinfo
subroutine pzbla1tstinfo(SUMMRY, NOUT, NMAT, NVAL, 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, LTEST, SOF, TEE, IAM, IGAP, IVERB, NPROCS, ALPHA, WORK)
Definition: pzblas1tst.f:802
pzerrnrm2
subroutine pzerrnrm2(ERRBND, N, USCLR, X, INCX, PREC)
Definition: pzblas1tst.f:3425
icopy
subroutine icopy(N, SX, INCX, SY, INCY)
Definition: pblastst.f:1525
pzerrasum
subroutine pzerrasum(ERRBND, N, USCLR, X, INCX, PREC)
Definition: pzblas1tst.f:3558
pb_zfillpad
subroutine pb_zfillpad(ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL)
Definition: pzblastst.f:9762
pdlamch
double precision function pdlamch(ICTXT, CMACH)
Definition: pdblastst.f:6769
pzblas1tstchk
subroutine pzblas1tstchk(ICTXT, NOUT, NROUT, N, PSCLR, PUSCLR, PISCLR, X, PX, IX, JX, DESCX, INCX, Y, PY, IY, JY, DESCY, INCY, INFO)
Definition: pzblas1tst.f:2255
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