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