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