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