ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pcblas1tst.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/'PCSWAP ', 'PCSCAL ',
7  $ 'PCSSCAL', 'PCCOPY ', 'PCAXPY ',
8  $ 'PCDOTU ', 'PCDOTC ', 'PSCNRM2',
9  $ 'PSCASUM', 'PCAMAX'/
10  END BLOCK DATA
11 
12  PROGRAM pcbla1tst
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 * PCBLA1TST 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 * 'PCBLAS1TST.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.0E0, 0.0E0) 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 * PCSWAP T put F for no test in the same column
63 * PCSCAL T put F for no test in the same column
64 * PCSSCAL T put F for no test in the same column
65 * PCCOPY T put F for no test in the same column
66 * PCAXPY T put F for no test in the same column
67 * PCDOTU T put F for no test in the same column
68 * PCDOTC T put F for no test in the same column
69 * PSCNRM2 T put F for no test in the same column
70 * PSCASUM T put F for no test in the same column
71 * PCAMAX 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 * REALSZ INTEGER
89 * CPLXSZ INTEGER
90 * REALSZ and CPLXSZ indicate the length in bytes on the given
91 * platform for a single precision real and a single precision
92 * complex. By default, REALSZ is set to four and CPLXSZ is set
93 * to eight.
94 *
95 * MEM COMPLEX array
96 * MEM is an array of dimension TOTMEM / CPLXSZ.
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, cplxsz, totmem,
109  $ memsiz, nsubs
110  REAL rzero
111  COMPLEX padval, zero
112  parameter( maxtests = 20, maxgrids = 20, gapmul = 10,
113  $ cplxsz = 8, totmem = 2000000,
114  $ memsiz = totmem / cplxsz,
115  $ padval = ( -9923.0e+0, -9923.0e+0 ),
116  $ rzero = 0.0e+0, zero = ( 0.0e+0, 0.0e+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  REAL pusclr
137  COMPLEX 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 mem( memsiz )
159 * ..
160 * .. External Subroutines ..
161  EXTERNAL blacs_exit, blacs_get, blacs_gridexit,
162  $ blacs_gridinfo, blacs_gridinit, blacs_pinfo,
163  $ igsum2d, pb_cchekpad, pb_cfillpad, pb_descset2,
164  $ pb_pclaprnt, pcamax, pcaxpy, pcbla1tstinfo,
165  $ pcblas1tstchk, pcblas1tstchke, pcchkarg1,
166  $ pcchkvout, pccopy, pcdotc, pcdotu, pclagen,
167  $ pcmprnt, pcscal, pcsscal, pcswap, pcvprnt,
168  $ pscasum, pscnrm2, pvdescchk, pvdimchk
169 * ..
170 * .. Intrinsic Functions ..
171  INTRINSIC abs, max, mod, real
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 pcbla1tstinfo( 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 pcblas1tstchke( 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*cplxsz
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 pclagen( .false., 'None', 'No diag', 0, mx, nx, 1,
416  $ 1, descx, ixseed, mem( ipx ),
417  $ descx( lld_ ) )
418  IF( ycheck( k ) )
419  $ CALL pclagen( .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 pclagen( .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 pclagen( .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_cfillpad( ictxt, mpx, nqx, mem( ipx-iprex ),
441  $ descx( lld_ ), iprex, ipostx, padval )
442 *
443  IF( ycheck( k ) ) THEN
444  CALL pb_cfillpad( 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 pcchkarg1( 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_pclaprnt( 1, n, mem( ipx ), ix, jx, descx,
466  $ 0, 0, 'PARALLEL_INITIAL_X', nout,
467  $ mem( ipw ) )
468  ELSE
469  CALL pb_pclaprnt( 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_pclaprnt( 1, n, mem( ipy ), iy, jy,
476  $ descy, 0, 0,
477  $ 'PARALLEL_INITIAL_Y', nout,
478  $ mem( ipw ) )
479  ELSE
480  CALL pb_pclaprnt( 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_pclaprnt( mx, nx, mem( ipx ), 1, 1, descx, 0,
488  $ 0, 'PARALLEL_INITIAL_X', nout,
489  $ mem( ipw ) )
490  IF( ycheck( k ) )
491  $ CALL pb_pclaprnt( 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 PCSWAP
501 *
502  CALL pcswap( 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 PCSCAL
508 *
509  psclr = alpha
510  CALL pcscal( n, alpha, mem( ipx ), ix, jx, descx,
511  $ incx )
512 *
513  ELSE IF( k.EQ.3 ) THEN
514 *
515 * Test PCSSCAL
516 *
517  pusclr = real( alpha )
518  CALL pcsscal( n, real( alpha ), mem( ipx ), ix, jx,
519  $ descx, incx )
520 *
521  ELSE IF( k.EQ.4 ) THEN
522 *
523 * Test PCCOPY
524 *
525  CALL pccopy( 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 PCAXPY
531 *
532  psclr = alpha
533  CALL pcaxpy( 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 PCDOTU
539 *
540  CALL pcdotu( 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 PCDOTC
546 *
547  CALL pcdotc( 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 PSCNRM2
553 *
554  CALL pscnrm2( n, pusclr, mem( ipx ), ix, jx, descx,
555  $ incx )
556 *
557  ELSE IF( k.EQ.9 ) THEN
558 *
559 * Test PSCASUM
560 *
561  CALL pscasum( n, pusclr, mem( ipx ), ix, jx, descx,
562  $ incx )
563 *
564  ELSE IF( k.EQ.10 ) THEN
565 *
566  CALL pcamax( 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 pcblas1tstchk( 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_cchekpad( ictxt, snames( k ), mpx, nqx,
599  $ mem( ipx-iprex ), descx( lld_ ),
600  $ iprex, ipostx, padval )
601  IF( ycheck( k ) ) THEN
602  CALL pb_cchekpad( 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 pcchkarg1( 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 pcchkvout( 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 pcchkvout( 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 pcmprnt( ictxt, nout, mx, nx, mem( ipmatx ),
654  $ ldx, 0, 0, 'SERIAL_X' )
655  CALL pb_pclaprnt( 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 pcvprnt( 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_pclaprnt( 1, n, mem( ipx ), ix, jx,
665  $ descx, 0, 0, 'PARALLEL_X',
666  $ nout, mem( ipmatx ) )
667  ELSE
668  CALL pb_pclaprnt( 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 pcmprnt( ictxt, nout, my, ny,
676  $ mem( ipmaty ), ldy, 0, 0,
677  $ 'SERIAL_Y' )
678  CALL pb_pclaprnt( 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 pcvprnt( 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_pclaprnt( 1, n, mem( ipy ), iy, jy,
688  $ descy, 0, 0, 'PARALLEL_Y',
689  $ nout, mem( ipmatx ) )
690  ELSE
691  CALL pb_pclaprnt( 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 PCBLA1TST
791 *
792  END
793  SUBROUTINE pcbla1tstinfo( 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 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 * PCBLA1TSTINFO 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
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  REAL 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, cgebr2d, cgebs2d,
1051  $ icopy, igebr2d, igebs2d, sgebr2d, sgebs2d
1052 * ..
1053 * .. External Functions ..
1054  REAL PSLAMCH
1055  EXTERNAL PSLAMCH
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='PCBLAS1TST.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 = pslamch( ictxt, 'eps' )
1210 *
1211 * Pack information arrays and broadcast
1212 *
1213  CALL cgebs2d( 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 single 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 = pslamch( ictxt, 'eps' )
1368 *
1369  CALL cgebr2d( 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 PCBLA1TSTINFO
1492 *
1493  END
1494  SUBROUTINE pcblas1tstchke( 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 * PCBLAS1TSTCHKE 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., PCSWAP will be tested;
1582 * If LTEST( 2 ) is .TRUE., PCSCAL will be tested;
1583 * If LTEST( 3 ) is .TRUE., PCSSCAL will be tested;
1584 * If LTEST( 4 ) is .TRUE., PCCOPY will be tested;
1585 * If LTEST( 5 ) is .TRUE., PCAXPY will be tested;
1586 * If LTEST( 6 ) is .TRUE., PCDOTU will be tested;
1587 * If LTEST( 7 ) is .TRUE., PCDOTC will be tested;
1588 * If LTEST( 8 ) is .TRUE., PSCNRM2 will be tested;
1589 * If LTEST( 9 ) is .TRUE., PSCASUM will be tested;
1590 * If LTEST( 10 ) is .TRUE., PCAMAX 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, pcamax, pcaxpy, pccopy,
1650  $ pcdimee, pcdotc, pcdotu, pcscal, pcsscal,
1651  $ pcswap, pcvecee, pscasum, pscnrm2
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 PCSWAP
1681 *
1682  i = 1
1683  IF( ltest( i ) ) THEN
1684  CALL pcdimee( ictxt, nout, pcswap, scode( i ), snames( i ) )
1685  CALL pcvecee( ictxt, nout, pcswap, scode( i ), snames( i ) )
1686  END IF
1687 *
1688 * Test PCSCAL
1689 *
1690  i = i + 1
1691  IF( ltest( i ) ) THEN
1692  CALL pcdimee( ictxt, nout, pcscal, scode( i ), snames( i ) )
1693  CALL pcvecee( ictxt, nout, pcscal, scode( i ), snames( i ) )
1694  END IF
1695 *
1696 * Test PCSSCAL
1697 *
1698  i = i + 1
1699  IF( ltest( i ) ) THEN
1700  CALL pcdimee( ictxt, nout, pcsscal, scode( i ), snames( i ) )
1701  CALL pcvecee( ictxt, nout, pcsscal, scode( i ), snames( i ) )
1702  END IF
1703 *
1704 * Test PCCOPY
1705 *
1706  i = i + 1
1707  IF( ltest( i ) ) THEN
1708  CALL pcdimee( ictxt, nout, pccopy, scode( i ), snames( i ) )
1709  CALL pcvecee( ictxt, nout, pccopy, scode( i ), snames( i ) )
1710  END IF
1711 *
1712 * Test PCAXPY
1713 *
1714  i = i + 1
1715  IF( ltest( i ) ) THEN
1716  CALL pcdimee( ictxt, nout, pcaxpy, scode( i ), snames( i ) )
1717  CALL pcvecee( ictxt, nout, pcaxpy, scode( i ), snames( i ) )
1718  END IF
1719 *
1720 * Test PCDOTU
1721 *
1722  i = i + 1
1723  IF( ltest( i ) ) THEN
1724  CALL pcdimee( ictxt, nout, pcdotu, scode( i ), snames( i ) )
1725  CALL pcvecee( ictxt, nout, pcdotu, scode( i ), snames( i ) )
1726  END IF
1727 *
1728 * Test PCDOTC
1729 *
1730  i = i + 1
1731  IF( ltest( i ) ) THEN
1732  CALL pcdimee( ictxt, nout, pcdotc, scode( i ), snames( i ) )
1733  CALL pcvecee( ictxt, nout, pcdotc, scode( i ), snames( i ) )
1734  END IF
1735 *
1736 * PSCNRM2
1737 *
1738  i = i + 1
1739  IF( ltest( i ) ) THEN
1740  CALL pcdimee( ictxt, nout, pscnrm2, scode( i ), snames( i ) )
1741  CALL pcvecee( ictxt, nout, pscnrm2, scode( i ), snames( i ) )
1742  END IF
1743 *
1744 * Test PSCASUM
1745 *
1746  i = i + 1
1747  IF( ltest( i ) ) THEN
1748  CALL pcdimee( ictxt, nout, pscasum, scode( i ), snames( i ) )
1749  CALL pcvecee( ictxt, nout, pscasum, scode( i ), snames( i ) )
1750  END IF
1751 *
1752 * Test PCAMAX
1753 *
1754  i = i + 1
1755  IF( ltest( i ) ) THEN
1756  CALL pcdimee( ictxt, nout, pcamax, scode( i ), snames( i ) )
1757  CALL pcvecee( ictxt, nout, pcamax, 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 PCBLAS1TSTCHKE
1774 *
1775  END
1776  SUBROUTINE pcchkarg1( 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 ALPHA
1788 * ..
1789 * .. Array Arguments ..
1790  CHARACTER*(*) SNAME
1791  INTEGER DESCX( * ), DESCY( * )
1792 * ..
1793 *
1794 * Purpose
1795 * =======
1796 *
1797 * PCCHKARG1 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
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 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 PCCHKARG1
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 pcblas1tstchk( 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  REAL PUSCLR
2265  COMPLEX PSCLR
2266 * ..
2267 * .. Array Arguments ..
2268  INTEGER DESCX( * ), DESCY( * )
2269  COMPLEX PX( * ), PY( * ), X( * ), Y( * )
2270 * ..
2271 *
2272 * Purpose
2273 * =======
2274 *
2275 * PCBLAS1TSTCHK 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, PCSWAP will be tested;
2357 * else if NROUT = 2, PCSCAL will be tested;
2358 * else if NROUT = 3, PCSSCAL will be tested;
2359 * else if NROUT = 4, PCCOPY will be tested;
2360 * else if NROUT = 5, PCAXPY will be tested;
2361 * else if NROUT = 6, PCDOTU will be tested;
2362 * else if NROUT = 7, PCDOTC will be tested;
2363 * else if NROUT = 8, PSCNRM2 will be tested;
2364 * else if NROUT = 9, PSCASUM will be tested;
2365 * else if NROUT = 10, PCAMAX 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
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) REAL
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) REAL
2383 * On entry, PISCLR specifies the value of the global index re-
2384 * turned by PCAMAX, otherwise PISCLR is not used.
2385 *
2386 * X (local input/local output) COMPLEX 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 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 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 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  REAL RZERO
2448  COMPLEX ZERO
2449  PARAMETER ( ZERO = ( 0.0e+0, 0.0e+0 ),
2450  $ rzero = 0.0e+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  REAL ERR, ERRMAX, PREC, USCLR
2466  COMPLEX SCLR
2467 * ..
2468 * .. Local Arrays ..
2469  INTEGER IERR( 6 )
2470  CHARACTER*5 ARGIN1, ARGIN2, ARGOUT1, ARGOUT2
2471 * ..
2472 * .. External Subroutines ..
2473  EXTERNAL blacs_gridinfo, ccopy, cswap, igamx2d,
2474  $ pb_infog2l, pcchkvin, pcerrasum, pcerraxpy,
2475  $ pcerrdotc, pcerrdotu, pcerrnrm2, pcerrscal,
2476  $ pcserrscal
2477 * ..
2478 * .. External Functions ..
2479  LOGICAL PISINSCOPE
2480  INTEGER ICAMAX
2481  REAL PSLAMCH
2482  EXTERNAL ICAMAX, PISINSCOPE, PSLAMCH
2483 * ..
2484 * .. Intrinsic Functions ..
2485  INTRINSIC min
2486 * ..
2487 * .. Executable Statements ..
2488 *
2489  info = 0
2490 *
2491 * Quick return if possible
2492 *
2493  IF( n.LE.0 )
2494  $ RETURN
2495 *
2496  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2497 *
2498  argin1 = ' '
2499  argin2 = ' '
2500  argout1 = ' '
2501  argout2 = ' '
2502  DO 10 i = 1, 6
2503  ierr( i ) = 0
2504  10 CONTINUE
2505 *
2506  prec = pslamch( ictxt, 'precision' )
2507 *
2508  IF( nrout.EQ.1 ) THEN
2509 *
2510 * Test PCSWAP
2511 *
2512  ioffx = ix + ( jx - 1 ) * descx( m_ )
2513  ioffy = iy + ( jy - 1 ) * descy( m_ )
2514  CALL cswap( n, x( ioffx ), incx, y( ioffy ), incy )
2515  CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2516  $ ierr( 1 ) )
2517  CALL pcchkvin( errmax, n, y, py, iy, jy, descy, incy,
2518  $ ierr( 2 ) )
2519 *
2520  ELSE IF( nrout.EQ.2 ) THEN
2521 *
2522 * Test PCSCAL
2523 *
2524  ldx = descx( lld_ )
2525  ioffx = ix + ( jx - 1 ) * descx( m_ )
2526  CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol,
2527  $ iix, jjx, ixrow, ixcol )
2528  icurrow = ixrow
2529  icurcol = ixcol
2530  rowrep = ( ixrow.EQ.-1 )
2531  colrep = ( ixcol.EQ.-1 )
2532 *
2533  IF( incx.EQ.descx( m_ ) ) THEN
2534 *
2535 * sub( X ) is a row vector
2536 *
2537  jb = descx( inb_ ) - jx + 1
2538  IF( jb.LE.0 )
2539  $ jb = ( (-jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2540  jb = min( jb, n )
2541  jn = jx + jb - 1
2542 *
2543  DO 20 j = jx, jn
2544 *
2545  CALL pcerrscal( err, psclr, x( ioffx ), prec )
2546 *
2547  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2548  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2549  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2550  $ err )
2551  $ ierr( 1 ) = 1
2552  jjx = jjx + 1
2553  END IF
2554 *
2555  ioffx = ioffx + incx
2556 *
2557  20 CONTINUE
2558 *
2559  icurcol = mod( icurcol+1, npcol )
2560 *
2561  DO 40 j = jn+1, jx+n-1, descx( nb_ )
2562  jb = min( jx+n-j, descx( nb_ ) )
2563 *
2564  DO 30 kk = 0, jb-1
2565 *
2566  CALL pcerrscal( err, psclr, x( ioffx ), prec )
2567 *
2568  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2569  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2570  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2571  $ err )
2572  $ ierr( 1 ) = 1
2573  jjx = jjx + 1
2574  END IF
2575 *
2576  ioffx = ioffx + incx
2577 *
2578  30 CONTINUE
2579 *
2580  icurcol = mod( icurcol+1, npcol )
2581 *
2582  40 CONTINUE
2583 *
2584  ELSE
2585 *
2586 * sub( X ) is a column vector
2587 *
2588  ib = descx( imb_ ) - ix + 1
2589  IF( ib.LE.0 )
2590  $ ib = ( (-ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2591  ib = min( ib, n )
2592  in = ix + ib - 1
2593 *
2594  DO 50 i = ix, in
2595 *
2596  CALL pcerrscal( err, psclr, x( ioffx ), prec )
2597 *
2598  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2599  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2600  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2601  $ err )
2602  $ ierr( 1 ) = 1
2603  iix = iix + 1
2604  END IF
2605 *
2606  ioffx = ioffx + incx
2607 *
2608  50 CONTINUE
2609 *
2610  icurrow = mod( icurrow+1, nprow )
2611 *
2612  DO 70 i = in+1, ix+n-1, descx( mb_ )
2613  ib = min( ix+n-i, descx( mb_ ) )
2614 *
2615  DO 60 kk = 0, ib-1
2616 *
2617  CALL pcerrscal( err, psclr, x( ioffx ), prec )
2618 *
2619  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2620  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2621  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2622  $ err )
2623  $ ierr( 1 ) = 1
2624  iix = iix + 1
2625  END IF
2626 *
2627  ioffx = ioffx + incx
2628  60 CONTINUE
2629 *
2630  icurrow = mod( icurrow+1, nprow )
2631 *
2632  70 CONTINUE
2633 *
2634  END IF
2635 *
2636  ELSE IF( nrout.EQ.3 ) THEN
2637 *
2638 * Test PCSSCAL
2639 *
2640  ldx = descx( lld_ )
2641  ioffx = ix + ( jx - 1 ) * descx( m_ )
2642  CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol,
2643  $ iix, jjx, ixrow, ixcol )
2644  icurrow = ixrow
2645  icurcol = ixcol
2646  rowrep = ( ixrow.EQ.-1 )
2647  colrep = ( ixcol.EQ.-1 )
2648 *
2649  IF( incx.EQ.descx( m_ ) ) THEN
2650 *
2651 * sub( X ) is a row vector
2652 *
2653  jb = descx( inb_ ) - jx + 1
2654  IF( jb.LE.0 )
2655  $ jb = ( (-jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2656  jb = min( jb, n )
2657  jn = jx + jb - 1
2658 *
2659  DO 80 j = jx, jn
2660 *
2661  CALL pcserrscal( err, pusclr, x( ioffx ), prec )
2662 *
2663  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2664  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2665  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2666  $ err )
2667  $ ierr( 1 ) = 1
2668  jjx = jjx + 1
2669  END IF
2670 *
2671  ioffx = ioffx + incx
2672 *
2673  80 CONTINUE
2674 *
2675  icurcol = mod( icurcol+1, npcol )
2676 *
2677  DO 100 j = jn+1, jx+n-1, descx( nb_ )
2678  jb = min( jx+n-j, descx( nb_ ) )
2679 *
2680  DO 90 kk = 0, jb-1
2681 *
2682  CALL pcserrscal( err, pusclr, x( ioffx ), prec )
2683 *
2684  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2685  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2686  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2687  $ err )
2688  $ ierr( 1 ) = 1
2689  jjx = jjx + 1
2690  END IF
2691 *
2692  ioffx = ioffx + incx
2693 *
2694  90 CONTINUE
2695 *
2696  icurcol = mod( icurcol+1, npcol )
2697 *
2698  100 CONTINUE
2699 *
2700  ELSE
2701 *
2702 * sub( X ) is a column vector
2703 *
2704  ib = descx( imb_ ) - ix + 1
2705  IF( ib.LE.0 )
2706  $ ib = ( (-ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2707  ib = min( ib, n )
2708  in = ix + ib - 1
2709 *
2710  DO 110 i = ix, in
2711 *
2712  CALL pcserrscal( err, pusclr, x( ioffx ), prec )
2713 *
2714  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2715  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2716  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2717  $ err )
2718  $ ierr( 1 ) = 1
2719  iix = iix + 1
2720  END IF
2721 *
2722  ioffx = ioffx + incx
2723 *
2724  110 CONTINUE
2725 *
2726  icurrow = mod( icurrow+1, nprow )
2727 *
2728  DO 130 i = in+1, ix+n-1, descx( mb_ )
2729  ib = min( ix+n-i, descx( mb_ ) )
2730 *
2731  DO 120 kk = 0, ib-1
2732 *
2733  CALL pcserrscal( err, pusclr, x( ioffx ), prec )
2734 *
2735  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2736  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2737  IF( abs( px( iix+(jjx-1)*ldx ) - x( ioffx ) ).GT.
2738  $ err )
2739  $ ierr( 1 ) = 1
2740  iix = iix + 1
2741  END IF
2742 *
2743  ioffx = ioffx + incx
2744  120 CONTINUE
2745 *
2746  icurrow = mod( icurrow+1, nprow )
2747 *
2748  130 CONTINUE
2749 *
2750  END IF
2751 *
2752  ELSE IF( nrout.EQ.4 ) THEN
2753 *
2754 * Test PCCOPY
2755 *
2756  ioffx = ix + ( jx - 1 ) * descx( m_ )
2757  ioffy = iy + ( jy - 1 ) * descy( m_ )
2758  CALL ccopy( n, x( ioffx ), incx, y( ioffy ), incy )
2759  CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2760  $ ierr( 1 ) )
2761  CALL pcchkvin( errmax, n, y, py, iy, jy, descy, incy,
2762  $ ierr( 2 ) )
2763 *
2764  ELSE IF( nrout.EQ.5 ) THEN
2765 *
2766 * Test PCAXPY
2767 *
2768  CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2769  $ ierr( 1 ) )
2770  ldy = descy( lld_ )
2771  ioffx = ix + ( jx - 1 ) * descx( m_ )
2772  ioffy = iy + ( jy - 1 ) * descy( m_ )
2773  CALL pb_infog2l( iy, jy, descy, nprow, npcol, myrow, mycol,
2774  $ iiy, jjy, iyrow, iycol )
2775  icurrow = iyrow
2776  icurcol = iycol
2777  rowrep = ( iyrow.EQ.-1 )
2778  colrep = ( iycol.EQ.-1 )
2779 *
2780  IF( incy.EQ.descy( m_ ) ) THEN
2781 *
2782 * sub( Y ) is a row vector
2783 *
2784  jb = descy( inb_ ) - jy + 1
2785  IF( jb.LE.0 )
2786  $ jb = ( (-jb ) / descy( nb_ ) + 1 ) * descy( nb_ ) + jb
2787  jb = min( jb, n )
2788  jn = jy + jb - 1
2789 *
2790  DO 140 j = jy, jn
2791 *
2792  CALL pcerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2793  $ prec )
2794 *
2795  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2796  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2797  IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2798  $ err ) THEN
2799  ierr( 2 ) = 1
2800  END IF
2801  jjy = jjy + 1
2802  END IF
2803 *
2804  ioffx = ioffx + incx
2805  ioffy = ioffy + incy
2806 *
2807  140 CONTINUE
2808 *
2809  icurcol = mod( icurcol+1, npcol )
2810 *
2811  DO 160 j = jn+1, jy+n-1, descy( nb_ )
2812  jb = min( jy+n-j, descy( nb_ ) )
2813 *
2814  DO 150 kk = 0, jb-1
2815 *
2816  CALL pcerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2817  $ prec )
2818 *
2819  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2820  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2821  IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2822  $ err ) THEN
2823  ierr( 2 ) = 1
2824  END IF
2825  jjy = jjy + 1
2826  END IF
2827 *
2828  ioffx = ioffx + incx
2829  ioffy = ioffy + incy
2830 *
2831  150 CONTINUE
2832 *
2833  icurcol = mod( icurcol+1, npcol )
2834 *
2835  160 CONTINUE
2836 *
2837  ELSE
2838 *
2839 * sub( Y ) is a column vector
2840 *
2841  ib = descy( imb_ ) - iy + 1
2842  IF( ib.LE.0 )
2843  $ ib = ( (-ib ) / descy( mb_ ) + 1 ) * descy( mb_ ) + ib
2844  ib = min( ib, n )
2845  in = iy + ib - 1
2846 *
2847  DO 170 i = iy, in
2848 *
2849  CALL pcerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2850  $ prec )
2851 *
2852  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2853  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2854  IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2855  $ err ) THEN
2856  ierr( 2 ) = 1
2857  END IF
2858  iiy = iiy + 1
2859  END IF
2860 *
2861  ioffx = ioffx + incx
2862  ioffy = ioffy + incy
2863 *
2864  170 CONTINUE
2865 *
2866  icurrow = mod( icurrow+1, nprow )
2867 *
2868  DO 190 i = in+1, iy+n-1, descy( mb_ )
2869  ib = min( iy+n-i, descy( mb_ ) )
2870 *
2871  DO 180 kk = 0, ib-1
2872 *
2873  CALL pcerraxpy( err, psclr, x( ioffx ), y( ioffy ),
2874  $ prec )
2875 *
2876  IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
2877  $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
2878  IF( abs( py( iiy+(jjy-1)*ldy ) - y( ioffy ) ).GT.
2879  $ err ) THEN
2880  ierr( 2 ) = 1
2881  END IF
2882  iiy = iiy + 1
2883  END IF
2884 *
2885  ioffx = ioffx + incx
2886  ioffy = ioffy + incy
2887 *
2888  180 CONTINUE
2889 *
2890  icurrow = mod( icurrow+1, nprow )
2891 *
2892  190 CONTINUE
2893 *
2894  END IF
2895 *
2896  ELSE IF( nrout.EQ.6 ) THEN
2897 *
2898 * Test PCDOTU
2899 *
2900  CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2901  $ ierr( 1 ) )
2902  CALL pcchkvin( errmax, n, y, py, iy, jy, descy, incy,
2903  $ ierr( 2 ) )
2904  ioffx = ix + ( jx - 1 ) * descx( m_ )
2905  ioffy = iy + ( jy - 1 ) * descy( m_ )
2906  CALL pcerrdotu( err, n, sclr, x( ioffx ), incx, y( ioffy ),
2907  $ incy, prec )
2908  inxscope = pisinscope( ictxt, n, ix, jx, descx, incx )
2909  inyscope = pisinscope( ictxt, n, iy, jy, descy, incy )
2910  IF( inxscope.OR.inyscope ) THEN
2911  IF( abs( psclr - sclr ).GT.err ) THEN
2912  ierr( 3 ) = 1
2913  WRITE( argin1, fmt = '(A)' ) 'DOTU'
2914  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2915  WRITE( nout, fmt = 9998 ) argin1
2916  WRITE( nout, fmt = 9996 ) sclr, psclr
2917  END IF
2918  END IF
2919  ELSE
2920  sclr = zero
2921  IF( psclr.NE.sclr ) THEN
2922  ierr( 4 ) = 1
2923  WRITE( argout1, fmt = '(A)' ) 'DOTU'
2924  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2925  WRITE( nout, fmt = 9997 ) argout1
2926  WRITE( nout, fmt = 9996 ) sclr, psclr
2927  END IF
2928  END IF
2929  END IF
2930 *
2931  ELSE IF( nrout.EQ.7 ) THEN
2932 *
2933 * Test PCDOTC
2934 *
2935  CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2936  $ ierr( 1 ) )
2937  CALL pcchkvin( errmax, n, y, py, iy, jy, descy, incy,
2938  $ ierr( 2 ) )
2939  ioffx = ix + ( jx - 1 ) * descx( m_ )
2940  ioffy = iy + ( jy - 1 ) * descy( m_ )
2941  CALL pcerrdotc( err, n, sclr, x( ioffx ), incx, y( ioffy ),
2942  $ incy, prec )
2943  inxscope = pisinscope( ictxt, n, ix, jx, descx, incx )
2944  inyscope = pisinscope( ictxt, n, iy, jy, descy, incy )
2945  IF( inxscope.OR.inyscope ) THEN
2946  IF( abs( psclr - sclr ).GT.err ) THEN
2947  ierr( 3 ) = 1
2948  WRITE( argin1, fmt = '(A)' ) 'DOTC'
2949  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2950  WRITE( nout, fmt = 9998 ) argin1
2951  WRITE( nout, fmt = 9996 ) sclr, psclr
2952  END IF
2953  END IF
2954  ELSE
2955  sclr = zero
2956  IF( psclr.NE.sclr ) THEN
2957  ierr( 4 ) = 1
2958  WRITE( argout1, fmt = '(A)' ) 'DOTC'
2959  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2960  WRITE( nout, fmt = 9997 ) argout1
2961  WRITE( nout, fmt = 9996 ) sclr, psclr
2962  END IF
2963  END IF
2964  END IF
2965 *
2966  ELSE IF( nrout.EQ.8 ) THEN
2967 *
2968 * Test PSCNRM2
2969 *
2970  CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
2971  $ ierr( 1 ) )
2972  ioffx = ix + ( jx - 1 ) * descx( m_ )
2973  CALL pcerrnrm2( err, n, usclr, x( ioffx ), incx, prec )
2974  IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
2975  IF( abs( pusclr - usclr ).GT.err ) THEN
2976  ierr( 3 ) = 1
2977  WRITE( argin1, fmt = '(A)' ) 'NRM2'
2978  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2979  WRITE( nout, fmt = 9998 ) argin1
2980  WRITE( nout, fmt = 9994 ) usclr, pusclr
2981  END IF
2982  END IF
2983  ELSE
2984  usclr = rzero
2985  IF( pusclr.NE.usclr ) THEN
2986  ierr( 4 ) = 1
2987  WRITE( argout1, fmt = '(A)' ) 'NRM2'
2988  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2989  WRITE( nout, fmt = 9997 ) argout1
2990  WRITE( nout, fmt = 9994 ) usclr, pusclr
2991  END IF
2992  END IF
2993  END IF
2994 *
2995  ELSE IF( nrout.EQ.9 ) THEN
2996 *
2997 * Test PSCASUM
2998 *
2999  CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
3000  $ ierr( 1 ) )
3001  ioffx = ix + ( jx - 1 ) * descx( m_ )
3002  CALL pcerrasum( err, n, usclr, x( ioffx ), incx, prec )
3003  IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
3004  IF( abs( pusclr - usclr ) .GT. err ) THEN
3005  ierr( 3 ) = 1
3006  WRITE( argin1, fmt = '(A)' ) 'ASUM'
3007  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3008  WRITE( nout, fmt = 9998 ) argin1
3009  WRITE( nout, fmt = 9994 ) usclr, pusclr
3010  END IF
3011  END IF
3012  ELSE
3013  usclr = rzero
3014  IF( pusclr.NE.usclr ) THEN
3015  ierr( 4 ) = 1
3016  WRITE( argout1, fmt = '(A)' ) 'ASUM'
3017  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3018  WRITE( nout, fmt = 9997 ) argout1
3019  WRITE( nout, fmt = 9994 ) usclr, pusclr
3020  END IF
3021  END IF
3022  END IF
3023 *
3024  ELSE IF( nrout.EQ.10 ) THEN
3025 *
3026 * Test PCAMAX
3027 *
3028  CALL pcchkvin( errmax, n, x, px, ix, jx, descx, incx,
3029  $ ierr( 1 ) )
3030  ioffx = ix + ( jx - 1 ) * descx( m_ )
3031  IF( pisinscope( ictxt, n, ix, jx, descx, incx ) ) THEN
3032  isclr = icamax( n, x( ioffx ), incx )
3033  IF( n.LT.1 ) THEN
3034  sclr = zero
3035  ELSE IF( ( incx.EQ.1 ).AND.( descx( m_ ).EQ.1 ).AND.
3036  $ ( n.EQ.1 ) ) THEN
3037  isclr = jx
3038  sclr = x( ioffx )
3039  ELSE IF( incx.EQ.descx( m_ ) ) THEN
3040  isclr = jx + isclr - 1
3041  sclr = x( ix + ( isclr - 1 ) * descx( m_ ) )
3042  ELSE
3043  isclr = ix + isclr - 1
3044  sclr = x( isclr + ( jx - 1 ) * descx( m_ ) )
3045  END IF
3046 *
3047  IF( psclr.NE.sclr ) THEN
3048  ierr( 3 ) = 1
3049  WRITE( argin1, fmt = '(A)' ) 'AMAX'
3050  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3051  WRITE( nout, fmt = 9998 ) argin1
3052  WRITE( nout, fmt = 9996 ) sclr, psclr
3053  END IF
3054  END IF
3055 *
3056  IF( pisclr.NE.isclr ) THEN
3057  ierr( 5 ) = 1
3058  WRITE( argin2, fmt = '(A)' ) 'INDX'
3059  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3060  WRITE( nout, fmt = 9998 ) argin2
3061  WRITE( nout, fmt = 9995 ) isclr, pisclr
3062  END IF
3063  END IF
3064  ELSE
3065  isclr = 0
3066  sclr = zero
3067  IF( psclr.NE.sclr ) THEN
3068  ierr( 4 ) = 1
3069  WRITE( argout1, fmt = '(A)' ) 'AMAX'
3070  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3071  WRITE( nout, fmt = 9997 ) argout1
3072  WRITE( nout, fmt = 9996 ) sclr, psclr
3073  END IF
3074  END IF
3075  IF( pisclr.NE.isclr ) THEN
3076  ierr( 6 ) = 1
3077  WRITE( argout2, fmt = '(A)' ) 'INDX'
3078  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
3079  WRITE( nout, fmt = 9997 ) argout2
3080  WRITE( nout, fmt = 9995 ) isclr, pisclr
3081  END IF
3082  END IF
3083  END IF
3084 *
3085  END IF
3086 *
3087 * Find IERR across all processes
3088 *
3089  CALL igamx2d( ictxt, 'All', ' ', 6, 1, ierr, 6, idumm, idumm, -1,
3090  $ -1, 0 )
3091 *
3092 * Encode the errors found in INFO
3093 *
3094  IF( ierr( 1 ).NE.0 ) THEN
3095  info = info + 1
3096  IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3097  $ WRITE( nout, fmt = 9999 ) 'X'
3098  END IF
3099 *
3100  IF( ierr( 2 ).NE.0 ) THEN
3101  info = info + 2
3102  IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3103  $ WRITE( nout, fmt = 9999 ) 'Y'
3104  END IF
3105 *
3106  IF( ierr( 3 ).NE.0 )
3107  $ info = info + 4
3108 *
3109  IF( ierr( 4 ).NE.0 )
3110  $ info = info + 8
3111 *
3112  IF( ierr( 5 ).NE.0 )
3113  $ info = info + 16
3114 *
3115  IF( ierr( 6 ).NE.0 )
3116  $ info = info + 32
3117 *
3118  9999 FORMAT( 2x, ' ***** ERROR: Vector operand ', a,
3119  $ ' is incorrect.' )
3120  9998 FORMAT( 2x, ' ***** ERROR: Output scalar result ', a,
3121  $ ' in scope is incorrect.' )
3122  9997 FORMAT( 2x, ' ***** ERROR: Output scalar result ', a,
3123  $ ' out of scope is incorrect.' )
3124  9996 FORMAT( 2x, ' ***** Expected value is: ', e16.8, '+i*(',
3125  $ e16.8, '),', /2x, ' Obtained value is: ',
3126  $ e16.8, '+i*(', e16.8, ')' )
3127  9995 FORMAT( 2x, ' ***** Expected value is: ', i6, /2x,
3128  $ ' Obtained value is: ', i6 )
3129  9994 FORMAT( 2x, ' ***** Expected value is: ', e16.8, /2x,
3130  $ ' Obtained value is: ', e16.8 )
3131 *
3132  RETURN
3133 *
3134 * End of PCBLAS1TSTCHK
3135 *
3136  END
3137  SUBROUTINE pcerrdotu( ERRBND, N, SCLR, X, INCX, Y, INCY, PREC )
3138 *
3139 * -- PBLAS test routine (version 2.0) --
3140 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3141 * and University of California, Berkeley.
3142 * April 1, 1998
3143 *
3144 * .. Scalar Arguments ..
3145  INTEGER INCX, INCY, N
3146  REAL ERRBND, PREC
3147  COMPLEX SCLR
3148 * ..
3149 * .. Array Arguments ..
3150  COMPLEX X( * ), Y( * )
3151 * ..
3152 *
3153 * Purpose
3154 * =======
3155 *
3156 * PCERRDOTU serially computes the dot product X**T * Y and returns a
3157 * scaled relative acceptable error bound on the result.
3158 *
3159 * Notes
3160 * =====
3161 *
3162 * If dot1 = SCLR and dot2 are two different computed results, and dot1
3163 * is being assumed to be correct, we require
3164 *
3165 * abs( dot1 - dot2 ) <= ERRBND = ERRFACT * abs( dot1 ),
3166 *
3167 * where ERRFACT is computed as the maximum of the positive and negative
3168 * partial sums multiplied by a constant proportional to the machine
3169 * precision.
3170 *
3171 * Arguments
3172 * =========
3173 *
3174 * ERRBND (global output) REAL
3175 * On exit, ERRBND specifies the scaled relative acceptable er-
3176 * ror bound.
3177 *
3178 * N (global input) INTEGER
3179 * On entry, N specifies the length of the vector operands.
3180 *
3181 * SCLR (global output) COMPLEX
3182 * On exit, SCLR specifies the dot product of the two vectors
3183 * X and Y.
3184 *
3185 * X (global input) COMPLEX array
3186 * On entry, X is an array of dimension at least
3187 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
3188 * ted array X must contain the vector x.
3189 *
3190 * INCX (global input) INTEGER.
3191 * On entry, INCX specifies the increment for the elements of X.
3192 * INCX must not be zero.
3193 *
3194 * Y (global input) COMPLEX array
3195 * On entry, Y is an array of dimension at least
3196 * ( 1 + ( n - 1 )*abs( INCY ) ). Before entry, the incremen-
3197 * ted array Y must contain the vector y.
3198 *
3199 * INCY (global input) INTEGER.
3200 * On entry, INCY specifies the increment for the elements of Y.
3201 * INCY must not be zero.
3202 *
3203 * PREC (global input) REAL
3204 * On entry, PREC specifies the machine precision.
3205 *
3206 * -- Written on April 1, 1998 by
3207 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3208 *
3209 * =====================================================================
3210 *
3211 * .. Parameters ..
3212  REAL ONE, TWO, ZERO
3213  PARAMETER ( ONE = 1.0e+0, two = 2.0e+0,
3214  $ zero = 0.0e+0 )
3215 * ..
3216 * .. Local Scalars ..
3217  INTEGER I, IX, IY
3218  REAL ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
3219  $ SUMRPOS, TMP
3220 * ..
3221 * .. Intrinsic Functions ..
3222  INTRINSIC ABS, AIMAG, MAX, REAL
3223 * ..
3224 * .. Executable Statements ..
3225 *
3226  ix = 1
3227  iy = 1
3228  sclr = zero
3229  sumipos = zero
3230  sumineg = zero
3231  sumrpos = zero
3232  sumrneg = zero
3233  fact = two * ( one + prec )
3234  addbnd = two * two * two * prec
3235 *
3236  DO 10 i = 1, n
3237 *
3238  sclr = sclr + x( ix ) * y( iy )
3239 *
3240  tmp = real( x( ix ) ) * real( y( iy ) )
3241  IF( tmp.GE.zero ) THEN
3242  sumrpos = sumrpos + tmp * fact
3243  ELSE
3244  sumrneg = sumrneg - tmp * fact
3245  END IF
3246 *
3247  tmp = - aimag( x( ix ) ) * aimag( y( iy ) )
3248  IF( tmp.GE.zero ) THEN
3249  sumrpos = sumrpos + tmp * fact
3250  ELSE
3251  sumrneg = sumrneg - tmp * fact
3252  END IF
3253 *
3254  tmp = aimag( x( ix ) ) * real( y( iy ) )
3255  IF( tmp.GE.zero ) THEN
3256  sumipos = sumipos + tmp * fact
3257  ELSE
3258  sumineg = sumineg - tmp * fact
3259  END IF
3260 *
3261  tmp = real( x( ix ) ) * aimag( y( iy ) )
3262  IF( tmp.GE.zero ) THEN
3263  sumipos = sumipos + tmp * fact
3264  ELSE
3265  sumineg = sumineg - tmp * fact
3266  END IF
3267 *
3268  ix = ix + incx
3269  iy = iy + incy
3270 *
3271  10 CONTINUE
3272 *
3273  errbnd = addbnd * max( max( sumrpos, sumrneg ),
3274  $ max( sumipos, sumineg ) )
3275 *
3276  RETURN
3277 *
3278 * End of PCERRDOTU
3279 *
3280  END
3281  SUBROUTINE pcerrdotc( ERRBND, N, SCLR, X, INCX, Y, INCY, PREC )
3282 *
3283 * -- PBLAS test routine (version 2.0) --
3284 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3285 * and University of California, Berkeley.
3286 * April 1, 1998
3287 *
3288 * .. Scalar Arguments ..
3289  INTEGER INCX, INCY, N
3290  REAL ERRBND, PREC
3291  COMPLEX SCLR
3292 * ..
3293 * .. Array Arguments ..
3294  COMPLEX X( * ), Y( * )
3295 * ..
3296 *
3297 * Purpose
3298 * =======
3299 *
3300 * PCERRDOTC serially computes the dot product X**H * Y and returns a
3301 * scaled relative acceptable error bound on the result.
3302 *
3303 * Notes
3304 * =====
3305 *
3306 * If dot1 = SCLR and dot2 are two different computed results, and dot1
3307 * is being assumed to be correct, we require
3308 *
3309 * abs( dot1 - dot2 ) <= ERRBND = ERRFACT * abs( dot1 ),
3310 *
3311 * where ERRFACT is computed as the maximum of the positive and negative
3312 * partial sums multiplied by a constant proportional to the machine
3313 * precision.
3314 *
3315 * Arguments
3316 * =========
3317 *
3318 * ERRBND (global output) REAL
3319 * On exit, ERRBND specifies the scaled relative acceptable er-
3320 * ror bound.
3321 *
3322 * N (global input) INTEGER
3323 * On entry, N specifies the length of the vector operands.
3324 *
3325 * SCLR (global output) COMPLEX
3326 * On exit, SCLR specifies the dot product of the two vectors
3327 * X and Y.
3328 *
3329 * X (global input) COMPLEX array
3330 * On entry, X is an array of dimension at least
3331 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
3332 * ted array X must contain the vector x.
3333 *
3334 * INCX (global input) INTEGER.
3335 * On entry, INCX specifies the increment for the elements of X.
3336 * INCX must not be zero.
3337 *
3338 * Y (global input) COMPLEX array
3339 * On entry, Y is an array of dimension at least
3340 * ( 1 + ( n - 1 )*abs( INCY ) ). Before entry, the incremen-
3341 * ted array Y must contain the vector y.
3342 *
3343 * INCY (global input) INTEGER.
3344 * On entry, INCY specifies the increment for the elements of Y.
3345 * INCY must not be zero.
3346 *
3347 * PREC (global input) REAL
3348 * On entry, PREC specifies the machine precision.
3349 *
3350 * -- Written on April 1, 1998 by
3351 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3352 *
3353 * =====================================================================
3354 *
3355 * .. Parameters ..
3356  REAL ONE, TWO, ZERO
3357  PARAMETER ( ONE = 1.0e+0, two = 2.0e+0,
3358  $ zero = 0.0e+0 )
3359 * ..
3360 * .. Local Scalars ..
3361  INTEGER I, IX, IY
3362  REAL ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
3363  $ SUMRPOS, TMP
3364 * ..
3365 * .. Intrinsic Functions ..
3366  INTRINSIC ABS, AIMAG, CONJG, MAX, REAL
3367 * ..
3368 * .. Executable Statements ..
3369 *
3370  ix = 1
3371  iy = 1
3372  sclr = zero
3373  sumipos = zero
3374  sumineg = zero
3375  sumrpos = zero
3376  sumrneg = zero
3377  fact = two * ( one + prec )
3378  addbnd = two * two * two * prec
3379 *
3380  DO 10 i = 1, n
3381 *
3382  sclr = sclr + conjg( x( ix ) ) * y( iy )
3383 *
3384  tmp = real( x( ix ) ) * real( y( iy ) )
3385  IF( tmp.GE.zero ) THEN
3386  sumrpos = sumrpos + tmp * fact
3387  ELSE
3388  sumrneg = sumrneg - tmp * fact
3389  END IF
3390 *
3391  tmp = aimag( x( ix ) ) * aimag( y( iy ) )
3392  IF( tmp.GE.zero ) THEN
3393  sumrpos = sumrpos + tmp * fact
3394  ELSE
3395  sumrneg = sumrneg - tmp * fact
3396  END IF
3397 *
3398  tmp = - aimag( x( ix ) ) * real( y( iy ) )
3399  IF( tmp.GE.zero ) THEN
3400  sumipos = sumipos + tmp * fact
3401  ELSE
3402  sumineg = sumineg - tmp * fact
3403  END IF
3404 *
3405  tmp = real( x( ix ) ) * aimag( y( iy ) )
3406  IF( tmp.GE.zero ) THEN
3407  sumipos = sumipos + tmp * fact
3408  ELSE
3409  sumineg = sumineg - tmp * fact
3410  END IF
3411 *
3412  ix = ix + incx
3413  iy = iy + incy
3414 *
3415  10 CONTINUE
3416 *
3417  errbnd = addbnd * max( max( sumrpos, sumrneg ),
3418  $ max( sumipos, sumineg ) )
3419 *
3420  RETURN
3421 *
3422 * End of PCERRDOTC
3423 *
3424  END
3425  SUBROUTINE pcerrnrm2( ERRBND, N, USCLR, X, INCX, PREC )
3426 *
3427 * -- PBLAS test routine (version 2.0) --
3428 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3429 * and University of California, Berkeley.
3430 * April 1, 1998
3431 *
3432 * .. Scalar Arguments ..
3433  INTEGER INCX, N
3434  REAL ERRBND, PREC, USCLR
3435 * ..
3436 * .. Array Arguments ..
3437  COMPLEX X( * )
3438 * ..
3439 *
3440 * Purpose
3441 * =======
3442 *
3443 * PCERRNRM2 serially computes the 2-norm the vector X and returns a
3444 * scaled relative acceptable error bound on the result.
3445 *
3446 * Notes
3447 * =====
3448 *
3449 * If norm1 = SCLR and norm2 are two different computed results, and
3450 * norm1 being assumed to be correct, we require
3451 *
3452 * abs( norm1 - norm2 ) <= ERRBND = ERRFACT * abs( norm1 ),
3453 *
3454 * where ERRFACT is computed as the maximum of the positive and negative
3455 * partial sums multiplied by a constant proportional to the machine
3456 * precision.
3457 *
3458 * Arguments
3459 * =========
3460 *
3461 * ERRBND (global output) REAL
3462 * On exit, ERRBND specifies the scaled relative acceptable er-
3463 * ror bound.
3464 *
3465 * N (global input) INTEGER
3466 * On entry, N specifies the length of the vector operand.
3467 *
3468 * USCLR (global output) REAL
3469 * On exit, USCLR specifies the 2-norm of the vector X.
3470 *
3471 * X (global input) COMPLEX array
3472 * On entry, X is an array of dimension at least
3473 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
3474 * ted array X must contain the vector x.
3475 *
3476 * INCX (global input) INTEGER.
3477 * On entry, INCX specifies the increment for the elements of X.
3478 * INCX must not be zero.
3479 *
3480 * PREC (global input) REAL
3481 * On entry, PREC specifies the machine precision.
3482 *
3483 * -- Written on April 1, 1998 by
3484 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3485 *
3486 * =====================================================================
3487 *
3488 * .. Parameters ..
3489  REAL ONE, TWO, ZERO
3490  PARAMETER ( ONE = 1.0e+0, two = 2.0e+0,
3491  $ zero = 0.0e+0 )
3492 * ..
3493 * .. Local Scalars ..
3494  INTEGER IX
3495  REAL ABSXI, ADDBND, FACT, SCALE, SSQ, SUMSCA, SUMSSQ
3496 * ..
3497 * .. Intrinsic Functions ..
3498  INTRINSIC ABS, AIMAG, REAL
3499 * ..
3500 * .. Executable Statements ..
3501 *
3502  usclr = zero
3503  sumssq = one
3504  sumsca = zero
3505  addbnd = two * two * two * prec
3506  fact = one + two * ( ( one + prec )**3 - one )
3507 *
3508  scale = zero
3509  ssq = one
3510  DO 10 ix = 1, 1 + ( n - 1 )*incx, incx
3511  IF( real( x( ix ) ).NE.zero ) THEN
3512  absxi = abs( real( x( ix ) ) )
3513  IF( scale.LT.absxi )THEN
3514  sumssq = one + ( ssq*( scale/absxi )**2 ) * fact
3515  errbnd = addbnd * sumssq
3516  sumssq = sumssq + errbnd
3517  ssq = one + ssq*( scale/absxi )**2
3518  sumsca = absxi
3519  scale = absxi
3520  ELSE
3521  sumssq = ssq + ( ( absxi/scale )**2 ) * fact
3522  errbnd = addbnd * sumssq
3523  sumssq = sumssq + errbnd
3524  ssq = ssq + ( absxi/scale )**2
3525  END IF
3526  END IF
3527  IF( aimag( x( ix ) ).NE.zero ) THEN
3528  absxi = abs( aimag( x( ix ) ) )
3529  IF( scale.LT.absxi )THEN
3530  sumssq = one + ( ssq*( scale/absxi )**2 ) * fact
3531  errbnd = addbnd * sumssq
3532  sumssq = sumssq + errbnd
3533  ssq = one + ssq*( scale/absxi )**2
3534  sumsca = absxi
3535  scale = absxi
3536  ELSE
3537  sumssq = ssq + ( ( absxi/scale )**2 ) * fact
3538  errbnd = addbnd * sumssq
3539  sumssq = sumssq + errbnd
3540  ssq = ssq + ( absxi/scale )**2
3541  END IF
3542  END IF
3543  10 CONTINUE
3544 *
3545  usclr = scale * sqrt( ssq )
3546 *
3547 * Error on square root
3548 *
3549  errbnd = sqrt( sumssq ) * ( one + two * ( 1.00001e+0 * prec ) )
3550 *
3551  errbnd = ( sumsca * errbnd ) - usclr
3552 *
3553  RETURN
3554 *
3555 * End of PCERRNRM2
3556 *
3557  END
3558  SUBROUTINE pcerrasum( ERRBND, N, USCLR, X, INCX, PREC )
3559 *
3560 * -- PBLAS test routine (version 2.0) --
3561 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3562 * and University of California, Berkeley.
3563 * April 1, 1998
3564 *
3565 * .. Scalar Arguments ..
3566  INTEGER INCX, N
3567  REAL ERRBND, PREC, USCLR
3568 * ..
3569 * .. Array Arguments ..
3570  COMPLEX X( * )
3571 * ..
3572 *
3573 * Purpose
3574 * =======
3575 *
3576 * PCERRASUM serially computes the sum of absolute values of the vector
3577 * X and returns a scaled relative acceptable error bound on the result.
3578 *
3579 * Arguments
3580 * =========
3581 *
3582 * ERRBND (global output) REAL
3583 * On exit, ERRBND specifies a scaled relative acceptable error
3584 * bound. In this case the error bound is just the absolute sum
3585 * multiplied by a constant proportional to the machine preci-
3586 * sion.
3587 *
3588 * N (global input) INTEGER
3589 * On entry, N specifies the length of the vector operand.
3590 *
3591 * USCLR (global output) REAL
3592 * On exit, USCLR specifies the sum of absolute values of the
3593 * vector X.
3594 *
3595 * X (global input) COMPLEX array
3596 * On entry, X is an array of dimension at least
3597 * ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
3598 * ted array X must contain the vector x.
3599 *
3600 * INCX (global input) INTEGER.
3601 * On entry, INCX specifies the increment for the elements of X.
3602 * INCX must not be zero.
3603 *
3604 * PREC (global input) REAL
3605 * On entry, PREC specifies the machine precision.
3606 *
3607 * -- Written on April 1, 1998 by
3608 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3609 *
3610 * =====================================================================
3611 *
3612 * .. Parameters ..
3613  REAL TWO, ZERO
3614  PARAMETER ( TWO = 2.0e+0, zero = 0.0e+0 )
3615 * ..
3616 * .. Local Scalars ..
3617  INTEGER IX
3618  REAL ADDBND
3619 * ..
3620 * .. Intrinsic Functions ..
3621  INTRINSIC ABS, AIMAG, REAL
3622 * ..
3623 * .. Executable Statements ..
3624 *
3625  ix = 1
3626  usclr = zero
3627  addbnd = two * two * two * prec
3628 *
3629  DO 10 ix = 1, 1 + ( n - 1 )*incx, incx
3630  usclr = usclr + abs( real( x( ix ) ) ) +
3631  $ abs( aimag( x( ix ) ) )
3632  10 CONTINUE
3633 *
3634  errbnd = addbnd * usclr
3635 *
3636  RETURN
3637 *
3638 * End of PCERRASUM
3639 *
3640  END
3641  SUBROUTINE pcerrscal( ERRBND, PSCLR, X, PREC )
3642 *
3643 * -- PBLAS test routine (version 2.0) --
3644 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3645 * and University of California, Berkeley.
3646 * April 1, 1998
3647 *
3648 * .. Scalar Arguments ..
3649  REAL ERRBND, PREC
3650  COMPLEX PSCLR, X
3651 * ..
3652 *
3653 * Purpose
3654 * =======
3655 *
3656 * PCERRSCAL serially computes the product PSCLR * X and returns a sca-
3657 * led relative acceptable error bound on the result.
3658 *
3659 * Notes
3660 * =====
3661 *
3662 * If s1 = PSCLR*X and s2 are two different computed results, and s1 is
3663 * being assumed to be correct, we require
3664 *
3665 * abs( s1 - s2 ) <= ERRBND = ERRFACT * abs( s1 ),
3666 *
3667 * where ERRFACT is computed as two times the machine precision.
3668 *
3669 * Arguments
3670 * =========
3671 *
3672 * ERRBND (global output) REAL
3673 * On exit, ERRBND specifies the scaled relative acceptable er-
3674 * ror bound.
3675 *
3676 * PSCLR (global input) COMPLEX
3677 * On entry, PSCLR specifies the scale factor.
3678 *
3679 * X (global input/global output) COMPLEX
3680 * On entry, X specifies the scalar to be scaled. On exit, X is
3681 * the scaled entry.
3682 *
3683 * PREC (global input) REAL
3684 * On entry, PREC specifies the machine precision.
3685 *
3686 * -- Written on April 1, 1998 by
3687 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3688 *
3689 * =====================================================================
3690 *
3691 * .. Parameters ..
3692  REAL TWO
3693  PARAMETER ( TWO = 2.0e+0 )
3694 * ..
3695 * .. Intrinsic Functions ..
3696  INTRINSIC abs
3697 * ..
3698 * .. Executable Statements ..
3699 *
3700  x = psclr * x
3701 *
3702  errbnd = ( two * prec ) * abs( x )
3703 *
3704  RETURN
3705 *
3706 * End of PCERRSCAL
3707 *
3708  END
3709  SUBROUTINE pcserrscal( ERRBND, PUSCLR, X, PREC )
3710 *
3711 * -- PBLAS test routine (version 2.0) --
3712 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3713 * and University of California, Berkeley.
3714 * April 1, 1998
3715 *
3716 * .. Scalar Arguments ..
3717  REAL ERRBND, PREC, PUSCLR
3718  COMPLEX X
3719 * ..
3720 *
3721 * Purpose
3722 * =======
3723 *
3724 * PCSERRSCAL serially computes the product PUSCLR * X and returns a
3725 * scaled relative acceptable error bound on the result.
3726 *
3727 * Notes
3728 * =====
3729 *
3730 * If s1 = PUSCLR*X and s2 are two different computed results, and s1 is
3731 * being assumed to be correct, we require
3732 *
3733 * abs( s1 - s2 ) <= ERRBND = ERRFACT * abs( s1 ),
3734 *
3735 * where ERRFACT is computed as two times the machine precision.
3736 *
3737 * Arguments
3738 * =========
3739 *
3740 * ERRBND (global output) REAL
3741 * On exit, ERRBND specifies the scaled relative acceptable er-
3742 * ror bound.
3743 *
3744 * PUSCLR (global input) REAL
3745 * On entry, PUSCLR specifies the real scale factor.
3746 *
3747 * X (global input/global output) COMPLEX
3748 * On entry, X specifies the scalar to be scaled. On exit, X is
3749 * the scaled entry.
3750 *
3751 * PREC (global input) REAL
3752 * On entry, PREC specifies the machine precision.
3753 *
3754 * -- Written on April 1, 1998 by
3755 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3756 *
3757 * =====================================================================
3758 *
3759 * .. Parameters ..
3760  REAL TWO
3761  PARAMETER ( TWO = 2.0e+0 )
3762 * ..
3763 * .. Intrinsic Functions ..
3764  INTRINSIC abs, aimag, cmplx, real
3765 * ..
3766 * .. Executable Statements ..
3767 *
3768  x = cmplx( pusclr * real( x ), pusclr * aimag( x ) )
3769 *
3770  errbnd = ( two * prec ) * abs( x )
3771 *
3772  RETURN
3773 *
3774 * End of PCSERRSCAL
3775 *
3776  END
3777  SUBROUTINE pcerraxpy( ERRBND, PSCLR, X, Y, PREC )
3778 *
3779 * -- PBLAS test routine (version 2.0) --
3780 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3781 * and University of California, Berkeley.
3782 * April 1, 1998
3783 *
3784 * .. Scalar Arguments ..
3785  REAL ERRBND, PREC
3786  COMPLEX PSCLR, X, Y
3787 * ..
3788 *
3789 * Purpose
3790 * =======
3791 *
3792 * PCERRAXPY serially computes Y := Y + PSCLR * X and returns a scaled
3793 * relative acceptable error bound on the result.
3794 *
3795 * Arguments
3796 * =========
3797 *
3798 * ERRBND (global output) REAL
3799 * On exit, ERRBND specifies the scaled relative acceptable er-
3800 * ror bound.
3801 *
3802 * PSCLR (global input) COMPLEX
3803 * On entry, PSCLR specifies the scale factor.
3804 *
3805 * X (global input) COMPLEX
3806 * On entry, X specifies the scalar to be scaled.
3807 *
3808 * Y (global input/global output) COMPLEX
3809 * On entry, Y specifies the scalar to be added. On exit, Y con-
3810 * tains the resulting scalar.
3811 *
3812 * PREC (global input) REAL
3813 * On entry, PREC specifies the machine precision.
3814 *
3815 * -- Written on April 1, 1998 by
3816 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3817 *
3818 * =====================================================================
3819 *
3820 * .. Parameters ..
3821  REAL ONE, TWO, ZERO
3822  PARAMETER ( ONE = 1.0e+0, two = 2.0e+0,
3823  $ zero = 0.0e+0 )
3824 * ..
3825 * .. Local Scalars ..
3826  REAL ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
3827  $ SUMRPOS
3828  COMPLEX TMP
3829 * ..
3830 * .. Intrinsic Functions ..
3831  INTRINSIC AIMAG, MAX, REAL
3832 * ..
3833 * .. Executable Statements ..
3834 *
3835  sumipos = zero
3836  sumineg = zero
3837  sumrpos = zero
3838  sumrneg = zero
3839  fact = one + two * prec
3840  addbnd = two * two * two * prec
3841 *
3842  tmp = psclr * x
3843  IF( real( tmp ).GE.zero ) THEN
3844  sumrpos = sumrpos + real( tmp ) * fact
3845  ELSE
3846  sumrneg = sumrneg - real( tmp ) * fact
3847  END IF
3848  IF( aimag( tmp ).GE.zero ) THEN
3849  sumipos = sumipos + aimag( tmp ) * fact
3850  ELSE
3851  sumineg = sumineg - aimag( tmp ) * fact
3852  END IF
3853 *
3854  tmp = y
3855  IF( real( tmp ).GE.zero ) THEN
3856  sumrpos = sumrpos + real( tmp )
3857  ELSE
3858  sumrneg = sumrneg - real( tmp )
3859  END IF
3860  IF( aimag( tmp ).GE.zero ) THEN
3861  sumipos = sumipos + aimag( tmp )
3862  ELSE
3863  sumineg = sumineg - aimag( tmp )
3864  END IF
3865 *
3866  y = y + ( psclr * x )
3867 *
3868  errbnd = addbnd * max( max( sumrpos, sumrneg ),
3869  $ max( sumipos, sumineg ) )
3870 *
3871  RETURN
3872 *
3873 * End of PCERRAXPY
3874 *
3875  END
cmplx
float cmplx[2]
Definition: pblas.h:132
pslamch
real function pslamch(ICTXT, CMACH)
Definition: pcblastst.f:7455
pisinscope
logical function pisinscope(ICTXT, N, IX, JX, DESCX, INCX)
Definition: pcblas1tst.f:2078
max
#define max(A, B)
Definition: pcgemr.c:180
pcdimee
subroutine pcdimee(ICTXT, NOUT, SUBPTR, SCODE, SNAME)
Definition: pcblastst.f:455
pcblas1tstchke
subroutine pcblas1tstchke(LTEST, INOUT, NPROCS)
Definition: pcblas1tst.f:1495
pb_descset2
subroutine pb_descset2(DESC, M, N, IMB, INB, MB, NB, RSRC, CSRC, CTXT, LLD)
Definition: pblastst.f:3172
pcvprnt
subroutine pcvprnt(ICTXT, NOUT, N, X, INCX, IRPRNT, ICPRNT, CVECNM)
Definition: pcblastst.f:4067
pcchkarg1
subroutine pcchkarg1(ICTXT, NOUT, SNAME, N, ALPHA, IX, JX, DESCX, INCX, IY, JY, DESCY, INCY, INFO)
Definition: pcblas1tst.f:1778
pclagen
subroutine pclagen(INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA, DESCA, IASEED, A, LDA)
Definition: pcblastst.f:8491
pcblas1tstchk
subroutine pcblas1tstchk(ICTXT, NOUT, NROUT, N, PSCLR, PUSCLR, PISCLR, X, PX, IX, JX, DESCX, INCX, Y, PY, IY, JY, DESCY, INCY, INFO)
Definition: pcblas1tst.f:2255
pcchkvin
subroutine pcchkvin(ERRMAX, N, X, PX, IX, JX, DESCX, INCX, INFO)
Definition: pcblastst.f:2582
pcbla1tst
program pcbla1tst
Definition: pcblas1tst.f:12
pb_cchekpad
subroutine pb_cchekpad(ICTXT, MESS, M, N, A, LDA, IPRE, IPOST, CHKVAL)
Definition: pcblastst.f:9873
pcerrnrm2
subroutine pcerrnrm2(ERRBND, N, USCLR, X, INCX, PREC)
Definition: pcblas1tst.f:3426
pcerraxpy
subroutine pcerraxpy(ERRBND, PSCLR, X, Y, PREC)
Definition: pcblas1tst.f:3778
pcbla1tstinfo
subroutine pcbla1tstinfo(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: pcblas1tst.f:802
pb_cfillpad
subroutine pb_cfillpad(ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL)
Definition: pcblastst.f:9760
pcmprnt
subroutine pcmprnt(ICTXT, NOUT, M, N, A, LDA, IRPRNT, ICPRNT, CMATNM)
Definition: pcblastst.f:3955
pcerrasum
subroutine pcerrasum(ERRBND, N, USCLR, X, INCX, PREC)
Definition: pcblas1tst.f:3559
pcvecee
subroutine pcvecee(ICTXT, NOUT, SUBPTR, SCODE, SNAME)
Definition: pcblastst.f:936
pb_infog2l
subroutine pb_infog2l(I, J, DESC, NPROW, NPCOL, MYROW, MYCOL, II, JJ, PROW, PCOL)
Definition: pblastst.f:1673
pcchkvout
subroutine pcchkvout(N, X, PX, IX, JX, DESCX, INCX, INFO)
Definition: pcblastst.f:2876
pb_pclaprnt
subroutine pb_pclaprnt(M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT, CMATNM, NOUT, WORK)
Definition: pcblastst.f:9302
pcerrscal
subroutine pcerrscal(ERRBND, PSCLR, X, PREC)
Definition: pcblas1tst.f:3642
pcerrdotc
subroutine pcerrdotc(ERRBND, N, SCLR, X, INCX, Y, INCY, PREC)
Definition: pcblas1tst.f:3282
icopy
subroutine icopy(N, SX, INCX, SY, INCY)
Definition: pblastst.f:1525
pcerrdotu
subroutine pcerrdotu(ERRBND, N, SCLR, X, INCX, Y, INCY, PREC)
Definition: pcblas1tst.f:3138
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
pcserrscal
subroutine pcserrscal(ERRBND, PUSCLR, X, PREC)
Definition: pcblas1tst.f:3710
min
#define min(A, B)
Definition: pcgemr.c:181