OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pzblas3tst.f
Go to the documentation of this file.
1 BLOCK DATA
2 INTEGER NSUBS
3 parameter(nsubs = 11)
4 CHARACTER*7 SNAMES( NSUBS )
5 COMMON /snamec/snames
6 DATA snames/'PZGEMM ', 'PZSYMM ', 'PZHEMM ',
7 $ 'PZSYRK ', 'PZHERK ', 'PZSYR2K',
8 $ 'PZHER2K', 'PZTRMM ', 'PZTRSM ',
9 $ 'pzgeadd', 'pztradd'/
10 END BLOCK DATA
11
12 PROGRAM PZBLA3TST
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* PZBLA3TST is the main testing program for the Level 3 PBLAS 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*
26* from the following 64 lines:
27* 'Level 3 PBLAS, Testing input file'
28* 'Intel iPSC/860 hypercube, gamma model.'
29* 'PZBLAS3TST.SUMM' output file name (if any)
30* 6 device out
31* F logical flag, T to stop on failures
32* F logical flag, T to test error exits
33* 0 verbosity, 0 for pass/fail, 1-3 for matrix dump on errors
34* 10 the leading dimension gap
35* 16.0 threshold value of test ratio
36* 10 value of the logical computational blocksize NB
37* 1 number of process grids (ordered pairs of P & Q)
38* 2 2 1 4 2 3 8 values of P
39* 2 2 4 1 3 2 1 values of Q
40* (1.0D0, 0.0D0) value of ALPHA
41* (1.0D0, 0.0D0) value of BETA
42* 2 number of tests problems
43* 'N' 'U' values of DIAG
44* 'L' 'R' values of SIDE
45* 'N' 'T' values of TRANSA
46* 'N' 'T' values of TRANSB
47* 'U' 'L' values of UPLO
48* 3 4 values of M
49* 3 4 values of N
50* 3 4 values of K
51* 6 10 values of M_A
52* 6 10 values of N_A
53* 2 5 values of IMB_A
54* 2 5 values of INB_A
55* 2 5 values of MB_A
56* 2 5 values of NB_A
57* 0 1 values of RSRC_A
58* 0 0 values of CSRC_A
59* 1 1 values of IA
60* 1 1 values of JA
61* 6 10 values of M_B
62* 6 10 values of N_B
63* 2 5 values of IMB_B
64* 2 5 values of INB_B
65* 2 5 values of MB_B
66* 2 5 values of NB_B
67* 0 1 values of RSRC_B
68* 0 0 values of CSRC_B
69* 1 1 values of IB
70* 1 1 values of JB
71* 6 10 values of M_C
72* 6 10 values of N_C
73* 2 5 values of IMB_C
74* 2 5 values of INB_C
75* 2 5 values of MB_C
76* 2 5 values of NB_C
77* 0 1 values of RSRC_C
78* 0 0 values of CSRC_C
79* 1 1 values of IC
80* 1 1 values of JC
81* PZGEMM T put F for no test in the same column
82* PZSYMM T put F for no test in the same column
83* PZHEMM T put F for no test in the same column
84* PZSYRK T put F for no test in the same column
85* PZHERK T put F for no test in the same column
86* PZSYR2K T put F for no test in the same column
87* PZHER2K T put F for no test in the same column
88* PZTRMM T put F for no test in the same column
89* PZTRSM T put F for no test in the same column
90* PZGEADD T put F for no test in the same column
91* PZTRADD T put F for no test in the same column
92*
93* Internal Parameters
94* ===================
95*
96* TOTMEM INTEGER
97* TOTMEM is a machine-specific parameter indicating the maxi-
98* mum amount of available memory per process in bytes. The
99* user should customize TOTMEM to his platform. Remember to
100* leave room in memory for the operating system, the BLACS
101* buffer, etc. For example, on a system with 8 MB of memory
102* per process (e.g., one processor on an Intel iPSC/860), the
103* parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS,
104* code, BLACS buffer, etc). However, for PVM, we usually set
105* TOTMEM = 2000000. Some experimenting with the maximum value
106* of TOTMEM may be required. By default, TOTMEM is 2000000.
107*
108* DBLESZ INTEGER
109* ZPLXSZ INTEGER
110* DBLESZ and ZPLXSZ indicate the length in bytes on the given
111* platform for a double precision real and a double precision
112* complex. By default, DBLESZ is set to eight and ZPLXSZ is set
113* to sixteen.
114*
115* MEM COMPLEX*16 array
116* MEM is an array of dimension TOTMEM / ZPLXSZ.
117* All arrays used by SCALAPACK routines are allocated from this
118* array MEM and referenced by pointers. The integer IPA, for
119* example, is a pointer to the starting element of MEM for the
120* matrix A.
121*
122* -- Written on April 1, 1998 by
123* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
124*
125* =====================================================================
126*
127* .. Parameters ..
128 INTEGER MAXTESTS, MAXGRIDS, GAPMUL, ZPLXSZ, TOTMEM,
129 $ MEMSIZ, NSUBS, DBLESZ
130 COMPLEX*16 ONE, PADVAL, ZERO, ROGUE
131 PARAMETER ( MAXTESTS = 20, MAXGRIDS = 20, GAPMUL = 10,
132 $ ZPLXSZ = 16, TOTMEM = 2000000,
133 $ MEMSIZ = TOTMEM / ZPLXSZ, DBLESZ = 8,
134 $ PADVAL = ( -9923.0D+0, -9923.0D+0 ),
135 $ ZERO = ( 0.0D+0, 0.0D+0 ),
136 $ ROGUE = ( -1.0D+10, 1.0D+10 ),
137 $ ONE = ( 1.0D+0, 0.0D+0 ), NSUBS = 11 )
138 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
139 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
140 $ RSRC_
141 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
142 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
143 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
144 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
145* ..
146* .. Local Scalars ..
147 LOGICAL ERRFLG, SOF, TEE
148 CHARACTER*1 ADIAGDO, AFORM, CFORM, DIAG, SIDE, TRANSA,
149 $ TRANSB, UPLO
150 INTEGER CSRCA, CSRCB, CSRCC, I, IA, IAM, IASEED, IB,
151 $ IBSEED, IC, ICSEED, ICTXT, IGAP, IMBA, IMBB,
152 $ IMBC, IMIDA, IMIDB, IMIDC, INBA, INBB, INBC,
153 $ IPA, IPB, IPC, IPG, IPMATA, IPMATB, IPMATC,
154 $ IPOSTA, IPOSTB, IPOSTC, IPREA, IPREB, IPREC,
155 $ IPW, IVERB, J, JA, JB, JC, K, L, LDA, LDB, LDC,
156 $ M, MA, MB, MBA, MBB, MBC, MC, MEMREQD, MPA,
157 $ MPB, MPC, MYCOL, MYROW, N, NA, NB, NBA, NBB,
158 $ NBC, NC, NCOLA, NCOLB, NCOLC, NGRIDS, NOUT,
159 $ NPCOL, NPROCS, NPROW, NQA, NQB, NQC, NROWA,
160 $ NROWB, NROWC, NTESTS, OFFDA, OFFDC, RSRCA,
161 $ RSRCB, RSRCC, TSKIP, TSTCNT
162 REAL THRESH
163 COMPLEX*16 ALPHA, BETA, SCALE
164* ..
165* .. Local Arrays ..
166 LOGICAL BCHECK( NSUBS ), CCHECK( NSUBS ),
167 $ LTEST( NSUBS )
168 CHARACTER*1 DIAGVAL( MAXTESTS ), SIDEVAL( MAXTESTS ),
169 $ TRNAVAL( MAXTESTS ), TRNBVAL( MAXTESTS ),
170 $ UPLOVAL( MAXTESTS )
171 CHARACTER*80 OUTFILE
172 INTEGER CSCAVAL( MAXTESTS ), CSCBVAL( MAXTESTS ),
173 $ CSCCVAL( MAXTESTS ), DESCA( DLEN_ ),
174 $ DESCAR( DLEN_ ), DESCB( DLEN_ ),
175 $ DESCBR( DLEN_ ), DESCC( DLEN_ ),
176 $ DESCCR( DLEN_ ), IAVAL( MAXTESTS ),
177 $ IBVAL( MAXTESTS ), ICVAL( MAXTESTS ),
178 $ IERR( 6 ), IMBAVAL( MAXTESTS ),
179 $ IMBBVAL( MAXTESTS ), IMBCVAL( MAXTESTS ),
180 $ INBAVAL( MAXTESTS ), INBBVAL( MAXTESTS ),
181 $ INBCVAL( MAXTESTS ), JAVAL( MAXTESTS ),
182 $ JBVAL( MAXTESTS ), JCVAL( MAXTESTS )
183 INTEGER KFAIL( NSUBS ), KPASS( NSUBS ), KSKIP( NSUBS ),
184 $ KTESTS( NSUBS ), KVAL( MAXTESTS ),
185 $ MAVAL( MAXTESTS ), MBAVAL( MAXTESTS ),
186 $ MBBVAL( MAXTESTS ), MBCVAL( MAXTESTS ),
187 $ MBVAL( MAXTESTS ), MCVAL( MAXTESTS ),
188 $ MVAL( MAXTESTS ), NAVAL( MAXTESTS ),
189 $ NBAVAL( MAXTESTS ), NBBVAL( MAXTESTS ),
190 $ NBCVAL( MAXTESTS ), NBVAL( MAXTESTS ),
191 $ NCVAL( MAXTESTS ), NVAL( MAXTESTS ),
192 $ PVAL( MAXTESTS ), QVAL( MAXTESTS ),
193 $ RSCAVAL( MAXTESTS ), RSCBVAL( MAXTESTS ),
194 $ RSCCVAL( MAXTESTS )
195 COMPLEX*16 MEM( MEMSIZ )
196* ..
197* .. External Subroutines ..
198 EXTERNAL BLACS_EXIT, BLACS_GET, BLACS_GRIDEXIT,
199 $ BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO,
200 $ IGSUM2D, PB_DESCSET2, PB_PZLAPRNT, PB_ZCHEKPAD,
201 $ PB_ZFILLPAD, PB_ZLASCAL, PB_ZLASET, PMDESCCHK,
202 $ PMDIMCHK, PZBLA3TSTINFO, PZBLAS3TSTCHK,
203 $ PZBLAS3TSTCHKE, PZCHKARG3, PZCHKMOUT, PZGEADD,
204 $ PZGEMM, PZHEMM, PZHER2K, PZHERK, PZIPSET,
205 $ PZLAGEN, PZLASCAL, PZLASET, PZMPRNT, PZSYMM,
206 $ PZSYR2K, PZSYRK, PZTRADD, PZTRMM, PZTRSM
207* ..
208* .. External Functions ..
209 LOGICAL LSAME
210 INTEGER PB_FCEIL
211 EXTERNAL PB_FCEIL, LSAME
212* ..
213* .. Intrinsic Functions ..
214 INTRINSIC ABS, DBLE, DCMPLX, MAX, MOD, REAL
215* ..
216* .. Common Blocks ..
217 CHARACTER*7 SNAMES( NSUBS )
218 LOGICAL ABRTFLG
219 INTEGER INFO, NBLOG
220 COMMON /SNAMEC/SNAMES
221 COMMON /INFOC/INFO, NBLOG
222 COMMON /PBERRORC/NOUT, ABRTFLG
223* ..
224* .. Data Statements ..
225 DATA BCHECK/.TRUE., .TRUE., .TRUE., .FALSE.,
226 $ .FALSE., .TRUE., .TRUE., .TRUE., .TRUE.,
227 $ .FALSE., .FALSE./
228 DATA CCHECK/.TRUE., .TRUE., .TRUE., .TRUE., .TRUE.,
229 $ .TRUE., .TRUE., .FALSE., .FALSE., .TRUE.,
230 $ .TRUE./
231* ..
232* .. Executable Statements ..
233*
234* Initialization
235*
236* Set flag so that the PBLAS error handler won't abort on errors,
237* so that the tester will detect unsupported operations.
238*
239 ABRTFLG = .FALSE.
240*
241* So far no error, will become true as soon as one error is found.
242*
243 ERRFLG = .FALSE.
244*
245* Test counters
246*
247 TSKIP = 0
248 TSTCNT = 0
249*
250* Seeds for random matrix generations.
251*
252 IASEED = 100
253 IBSEED = 200
254 ICSEED = 300
255*
256* So far no tests have been performed.
257*
258 DO 10 I = 1, NSUBS
259 KPASS( I ) = 0
260 KSKIP( I ) = 0
261 KFAIL( I ) = 0
262 KTESTS( I ) = 0
263 10 CONTINUE
264*
265* Get starting information
266*
267 CALL BLACS_PINFO( IAM, NPROCS )
268 CALL PZBLA3TSTINFO( OUTFILE, NOUT, NTESTS, DIAGVAL, SIDEVAL,
269 $ TRNAVAL, TRNBVAL, UPLOVAL, MVAL, NVAL,
270 $ KVAL, MAVAL, NAVAL, IMBAVAL, MBAVAL,
271 $ INBAVAL, NBAVAL, RSCAVAL, CSCAVAL, IAVAL,
272 $ JAVAL, MBVAL, NBVAL, IMBBVAL, MBBVAL,
273 $ INBBVAL, NBBVAL, RSCBVAL, CSCBVAL, IBVAL,
274 $ JBVAL, MCVAL, NCVAL, IMBCVAL, MBCVAL,
275 $ INBCVAL, NBCVAL, RSCCVAL, CSCCVAL, ICVAL,
276 $ JCVAL, MAXTESTS, NGRIDS, PVAL, MAXGRIDS,
277 $ QVAL, MAXGRIDS, NBLOG, LTEST, SOF, TEE, IAM,
278 $ IGAP, IVERB, NPROCS, THRESH, ALPHA, BETA,
279 $ MEM )
280*
281.EQ. IF( IAM0 ) THEN
282 WRITE( NOUT, FMT = 9976 )
283 WRITE( NOUT, FMT = * )
284 END IF
285*
286* If TEE is set then Test Error Exits of routines.
287*
288 IF( TEE )
289 $ CALL PZBLAS3TSTCHKE( LTEST, NOUT, NPROCS )
290*
291* Loop over different process grids
292*
293 DO 60 I = 1, NGRIDS
294*
295 NPROW = PVAL( I )
296 NPCOL = QVAL( I )
297*
298* Make sure grid information is correct
299*
300 IERR( 1 ) = 0
301.LT. IF( NPROW1 ) THEN
302.EQ. IF( IAM0 )
303 $ WRITE( NOUT, FMT = 9999 ) 'grid size', 'nprow', NPROW
304 IERR( 1 ) = 1
305.LT. ELSE IF( NPCOL1 ) THEN
306.EQ. IF( IAM0 )
307 $ WRITE( NOUT, FMT = 9999 ) 'grid size', 'npcol', NPCOL
308 IERR( 1 ) = 1
309.GT. ELSE IF( NPROW*NPCOLNPROCS ) THEN
310.EQ. IF( IAM0 )
311 $ WRITE( NOUT, FMT = 9998 ) NPROW*NPCOL, NPROCS
312 IERR( 1 ) = 1
313 END IF
314*
315.GT. IF( IERR( 1 )0 ) THEN
316.EQ. IF( IAM0 )
317 $ WRITE( NOUT, FMT = 9997 ) 'grid'
318 TSKIP = TSKIP + 1
319 GO TO 60
320 END IF
321*
322* Define process grid
323*
324 CALL BLACS_GET( -1, 0, ICTXT )
325 CALL BLACS_GRIDINIT( ICTXT, 'row-major', NPROW, NPCOL )
326 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
327*
328* Go to bottom of process grid loop if this case doesn't use my
329* process
330*
331.GE..OR..GE. IF( MYROWNPROW MYCOLNPCOL )
332 $ GO TO 60
333*
334* Loop over number of tests
335*
336 DO 50 J = 1, NTESTS
337*
338* Get the test parameters
339*
340 DIAG = DIAGVAL( J )
341 SIDE = SIDEVAL( J )
342 TRANSA = TRNAVAL( J )
343 TRANSB = TRNBVAL( J )
344 UPLO = UPLOVAL( J )
345*
346 M = MVAL( J )
347 N = NVAL( J )
348 K = KVAL( J )
349*
350 MA = MAVAL( J )
351 NA = NAVAL( J )
352 IMBA = IMBAVAL( J )
353 MBA = MBAVAL( J )
354 INBA = INBAVAL( J )
355 NBA = NBAVAL( J )
356 RSRCA = RSCAVAL( J )
357 CSRCA = CSCAVAL( J )
358 IA = IAVAL( J )
359 JA = JAVAL( J )
360*
361 MB = MBVAL( J )
362 NB = NBVAL( J )
363 IMBB = IMBBVAL( J )
364 MBB = MBBVAL( J )
365 INBB = INBBVAL( J )
366 NBB = NBBVAL( J )
367 RSRCB = RSCBVAL( J )
368 CSRCB = CSCBVAL( J )
369 IB = IBVAL( J )
370 JB = JBVAL( J )
371*
372 MC = MCVAL( J )
373 NC = NCVAL( J )
374 IMBC = IMBCVAL( J )
375 MBC = MBCVAL( J )
376 INBC = INBCVAL( J )
377 NBC = NBCVAL( J )
378 RSRCC = RSCCVAL( J )
379 CSRCC = CSCCVAL( J )
380 IC = ICVAL( J )
381 JC = JCVAL( J )
382*
383.EQ. IF( IAM0 ) THEN
384*
385 TSTCNT = TSTCNT + 1
386*
387 WRITE( NOUT, FMT = * )
388 WRITE( NOUT, FMT = 9996 ) TSTCNT, NPROW, NPCOL
389 WRITE( NOUT, FMT = * )
390*
391 WRITE( NOUT, FMT = 9995 )
392 WRITE( NOUT, FMT = 9994 )
393 WRITE( NOUT, FMT = 9995 )
394 WRITE( NOUT, FMT = 9993 ) M, N, K, SIDE, UPLO, TRANSA,
395 $ TRANSB, DIAG
396*
397 WRITE( NOUT, FMT = 9995 )
398 WRITE( NOUT, FMT = 9992 )
399 WRITE( NOUT, FMT = 9995 )
400 WRITE( NOUT, FMT = 9991 ) IA, JA, MA, NA, IMBA, INBA,
401 $ MBA, NBA, RSRCA, CSRCA
402*
403 WRITE( NOUT, FMT = 9995 )
404 WRITE( NOUT, FMT = 9990 )
405 WRITE( NOUT, FMT = 9995 )
406 WRITE( NOUT, FMT = 9991 ) IB, JB, MB, NB, IMBB, INBB,
407 $ MBB, NBB, RSRCB, CSRCB
408*
409 WRITE( NOUT, FMT = 9995 )
410 WRITE( NOUT, FMT = 9989 )
411 WRITE( NOUT, FMT = 9995 )
412 WRITE( NOUT, FMT = 9991 ) IC, JC, MC, NC, IMBC, INBC,
413 $ MBC, NBC, RSRCC, CSRCC
414*
415 WRITE( NOUT, FMT = 9995 )
416*
417 END IF
418*
419* Check the validity of the input test parameters
420*
421.NOT. IF( LSAME( SIDE, 'l.AND.' )
422.NOT. $ LSAME( SIDE, 'r' ) ) THEN
423.EQ. IF( IAM0 )
424 $ WRITE( NOUT, FMT = 9997 ) 'side'
425 TSKIP = TSKIP + 1
426 GO TO 40
427 END IF
428*
429.NOT. IF( LSAME( UPLO, 'u.AND.' )
430.NOT. $ LSAME( UPLO, 'l' ) ) THEN
431.EQ. IF( IAM0 )
432 $ WRITE( NOUT, FMT = 9997 ) 'uplo'
433 TSKIP = TSKIP + 1
434 GO TO 40
435 END IF
436*
437.NOT. IF( LSAME( TRANSA, 'n.AND.' )
438.NOT. $ LSAME( TRANSA, 't.AND.' )
439.NOT. $ LSAME( TRANSA, 'c' ) ) THEN
440.EQ. IF( IAM0 )
441 $ WRITE( NOUT, FMT = 9997 ) 'transa'
442 TSKIP = TSKIP + 1
443 GO TO 40
444 END IF
445*
446.NOT. IF( LSAME( TRANSB, 'n.AND.' )
447.NOT. $ LSAME( TRANSB, 't.AND.' )
448.NOT. $ LSAME( TRANSB, 'c' ) ) THEN
449.EQ. IF( IAM0 )
450 $ WRITE( NOUT, FMT = 9997 ) 'transb'
451 TSKIP = TSKIP + 1
452 GO TO 40
453 END IF
454*
455.NOT. IF( LSAME( DIAG , 'u.AND.' )
456.NOT. $ LSAME( DIAG , 'n' ) )THEN
457.EQ. IF( IAM0 )
458 $ WRITE( NOUT, FMT = 9997 ) 'diag'
459 TSKIP = TSKIP + 1
460 GO TO 40
461 END IF
462*
463* Check and initialize the matrix descriptors
464*
465 CALL PMDESCCHK( ICTXT, NOUT, 'a', DESCA,
466 $ BLOCK_CYCLIC_2D_INB, MA, NA, IMBA, INBA,
467 $ MBA, NBA, RSRCA, CSRCA, MPA, NQA, IPREA,
468 $ IMIDA, IPOSTA, IGAP, GAPMUL, IERR( 1 ) )
469*
470 CALL PMDESCCHK( ICTXT, NOUT, 'b', DESCB,
471 $ BLOCK_CYCLIC_2D_INB, MB, NB, IMBB, INBB,
472 $ MBB, NBB, RSRCB, CSRCB, MPB, NQB, IPREB,
473 $ IMIDB, IPOSTB, IGAP, GAPMUL, IERR( 2 ) )
474*
475 CALL PMDESCCHK( ICTXT, NOUT, 'c', DESCC,
476 $ BLOCK_CYCLIC_2D_INB, MC, NC, IMBC, INBC,
477 $ MBC, NBC, RSRCC, CSRCC, MPC, NQC, IPREC,
478 $ IMIDC, IPOSTC, IGAP, GAPMUL, IERR( 3 ) )
479*
480.GT..OR..GT..OR. IF( IERR( 1 )0 IERR( 2 )0
481.GT. $ IERR( 3 )0 ) THEN
482 TSKIP = TSKIP + 1
483 GO TO 40
484 END IF
485*
486 LDA = MAX( 1, MA )
487 LDB = MAX( 1, MB )
488 LDC = MAX( 1, MC )
489*
490* Assign pointers into MEM for matrices corresponding to
491* the distributed matrices A, X and Y.
492*
493 IPA = IPREA + 1
494 IPB = IPA + DESCA( LLD_ )*NQA + IPOSTA + IPREB
495 IPC = IPB + DESCB( LLD_ )*NQB + IPOSTB + IPREC
496 IPMATA = IPC + DESCC( LLD_ )*NQC + IPOSTC
497 IPMATB = IPMATA + MA*NA
498 IPMATC = IPMATB + MB*NB
499 IPG = IPMATC + MAX( MB*NB, MC*NC )
500*
501* Check if sufficient memory.
502* Requirement = mem for local part of parallel matrices +
503* mem for whole matrices for comp. check +
504* mem for recving comp. check error vals.
505*
506 IPW = IPG + MAX( MAX( MAX( IMBA, MBA ),
507 $ MAX( IMBB, MBB ) ),
508 $ MAX( IMBC, MBC ) ) + MAX( M, MAX( N, K ) )
509 MEMREQD = IPW + PB_FCEIL( REAL( MAX( M, MAX( N, K ) ) ) *
510 $ REAL( DBLESZ ), REAL( ZPLXSZ ) ) - 1
511 IERR( 1 ) = 0
512.GT. IF( MEMREQDMEMSIZ ) THEN
513.EQ. IF( IAM0 )
514 $ WRITE( NOUT, FMT = 9987 ) MEMREQD*ZPLXSZ
515 IERR( 1 ) = 1
516 END IF
517*
518* Check all processes for an error
519*
520 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, IERR, 1, -1, 0 )
521*
522.GT. IF( IERR( 1 )0 ) THEN
523.EQ. IF( IAM0 )
524 $ WRITE( NOUT, FMT = 9988 )
525 TSKIP = TSKIP + 1
526 GO TO 40
527 END IF
528*
529* Loop over all PBLAS 3 routines
530*
531 DO 30 L = 1, NSUBS
532*
533* Continue only if this subroutine has to be tested.
534*
535.NOT. IF( LTEST( L ) )
536 $ GO TO 30
537*
538.EQ. IF( IAM0 ) THEN
539 WRITE( NOUT, FMT = * )
540 WRITE( NOUT, FMT = 9986 ) SNAMES( L )
541 END IF
542*
543* Define the size of the operands
544*
545.EQ. IF( L1 ) THEN
546*
547* PZGEMM
548*
549 NROWC = M
550 NCOLC = N
551 IF( LSAME( TRANSA, 'n' ) ) THEN
552 NROWA = M
553 NCOLA = K
554 ELSE
555 NROWA = K
556 NCOLA = M
557 END IF
558 IF( LSAME( TRANSB, 'n' ) ) THEN
559 NROWB = K
560 NCOLB = N
561 ELSE
562 NROWB = N
563 NCOLB = K
564 END IF
565*
566.EQ..OR..EQ. ELSE IF( L2 L3 ) THEN
567*
568* PZSYMM, PZHEMM
569*
570 NROWC = M
571 NCOLC = N
572 NROWB = M
573 NCOLB = N
574 IF( LSAME( SIDE, 'l' ) ) THEN
575 NROWA = M
576 NCOLA = M
577 ELSE
578 NROWA = N
579 NCOLA = N
580 END IF
581*
582.EQ..OR..EQ. ELSE IF( L4 L5 ) THEN
583*
584* PZSYRK, PZHERK
585*
586 NROWC = N
587 NCOLC = N
588 IF( LSAME( TRANSA, 'n' ) ) THEN
589 NROWA = N
590 NCOLA = K
591 ELSE
592 NROWA = K
593 NCOLA = N
594 END IF
595 NROWB = 0
596 NCOLB = 0
597*
598.EQ..OR..EQ. ELSE IF( L6 L7 ) THEN
599*
600* PZSYR2K, PZHER2K
601*
602 NROWC = N
603 NCOLC = N
604 IF( LSAME( TRANSA, 'n' ) ) THEN
605 NROWA = N
606 NCOLA = K
607 NROWB = N
608 NCOLB = K
609 ELSE
610 NROWA = K
611 NCOLA = N
612 NROWB = K
613 NCOLB = N
614 END IF
615*
616.EQ..OR..EQ. ELSE IF( L8 L9 ) THEN
617 NROWB = M
618 NCOLB = N
619 IF( LSAME( SIDE, 'l' ) ) THEN
620 NROWA = M
621 NCOLA = M
622 ELSE
623 NROWA = N
624 NCOLA = N
625 END IF
626 NROWC = 0
627 NCOLC = 0
628*
629.EQ..OR..EQ. ELSE IF( L10 L11 ) THEN
630*
631* PZGEADD, PZTRADD
632*
633 IF( LSAME( TRANSA, 'n' ) ) THEN
634 NROWA = M
635 NCOLA = N
636 ELSE
637 NROWA = N
638 NCOLA = M
639 END IF
640 NROWC = M
641 NCOLC = N
642 NROWB = 0
643 NCOLB = 0
644*
645 END IF
646*
647* Check the validity of the operand sizes
648*
649 CALL PMDIMCHK( ICTXT, NOUT, NROWA, NCOLA, 'a', IA, JA,
650 $ DESCA, IERR( 1 ) )
651 CALL PMDIMCHK( ICTXT, NOUT, NROWB, NCOLB, 'b', IB, JB,
652 $ DESCB, IERR( 2 ) )
653 CALL PMDIMCHK( ICTXT, NOUT, NROWC, NCOLC, 'c', IC, JC,
654 $ DESCC, IERR( 3 ) )
655*
656.NE..OR..NE..OR. IF( IERR( 1 )0 IERR( 2 )0
657.NE. $ IERR( 3 )0 ) THEN
658 KSKIP( L ) = KSKIP( L ) + 1
659 GO TO 30
660 END IF
661*
662* Check special values of TRANSA for symmetric and
663* hermitian rank-k and rank-2k updates.
664*
665.EQ..OR..EQ. IF( L4 L6 ) THEN
666.NOT. IF( LSAME( TRANSA, 'n.AND.' )
667.NOT. $ LSAME( TRANSA, 't' ) ) THEN
668.EQ. IF( IAM0 )
669 $ WRITE( NOUT, FMT = 9975 ) 'transa'
670 KSKIP( L ) = KSKIP( L ) + 1
671 GO TO 30
672 END IF
673.EQ..OR..EQ. ELSE IF( L5 L7 ) THEN
674.NOT. IF( LSAME( TRANSA, 'n.AND.' )
675.NOT. $ LSAME( TRANSA, 'c' ) ) THEN
676.EQ. IF( IAM0 )
677 $ WRITE( NOUT, FMT = 9975 ) 'transa'
678 KSKIP( L ) = KSKIP( L ) + 1
679 GO TO 30
680 END IF
681 END IF
682*
683* Generate distributed matrices A, B and C
684*
685.EQ. IF( L2 ) THEN
686*
687* PZSYMM
688*
689 AFORM = 's'
690 ADIAGDO = 'n'
691 OFFDA = IA - JA
692 CFORM = 'n'
693 OFFDC = 0
694*
695.EQ. ELSE IF( L3 ) THEN
696*
697* PZHEMM
698*
699 AFORM = 'h'
700 ADIAGDO = 'n'
701 OFFDA = IA - JA
702 CFORM = 'n'
703 OFFDC = 0
704*
705.EQ..OR..EQ. ELSE IF( L4 L6 ) THEN
706*
707* PZSYRK, PZSYR2K
708*
709 AFORM = 'n'
710 ADIAGDO = 'n'
711 OFFDA = 0
712 CFORM = 's'
713 OFFDC = IC - JC
714*
715.EQ..OR..EQ. ELSE IF( L5 L7 ) THEN
716*
717* PZHERK, PZHER2K
718*
719 AFORM = 'n'
720 ADIAGDO = 'n'
721 OFFDA = 0
722 CFORM = 'h'
723 OFFDC = IC - JC
724*
725.EQ..AND. ELSE IF( ( L9 )( LSAME( DIAG, 'n' ) ) ) THEN
726*
727* PZTRSM
728*
729 AFORM = 'n'
730 ADIAGDO = 'd'
731 OFFDA = IA - JA
732 CFORM = 'n'
733 OFFDC = 0
734*
735 ELSE
736*
737* Default values
738*
739 AFORM = 'n'
740 ADIAGDO = 'n'
741 OFFDA = 0
742 CFORM = 'n'
743 OFFDC = 0
744*
745 END IF
746*
747 CALL PZLAGEN( .FALSE., AFORM, ADIAGDO, OFFDA, MA, NA,
748 $ 1, 1, DESCA, IASEED, MEM( IPA ),
749 $ DESCA( LLD_ ) )
750*
751 IF( BCHECK( L ) )
752 $ CALL PZLAGEN( .FALSE., 'none', 'no diag', 0, MB, NB,
753 $ 1, 1, DESCB, IBSEED, MEM( IPB ),
754 $ DESCB( LLD_ ) )
755*
756 IF( CCHECK( L ) )
757 $ CALL PZLAGEN( .FALSE., CFORM, 'no diag', OFFDC, MC,
758 $ NC, 1, 1, DESCC, ICSEED, MEM( IPC ),
759 $ DESCC( LLD_ ) )
760*
761* Generate entire matrices on each process.
762*
763 CALL PB_DESCSET2( DESCAR, MA, NA, IMBA, INBA, MBA, NBA,
764 $ -1, -1, ICTXT, MAX( 1, MA ) )
765 CALL PZLAGEN( .FALSE., AFORM, ADIAGDO, OFFDA, MA, NA,
766 $ 1, 1, DESCAR, IASEED, MEM( IPMATA ),
767 $ DESCAR( LLD_ ) )
768*
769 IF( BCHECK( L ) ) THEN
770 CALL PB_DESCSET2( DESCBR, MB, NB, IMBB, INBB, MBB,
771 $ NBB, -1, -1, ICTXT, MAX( 1, MB ) )
772 CALL PZLAGEN( .FALSE., 'none', 'no diag', 0, MB, NB,
773 $ 1, 1, DESCBR, IBSEED, MEM( IPMATB ),
774 $ DESCBR( LLD_ ) )
775 END IF
776*
777 IF( CCHECK( L ) ) THEN
778*
779 CALL PB_DESCSET2( DESCCR, MC, NC, IMBC, INBC, MBC,
780 $ NBC, -1, -1, ICTXT, MAX( 1, MC ) )
781 CALL PZLAGEN( .FALSE., CFORM, 'no diag', OFFDC, MC,
782 $ NC, 1, 1, DESCCR, ICSEED, MEM( IPMATC ),
783 $ DESCCR( LLD_ ) )
784*
785 ELSE
786*
787* If C is not needed, generate a copy of B instead
788*
789 CALL PB_DESCSET2( DESCCR, MB, NB, IMBB, INBB, MBB,
790 $ NBB, -1, -1, ICTXT, MAX( 1, MB ) )
791 CALL PZLAGEN( .FALSE., 'none', 'no diag', 0, MB, NB,
792 $ 1, 1, DESCCR, IBSEED, MEM( IPMATC ),
793 $ DESCCR( LLD_ ) )
794*
795 END IF
796*
797* Zero non referenced part of the matrices A, B, C
798*
799.EQ..OR..EQ..AND. IF( ( ( L2 ) ( L3 ) )
800.GT. $ ( MAX( NROWA, NCOLA )1 ) ) THEN
801*
802* The distributed matrix A is symmetric or Hermitian
803*
804 IF( LSAME( UPLO, 'l' ) ) THEN
805*
806* Zeros the strict upper triangular part of A.
807*
808 CALL PZLASET( 'upper', NROWA-1, NCOLA-1, ROGUE,
809 $ ROGUE, MEM( IPA ), IA, JA+1, DESCA )
810*
811 ELSE IF( LSAME( UPLO, 'u' ) ) THEN
812*
813* Zeros the strict lower triangular part of A.
814*
815 CALL PZLASET( 'lower', NROWA-1, NCOLA-1, ROGUE,
816 $ ROGUE, MEM( IPA ), IA+1, JA, DESCA )
817*
818 END IF
819*
820.EQ..OR..EQ..OR..EQ..OR. ELSE IF( ( ( L4 )( L5 )( L6 )
821.EQ..AND. $ ( L7 ) )
822.GT. $ ( MAX( NROWC, NCOLC )1 ) ) THEN
823*
824* The distributed matrix C is symmetric or Hermitian
825*
826 IF( LSAME( UPLO, 'l' ) ) THEN
827*
828* Zeros the strict upper triangular part of C.
829*
830.GT. IF( MAX( NROWC, NCOLC )1 ) THEN
831 CALL PZLASET( 'upper', NROWC-1, NCOLC-1, ROGUE,
832 $ ROGUE, MEM( IPC ), IC, JC+1,
833 $ DESCC )
834 CALL PB_ZLASET( 'upper', NROWC-1, NCOLC-1, 0,
835 $ ROGUE, ROGUE,
836 $ MEM( IPMATC+IC-1+JC*LDC ), LDC )
837 END IF
838*
839 ELSE IF( LSAME( UPLO, 'u' ) ) THEN
840*
841* Zeros the strict lower triangular part of C.
842*
843.GT. IF( MAX( NROWC, NCOLC )1 ) THEN
844 CALL PZLASET( 'lower', NROWC-1, NCOLC-1, ROGUE,
845 $ ROGUE, MEM( IPC ), IC+1, JC,
846 $ DESCC )
847 CALL PB_ZLASET( 'lower', NROWC-1, NCOLC-1, 0,
848 $ ROGUE, ROGUE,
849 $ MEM( IPMATC+IC+(JC-1)*LDC ),
850 $ LDC )
851 END IF
852*
853 END IF
854*
855.EQ..OR..EQ. ELSE IF( L8 L9 ) THEN
856*
857 IF( LSAME( UPLO, 'l' ) ) THEN
858*
859* The distributed matrix A is lower triangular
860*
861 IF( LSAME( DIAG, 'n' ) ) THEN
862*
863.GT. IF( MAX( NROWA, NCOLA )1 ) THEN
864 CALL PZLASET( 'upper', NROWA-1, NCOLA-1,
865 $ ROGUE, ROGUE, MEM( IPA ), IA,
866 $ JA+1, DESCA )
867 CALL PB_ZLASET( 'upper', NROWA-1, NCOLA-1, 0,
868 $ ZERO, ZERO,
869 $ MEM( IPMATA+IA-1+JA*LDA ),
870 $ LDA )
871 END IF
872*
873 ELSE
874*
875 CALL PZLASET( 'upper', NROWA, NCOLA, ROGUE, ONE,
876 $ MEM( IPA ), IA, JA, DESCA )
877 CALL PB_ZLASET( 'upper', NROWA, NCOLA, 0, ZERO,
878 $ ONE,
879 $ MEM( IPMATA+IA-1+(JA-1)*LDA ),
880 $ LDA )
881.EQ..AND. IF( ( L9 )
882.GT. $ ( MAX( NROWA, NCOLA )1 ) ) THEN
883 SCALE = ONE /
884 $ DCMPLX( DBLE( MAX( NROWA, NCOLA ) ) )
885 CALL PZLASCAL( 'lower', NROWA-1, NCOLA-1,
886 $ SCALE, MEM( IPA ), IA+1, JA,
887 $ DESCA )
888 CALL PB_ZLASCAL( 'lower', NROWA-1, NCOLA-1,
889 $ 0, SCALE,
890 $ MEM( IPMATA+IA+(JA-1)*LDA ),
891 $ LDA )
892 END IF
893 END IF
894*
895 ELSE IF( LSAME( UPLO, 'u' ) ) THEN
896*
897* The distributed matrix A is upper triangular
898*
899 IF( LSAME( DIAG, 'n' ) ) THEN
900*
901.GT. IF( MAX( NROWA, NCOLA )1 ) THEN
902 CALL PZLASET( 'lower', NROWA-1, NCOLA-1,
903 $ ROGUE, ROGUE, MEM( IPA ), IA+1,
904 $ JA, DESCA )
905 CALL PB_ZLASET( 'lower', NROWA-1, NCOLA-1, 0,
906 $ ZERO, ZERO,
907 $ MEM( IPMATA+IA+(JA-1)*LDA ),
908 $ LDA )
909 END IF
910*
911 ELSE
912*
913 CALL PZLASET( 'lower', NROWA, NCOLA, ROGUE, ONE,
914 $ MEM( IPA ), IA, JA, DESCA )
915 CALL PB_ZLASET( 'lower', NROWA, NCOLA, 0, ZERO,
916 $ ONE,
917 $ MEM( IPMATA+IA-1+(JA-1)*LDA ),
918 $ LDA )
919.EQ..AND. IF( ( L9 )
920.GT. $ ( MAX( NROWA, NCOLA )1 ) ) THEN
921 SCALE = ONE /
922 $ DCMPLX( DBLE( MAX( NROWA, NCOLA ) ) )
923 CALL PZLASCAL( 'upper', NROWA-1, NCOLA-1,
924 $ SCALE, MEM( IPA ), IA, JA+1,
925 $ DESCA )
926 CALL PB_ZLASCAL( 'upper', NROWA-1, NCOLA-1,
927 $ 0, SCALE,
928 $ MEM( IPMATA+IA-1+JA*LDA ), LDA )
929 END IF
930*
931 END IF
932*
933 END IF
934*
935.EQ. ELSE IF( L11 ) THEN
936*
937 IF( LSAME( UPLO, 'l' ) ) THEN
938*
939* The distributed matrix C is lower triangular
940*
941.GT. IF( MAX( NROWC, NCOLC )1 ) THEN
942 CALL PZLASET( 'upper', NROWC-1, NCOLC-1,
943 $ ROGUE, ROGUE, MEM( IPC ), IC,
944 $ JC+1, DESCC )
945 CALL PB_ZLASET( 'upper', NROWC-1, NCOLC-1, 0,
946 $ ROGUE, ROGUE,
947 $ MEM( IPMATC+IC-1+JC*LDC ), LDC )
948 END IF
949*
950 ELSE IF( LSAME( UPLO, 'u' ) ) THEN
951*
952* The distributed matrix C is upper triangular
953*
954.GT. IF( MAX( NROWC, NCOLC )1 ) THEN
955 CALL PZLASET( 'lower', NROWC-1, NCOLC-1,
956 $ ROGUE, ROGUE, MEM( IPC ), IC+1,
957 $ JC, DESCC )
958 CALL PB_ZLASET( 'lower', NROWC-1, NCOLC-1, 0,
959 $ ROGUE, ROGUE,
960 $ MEM( IPMATC+IC+(JC-1)*LDC ),
961 $ LDC )
962 END IF
963*
964 END IF
965*
966 END IF
967*
968* Pad the guard zones of A, B and C
969*
970 CALL PB_ZFILLPAD( ICTXT, MPA, NQA, MEM( IPA-IPREA ),
971 $ DESCA( LLD_ ), IPREA, IPOSTA, PADVAL )
972*
973 IF( BCHECK( L ) ) THEN
974 CALL PB_ZFILLPAD( ICTXT, MPB, NQB, MEM( IPB-IPREB ),
975 $ DESCB( LLD_ ), IPREB, IPOSTB,
976 $ PADVAL )
977 END IF
978*
979 IF( CCHECK( L ) ) THEN
980 CALL PB_ZFILLPAD( ICTXT, MPC, NQC, MEM( IPC-IPREC ),
981 $ DESCC( LLD_ ), IPREC, IPOSTC,
982 $ PADVAL )
983 END IF
984*
985* Initialize the check for INPUT-only arguments.
986*
987 INFO = 0
988 CALL PZCHKARG3( ICTXT, NOUT, SNAMES( L ), SIDE, UPLO,
989 $ TRANSA, TRANSB, DIAG, M, N, K, ALPHA, IA,
990 $ JA, DESCA, IB, JB, DESCB, BETA, IC, JC,
991 $ DESCC, INFO )
992*
993* Print initial parallel data if IVERB >= 2.
994*
995.EQ. IF( IVERB2 ) THEN
996 CALL PB_PZLAPRNT( NROWA, NCOLA, MEM( IPA ), IA, JA,
997 $ DESCA, 0, 0,
998 $ 'parallel_initial_a', NOUT,
999 $ MEM( IPW ) )
1000.GE. ELSE IF( IVERB3 ) THEN
1001 CALL PB_PZLAPRNT( MA, NA, MEM( IPA ), 1, 1, DESCA,
1002 $ 0, 0, 'parallel_initial_a', NOUT,
1003 $ MEM( IPW ) )
1004 END IF
1005*
1006 IF( BCHECK( L ) ) THEN
1007.EQ. IF( IVERB2 ) THEN
1008 CALL PB_PZLAPRNT( NROWB, NCOLB, MEM( IPB ), IB, JB,
1009 $ DESCB, 0, 0,
1010 $ 'parallel_initial_b', NOUT,
1011 $ MEM( IPW ) )
1012.GE. ELSE IF( IVERB3 ) THEN
1013 CALL PB_PZLAPRNT( MB, NB, MEM( IPB ), 1, 1, DESCB,
1014 $ 0, 0, 'parallel_initial_b', NOUT,
1015 $ MEM( IPW ) )
1016 END IF
1017 END IF
1018*
1019 IF( CCHECK( L ) ) THEN
1020.EQ. IF( IVERB2 ) THEN
1021 CALL PB_PZLAPRNT( NROWC, NCOLC, MEM( IPC ), IC, JC,
1022 $ DESCC, 0, 0,
1023 $ 'parallel_initial_c', NOUT,
1024 $ MEM( IPW ) )
1025.GE. ELSE IF( IVERB3 ) THEN
1026 CALL PB_PZLAPRNT( MC, NC, MEM( IPC ), 1, 1, DESCC,
1027 $ 0, 0, 'parallel_initial_c', NOUT,
1028 $ MEM( IPW ) )
1029 END IF
1030 END IF
1031*
1032* Call the Level 3 PBLAS routine
1033*
1034 INFO = 0
1035.EQ. IF( L1 ) THEN
1036*
1037* Test PZGEMM
1038*
1039 CALL PZGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
1040 $ MEM( IPA ), IA, JA, DESCA, MEM( IPB ),
1041 $ IB, JB, DESCB, BETA, MEM( IPC ), IC, JC,
1042 $ DESCC )
1043*
1044.EQ. ELSE IF( L2 ) THEN
1045*
1046* Test PZSYMM
1047*
1048 CALL PZSYMM( SIDE, UPLO, M, N, ALPHA, MEM( IPA ), IA,
1049 $ JA, DESCA, MEM( IPB ), IB, JB, DESCB,
1050 $ BETA, MEM( IPC ), IC, JC, DESCC )
1051*
1052.EQ. ELSE IF( L3 ) THEN
1053*
1054* Test PZHEMM
1055*
1056 CALL PZIPSET( 'bignum', NROWA, MEM( IPA ), IA, JA,
1057 $ DESCA )
1058*
1059 CALL PZHEMM( SIDE, UPLO, M, N, ALPHA, MEM( IPA ), IA,
1060 $ JA, DESCA, MEM( IPB ), IB, JB, DESCB,
1061 $ BETA, MEM( IPC ), IC, JC, DESCC )
1062*
1063 CALL PZIPSET( 'zero', NROWA, MEM( IPA ), IA, JA,
1064 $ DESCA )
1065*
1066.EQ. ELSE IF( L4 ) THEN
1067*
1068* Test PZSYRK
1069*
1070 CALL PZSYRK( UPLO, TRANSA, N, K, ALPHA, MEM( IPA ),
1071 $ IA, JA, DESCA, BETA, MEM( IPC ), IC, JC,
1072 $ DESCC )
1073*
1074.EQ. ELSE IF( L5 ) THEN
1075*
1076* Test PZHERK
1077*
1078.NE..AND. IF( ( ( DCMPLX( DBLE( ALPHA ) )ZERO )
1079.NE..OR. $ ( K0 ) )
1080.NE. $ ( DCMPLX( DBLE( BETA ) )ONE ) )
1081 $ CALL PZIPSET( 'bignum', N, MEM( IPC ), IC, JC,
1082 $ DESCC )
1083*
1084 CALL PZHERK( UPLO, TRANSA, N, K, DBLE( ALPHA ),
1085 $ MEM( IPA ), IA, JA, DESCA, DBLE( BETA ),
1086 $ MEM( IPC ), IC, JC, DESCC )
1087*
1088.EQ. ELSE IF( L6 ) THEN
1089*
1090* Test PZSYR2K
1091*
1092 CALL PZSYR2K( UPLO, TRANSA, N, K, ALPHA, MEM( IPA ),
1093 $ IA, JA, DESCA, MEM( IPB ), IB, JB,
1094 $ DESCB, BETA, MEM( IPC ), IC, JC,
1095 $ DESCC )
1096*
1097.EQ. ELSE IF( L7 ) THEN
1098*
1099* Test PZHER2K
1100*
1101.NE..AND..NE..OR. IF( ( ( ALPHAZERO )( K0 ) )
1102.NE. $ ( DCMPLX( DBLE( BETA ) )ONE ) )
1103 $ CALL PZIPSET( 'bignum', N, MEM( IPC ), IC, JC,
1104 $ DESCC )
1105*
1106 CALL PZHER2K( UPLO, TRANSA, N, K, ALPHA, MEM( IPA ),
1107 $ IA, JA, DESCA, MEM( IPB ), IB, JB,
1108 $ DESCB, DBLE( BETA ), MEM( IPC ), IC, JC,
1109 $ DESCC )
1110*
1111.EQ. ELSE IF( L8 ) THEN
1112*
1113* Test PZTRMM
1114*
1115 CALL PZTRMM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1116 $ MEM( IPA ), IA, JA, DESCA, MEM( IPB ),
1117 $ IB, JB, DESCB )
1118*
1119.EQ. ELSE IF( L9 ) THEN
1120*
1121* Test PZTRSM
1122*
1123 CALL PZTRSM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1124 $ MEM( IPA ), IA, JA, DESCA, MEM( IPB ),
1125 $ IB, JB, DESCB )
1126*
1127*
1128.EQ. ELSE IF( L10 ) THEN
1129*
1130* Test PZGEADD
1131*
1132 CALL PZGEADD( TRANSA, M, N, ALPHA, MEM( IPA ), IA, JA,
1133 $ DESCA, BETA, MEM( IPC ), IC, JC, DESCC )
1134*
1135.EQ. ELSE IF( L11 ) THEN
1136*
1137* Test PZTRADD
1138*
1139 CALL PZTRADD( UPLO, TRANSA, M, N, ALPHA, MEM( IPA ),
1140 $ IA, JA, DESCA, BETA, MEM( IPC ), IC, JC,
1141 $ DESCC )
1142*
1143 END IF
1144*
1145* Check if the operation has been performed.
1146*
1147.NE. IF( INFO0 ) THEN
1148 KSKIP( L ) = KSKIP( L ) + 1
1149.EQ. IF( IAM0 )
1150 $ WRITE( NOUT, FMT = 9974 ) INFO
1151 GO TO 30
1152 END IF
1153*
1154* Check padding
1155*
1156 CALL PB_ZCHEKPAD( ICTXT, SNAMES( L ), MPA, NQA,
1157 $ MEM( IPA-IPREA ), DESCA( LLD_ ),
1158 $ IPREA, IPOSTA, PADVAL )
1159*
1160 IF( BCHECK( L ) ) THEN
1161 CALL PB_ZCHEKPAD( ICTXT, SNAMES( L ), MPB, NQB,
1162 $ MEM( IPB-IPREB ), DESCB( LLD_ ),
1163 $ IPREB, IPOSTB, PADVAL )
1164 END IF
1165*
1166 IF( CCHECK( L ) ) THEN
1167 CALL PB_ZCHEKPAD( ICTXT, SNAMES( L ), MPC, NQC,
1168 $ MEM( IPC-IPREC ), DESCC( LLD_ ),
1169 $ IPREC, IPOSTC, PADVAL )
1170 END IF
1171*
1172* Check the computations
1173*
1174 CALL PZBLAS3TSTCHK( ICTXT, NOUT, L, SIDE, UPLO, TRANSA,
1175 $ TRANSB, DIAG, M, N, K, ALPHA,
1176 $ MEM( IPMATA ), MEM( IPA ), IA, JA,
1177 $ DESCA, MEM( IPMATB ), MEM( IPB ),
1178 $ IB, JB, DESCB, BETA, MEM( IPMATC ),
1179 $ MEM( IPC ), IC, JC, DESCC, THRESH,
1180 $ ROGUE, MEM( IPG ), MEM( IPW ), INFO )
1181.EQ. IF( MOD( INFO, 2 )1 ) THEN
1182 IERR( 1 ) = 1
1183.EQ. ELSE IF( MOD( INFO / 2, 2 )1 ) THEN
1184 IERR( 2 ) = 1
1185.EQ. ELSE IF( MOD( INFO / 4, 2 )1 ) THEN
1186 IERR( 3 ) = 1
1187.NE. ELSE IF( INFO0 ) THEN
1188 IERR( 1 ) = 1
1189 IERR( 2 ) = 1
1190 IERR( 3 ) = 1
1191 END IF
1192*
1193* Check input-only scalar arguments
1194*
1195 INFO = 1
1196 CALL PZCHKARG3( ICTXT, NOUT, SNAMES( L ), SIDE, UPLO,
1197 $ TRANSA, TRANSB, DIAG, M, N, K, ALPHA, IA,
1198 $ JA, DESCA, IB, JB, DESCB, BETA, IC, JC,
1199 $ DESCC, INFO )
1200*
1201* Check input-only array arguments
1202*
1203 CALL PZCHKMOUT( NROWA, NCOLA, MEM( IPMATA ),
1204 $ MEM( IPA ), IA, JA, DESCA, IERR( 4 ) )
1205.NE. IF( IERR( 4 )0 ) THEN
1206.EQ. IF( IAM0 )
1207 $ WRITE( NOUT, FMT = 9983 ) 'parallel_a',
1208 $ SNAMES( L )
1209 END IF
1210*
1211 IF( BCHECK( L ) ) THEN
1212 CALL PZCHKMOUT( NROWB, NCOLB, MEM( IPMATB ),
1213 $ MEM( IPB ), IB, JB, DESCB, IERR( 5 ) )
1214.NE. IF( IERR( 5 )0 ) THEN
1215.EQ. IF( IAM0 )
1216 $ WRITE( NOUT, FMT = 9983 ) 'parallel_b',
1217 $ SNAMES( L )
1218 END IF
1219 END IF
1220*
1221 IF( CCHECK( L ) ) THEN
1222 CALL PZCHKMOUT( NROWC, NCOLC, MEM( IPMATC ),
1223 $ MEM( IPC ), IC, JC, DESCC, IERR( 6 ) )
1224.NE. IF( IERR( 6 )0 ) THEN
1225.EQ. IF( IAM0 )
1226 $ WRITE( NOUT, FMT = 9983 ) 'parallel_c',
1227 $ SNAMES( L )
1228 END IF
1229 END IF
1230*
1231* Only node 0 prints computational test result
1232*
1233.NE..OR..NE..OR. IF( INFO0 IERR( 1 )0
1234.NE..OR..NE..OR. $ IERR( 2 )0 IERR( 3 )0
1235.NE..OR..NE..OR. $ IERR( 4 )0 IERR( 5 )0
1236.NE. $ IERR( 6 )0 ) THEN
1237 KFAIL( L ) = KFAIL( L ) + 1
1238 ERRFLG = .TRUE.
1239.EQ. IF( IAM0 )
1240 $ WRITE( NOUT, FMT = 9985 ) SNAMES( L )
1241 ELSE
1242 KPASS( L ) = KPASS( L ) + 1
1243.EQ. IF( IAM0 )
1244 $ WRITE( NOUT, FMT = 9984 ) SNAMES( L )
1245 END IF
1246*
1247* Dump matrix if IVERB >= 1 and error.
1248*
1249.GE..AND. IF( IVERB1 ERRFLG ) THEN
1250.NE..OR..GE. IF( IERR( 4 )0 IVERB3 ) THEN
1251 CALL PZMPRNT( ICTXT, NOUT, MA, NA, MEM( IPMATA ),
1252 $ LDA, 0, 0, 'serial_a' )
1253 CALL PB_PZLAPRNT( MA, NA, MEM( IPA ), 1, 1, DESCA,
1254 $ 0, 0, 'parallel_a', NOUT,
1255 $ MEM( IPMATA ) )
1256.NE. ELSE IF( IERR( 1 )0 ) THEN
1257.GT..AND..GT. IF( ( NROWA0 )( NCOLA0 ) )
1258 $ CALL PZMPRNT( ICTXT, NOUT, NROWA, NCOLA,
1259 $ MEM( IPMATA+IA-1+(JA-1)*LDA ),
1260 $ LDA, 0, 0, 'serial_a' )
1261 CALL PB_PZLAPRNT( NROWA, NCOLA, MEM( IPA ), IA, JA,
1262 $ DESCA, 0, 0, 'parallel_a', NOUT,
1263 $ MEM( IPMATA ) )
1264 END IF
1265 IF( BCHECK( L ) ) THEN
1266.NE..OR..GE. IF( IERR( 5 )0 IVERB3 ) THEN
1267 CALL PZMPRNT( ICTXT, NOUT, MB, NB,
1268 $ MEM( IPMATB ), LDB, 0, 0,
1269 $ 'serial_b' )
1270 CALL PB_PZLAPRNT( MB, NB, MEM( IPB ), 1, 1,
1271 $ DESCB, 0, 0, 'parallel_b',
1272 $ NOUT, MEM( IPMATB ) )
1273.NE. ELSE IF( IERR( 2 )0 ) THEN
1274.GT..AND..GT. IF( ( NROWB0 )( NCOLB0 ) )
1275 $ CALL PZMPRNT( ICTXT, NOUT, NROWB, NCOLB,
1276 $ MEM( IPMATB+IB-1+(JB-1)*LDB ),
1277 $ LDB, 0, 0, 'serial_b' )
1278 CALL PB_PZLAPRNT( NROWB, NCOLB, MEM( IPB ), IB,
1279 $ JB, DESCB, 0, 0, 'parallel_b',
1280 $ NOUT, MEM( IPMATB ) )
1281 END IF
1282 END IF
1283 IF( CCHECK( L ) ) THEN
1284.NE..OR..GE. IF( IERR( 6 )0 IVERB3 ) THEN
1285 CALL PZMPRNT( ICTXT, NOUT, MC, NC,
1286 $ MEM( IPMATC ), LDC, 0, 0,
1287 $ 'serial_c' )
1288 CALL PB_PZLAPRNT( MC, NC, MEM( IPC ), 1, 1,
1289 $ DESCC, 0, 0, 'parallel_c',
1290 $ NOUT, MEM( IPMATC ) )
1291.NE. ELSE IF( IERR( 3 )0 ) THEN
1292.GT..AND..GT. IF( ( NROWB0 )( NCOLB0 ) )
1293 $ CALL PZMPRNT( ICTXT, NOUT, NROWC, NCOLC,
1294 $ MEM( IPMATC+IC-1+(JC-1)*LDC ),
1295 $ LDC, 0, 0, 'serial_c' )
1296 CALL PB_PZLAPRNT( NROWC, NCOLC, MEM( IPC ), IC,
1297 $ JC, DESCC, 0, 0, 'parallel_c',
1298 $ NOUT, MEM( IPMATC ) )
1299 END IF
1300 END IF
1301 END IF
1302*
1303* Leave if error and "Stop On Failure"
1304*
1305.AND. IF( SOFERRFLG )
1306 $ GO TO 70
1307*
1308 30 CONTINUE
1309*
1310.EQ. 40 IF( IAM0 ) THEN
1311 WRITE( NOUT, FMT = * )
1312 WRITE( NOUT, FMT = 9982 ) J
1313 END IF
1314*
1315 50 CONTINUE
1316*
1317 CALL BLACS_GRIDEXIT( ICTXT )
1318*
1319 60 CONTINUE
1320*
1321* Come here, if error and "Stop On Failure"
1322*
1323 70 CONTINUE
1324*
1325* Before printing out final stats, add TSKIP to all skips
1326*
1327 DO 80 I = 1, NSUBS
1328 IF( LTEST( I ) ) THEN
1329 KSKIP( I ) = KSKIP( I ) + TSKIP
1330 KTESTS( I ) = KSKIP( I ) + KFAIL( I ) + KPASS( I )
1331 END IF
1332 80 CONTINUE
1333*
1334* Print results
1335*
1336.EQ. IF( IAM0 ) THEN
1337 WRITE( NOUT, FMT = * )
1338 WRITE( NOUT, FMT = 9978 )
1339 WRITE( NOUT, FMT = * )
1340 WRITE( NOUT, FMT = 9980 )
1341 WRITE( NOUT, FMT = 9979 )
1342*
1343 DO 90 I = 1, NSUBS
1344 WRITE( NOUT, FMT = 9981 ) '|', SNAMES( I ), KTESTS( I ),
1345 $ KPASS( I ), KFAIL( I ), KSKIP( I )
1346 90 CONTINUE
1347 WRITE( NOUT, FMT = * )
1348 WRITE( NOUT, FMT = 9977 )
1349 WRITE( NOUT, FMT = * )
1350*
1351 END IF
1352*
1353 CALL BLACS_EXIT( 0 )
1354*
1355 9999 FORMAT( 'illegal ', A, ': ', A, ' = ', I10,
1356 $ ' should be at least 1' )
1357 9998 FORMAT( 'illegal grid: nprow*npcol = ', I4,
1358 $ '. it can be at most', I4 )
1359 9997 FORMAT( 'bad ', A, ' parameters: going on to next test case.' )
1360 9996 FORMAT( 2X, 'test number ', I4 , ' started on a ', I6, ' x ',
1361 $ I6, ' process grid.' )
1362 9995 FORMAT( 2X, ' ------------------------------------------------',
1363 $ '-------------------' )
1364 9994 FORMAT( 2X, ' m n k side uplo transa ',
1365 $ 'transb diag' )
1366 9993 FORMAT( 5X,I6,1X,I6,1X,I6,6X,A1,5X,A1,7X,A1,7X,A1,5X,A1 )
1367 9992 FORMAT( 2X, ' ia ja ma na imba inba',
1368 $ ' mba nba rsrca csrca' )
1369 9991 FORMAT( 5X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,
1370 $ 1X,I5,1X,I5 )
1371 9990 FORMAT( 2X, ' ib jb mb nb imbb inbb',
1372 $ ' mbb nbb rsrcb csrcb' )
1373 9989 FORMAT( 2X, ' ic jc mc nc imbc inbc',
1374 $ ' mbc nbc rsrcc csrcc' )
1375 9988 FORMAT( 'not enough memory for this test: going on to',
1376 $ ' next test case.' )
1377 9987 FORMAT( 'not enough memory. need: ', I12 )
1378 9986 FORMAT( 2X, ' tested subroutine: ', A )
1379 9985 FORMAT( 2X, ' ***** computational check: ', A, ' ',
1380 $ ' failed ',' *****' )
1381 9984 FORMAT( 2X, ' ***** computational check: ', A, ' ',
1382 $ ' passed ',' *****' )
1383 9983 FORMAT( 2X, ' ***** error ***** matrix operand ', A,
1384 $ ' modified by ', A, ' *****' )
1385 9982 FORMAT( 2X, 'test number ', I4, ' completed.' )
1386 9981 FORMAT( 2X,A1,2X,A7,8X,I4,6X,I4,5X,I4,4X,I4 )
1387 9980 FORMAT( 2X, ' SUBROUTINE total tests passed failed ',
1388 $ 'skipped' )
1389 9979 FORMAT( 2X, ' ---------- ----------- ------ ------ ',
1390 $ '-------' )
1391 9978 FORMAT( 2X, 'testing summary')
1392 9977 FORMAT( 2X, 'end of tests.' )
1393 9976 FORMAT( 2X, 'tests started.' )
1394 9975 FORMAT( 2X, ' ***** ', A, ' has an incorrect value: ',
1395 $ ' bypass *****' )
1396 9974 FORMAT( 2X, ' ***** operation not supported, error code: ',
1397 $ I5, ' *****' )
1398*
1399 STOP
1400*
1401* End of PZBLA3TST
1402*
1403 END
1404 SUBROUTINE PZBLA3TSTINFO( SUMMRY, NOUT, NMAT, DIAGVAL, SIDEVAL,
1405 $ TRNAVAL, TRNBVAL, UPLOVAL, MVAL,
1406 $ NVAL, KVAL, MAVAL, NAVAL, IMBAVAL,
1407 $ MBAVAL, INBAVAL, NBAVAL, RSCAVAL,
1408 $ CSCAVAL, IAVAL, JAVAL, MBVAL, NBVAL,
1409 $ IMBBVAL, MBBVAL, INBBVAL, NBBVAL,
1410 $ RSCBVAL, CSCBVAL, IBVAL, JBVAL,
1411 $ MCVAL, NCVAL, IMBCVAL, MBCVAL,
1412 $ INBCVAL, NBCVAL, RSCCVAL, CSCCVAL,
1413 $ ICVAL, JCVAL, LDVAL, NGRIDS, PVAL,
1414 $ LDPVAL, QVAL, LDQVAL, NBLOG, LTEST, SOF,
1415 $ TEE, IAM, IGAP, IVERB, NPROCS, THRESH,
1416 $ ALPHA, BETA, WORK )
1417*
1418* -- PBLAS test routine (version 2.0) --
1419* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1420* and University of California, Berkeley.
1421* April 1, 1998
1422*
1423* .. Scalar Arguments ..
1424 LOGICAL SOF, TEE
1425 INTEGER IAM, IGAP, IVERB, LDPVAL, LDQVAL, LDVAL, NBLOG,
1426 $ NGRIDS, NMAT, NOUT, NPROCS
1427 REAL THRESH
1428 COMPLEX*16 ALPHA, BETA
1429* ..
1430* .. Array Arguments ..
1431 CHARACTER*( * ) SUMMRY
1432 CHARACTER*1 DIAGVAL( LDVAL ), SIDEVAL( LDVAL ),
1433 $ TRNAVAL( LDVAL ), TRNBVAL( LDVAL ),
1434 $ UPLOVAL( LDVAL )
1435 LOGICAL LTEST( * )
1436 INTEGER CSCAVAL( LDVAL ), CSCBVAL( LDVAL ),
1437 $ CSCCVAL( LDVAL ), IAVAL( LDVAL ),
1438 $ IBVAL( LDVAL ), ICVAL( LDVAL ),
1439 $ IMBAVAL( LDVAL ), IMBBVAL( LDVAL ),
1440 $ IMBCVAL( LDVAL ), INBAVAL( LDVAL ),
1441 $ INBBVAL( LDVAL ), INBCVAL( LDVAL ),
1442 $ JAVAL( LDVAL ), JBVAL( LDVAL ), JCVAL( LDVAL ),
1443 $ KVAL( LDVAL ), MAVAL( LDVAL ), MBAVAL( LDVAL ),
1444 $ MBBVAL( LDVAL ), MBCVAL( LDVAL ),
1445 $ MBVAL( LDVAL ), MCVAL( LDVAL ), MVAL( LDVAL ),
1446 $ NAVAL( LDVAL ), NBAVAL( LDVAL ),
1447 $ NBBVAL( LDVAL ), NBCVAL( LDVAL ),
1448 $ NBVAL( LDVAL ), NCVAL( LDVAL ), NVAL( LDVAL ),
1449 $ PVAL( LDPVAL ), QVAL( LDQVAL ),
1450 $ RSCAVAL( LDVAL ), RSCBVAL( LDVAL ),
1451 $ RSCCVAL( LDVAL ), WORK( * )
1452* ..
1453*
1454* Purpose
1455* =======
1456*
1457* PZBLA3TSTINFO get the needed startup information for testing various
1458* Level 3 PBLAS routines, and transmits it to all processes.
1459*
1460* Notes
1461* =====
1462*
1463* For packing the information we assumed that the length in bytes of an
1464* integer is equal to the length in bytes of a real single precision.
1465*
1466* Arguments
1467* =========
1468*
1469* SUMMRY (global output) CHARACTER*(*)
1470* On exit, SUMMRY is the name of output (summary) file (if
1471* any). SUMMRY is only defined for process 0.
1472*
1473* NOUT (global output) INTEGER
1474* On exit, NOUT specifies the unit number for the output file.
1475* When NOUT is 6, output to screen, when NOUT is 0, output to
1476* stderr. NOUT is only defined for process 0.
1477*
1478* NMAT (global output) INTEGER
1479* On exit, NMAT specifies the number of different test cases.
1480*
1481* DIAGVAL (global output) CHARACTER array
1482* On entry, DIAGVAL is an array of dimension LDVAL. On exit,
1483* this array contains the values of DIAG to run the code with.
1484*
1485* SIDEVAL (global output) CHARACTER array
1486* On entry, SIDEVAL is an array of dimension LDVAL. On exit,
1487* this array contains the values of SIDE to run the code with.
1488*
1489* TRNAVAL (global output) CHARACTER array
1490* On entry, TRNAVAL is an array of dimension LDVAL. On exit,
1491* this array contains the values of TRANSA to run the code
1492* with.
1493*
1494* TRNBVAL (global output) CHARACTER array
1495* On entry, TRNBVAL is an array of dimension LDVAL. On exit,
1496* this array contains the values of TRANSB to run the code
1497* with.
1498*
1499* UPLOVAL (global output) CHARACTER array
1500* On entry, UPLOVAL is an array of dimension LDVAL. On exit,
1501* this array contains the values of UPLO to run the code with.
1502*
1503* MVAL (global output) INTEGER array
1504* On entry, MVAL is an array of dimension LDVAL. On exit, this
1505* array contains the values of M to run the code with.
1506*
1507* NVAL (global output) INTEGER array
1508* On entry, NVAL is an array of dimension LDVAL. On exit, this
1509* array contains the values of N to run the code with.
1510*
1511* KVAL (global output) INTEGER array
1512* On entry, KVAL is an array of dimension LDVAL. On exit, this
1513* array contains the values of K to run the code with.
1514*
1515* MAVAL (global output) INTEGER array
1516* On entry, MAVAL is an array of dimension LDVAL. On exit, this
1517* array contains the values of DESCA( M_ ) to run the code
1518* with.
1519*
1520* NAVAL (global output) INTEGER array
1521* On entry, NAVAL is an array of dimension LDVAL. On exit, this
1522* array contains the values of DESCA( N_ ) to run the code
1523* with.
1524*
1525* IMBAVAL (global output) INTEGER array
1526* On entry, IMBAVAL is an array of dimension LDVAL. On exit,
1527* this array contains the values of DESCA( IMB_ ) to run the
1528* code with.
1529*
1530* MBAVAL (global output) INTEGER array
1531* On entry, MBAVAL is an array of dimension LDVAL. On exit,
1532* this array contains the values of DESCA( MB_ ) to run the
1533* code with.
1534*
1535* INBAVAL (global output) INTEGER array
1536* On entry, INBAVAL is an array of dimension LDVAL. On exit,
1537* this array contains the values of DESCA( INB_ ) to run the
1538* code with.
1539*
1540* NBAVAL (global output) INTEGER array
1541* On entry, NBAVAL is an array of dimension LDVAL. On exit,
1542* this array contains the values of DESCA( NB_ ) to run the
1543* code with.
1544*
1545* RSCAVAL (global output) INTEGER array
1546* On entry, RSCAVAL is an array of dimension LDVAL. On exit,
1547* this array contains the values of DESCA( RSRC_ ) to run the
1548* code with.
1549*
1550* CSCAVAL (global output) INTEGER array
1551* On entry, CSCAVAL is an array of dimension LDVAL. On exit,
1552* this array contains the values of DESCA( CSRC_ ) to run the
1553* code with.
1554*
1555* IAVAL (global output) INTEGER array
1556* On entry, IAVAL is an array of dimension LDVAL. On exit, this
1557* array contains the values of IA to run the code with.
1558*
1559* JAVAL (global output) INTEGER array
1560* On entry, JAVAL is an array of dimension LDVAL. On exit, this
1561* array contains the values of JA to run the code with.
1562*
1563* MBVAL (global output) INTEGER array
1564* On entry, MBVAL is an array of dimension LDVAL. On exit, this
1565* array contains the values of DESCB( M_ ) to run the code
1566* with.
1567*
1568* NBVAL (global output) INTEGER array
1569* On entry, NBVAL is an array of dimension LDVAL. On exit, this
1570* array contains the values of DESCB( N_ ) to run the code
1571* with.
1572*
1573* IMBBVAL (global output) INTEGER array
1574* On entry, IMBBVAL is an array of dimension LDVAL. On exit,
1575* this array contains the values of DESCB( IMB_ ) to run the
1576* code with.
1577*
1578* MBBVAL (global output) INTEGER array
1579* On entry, MBBVAL is an array of dimension LDVAL. On exit,
1580* this array contains the values of DESCB( MB_ ) to run the
1581* code with.
1582*
1583* INBBVAL (global output) INTEGER array
1584* On entry, INBBVAL is an array of dimension LDVAL. On exit,
1585* this array contains the values of DESCB( INB_ ) to run the
1586* code with.
1587*
1588* NBBVAL (global output) INTEGER array
1589* On entry, NBBVAL is an array of dimension LDVAL. On exit,
1590* this array contains the values of DESCB( NB_ ) to run the
1591* code with.
1592*
1593* RSCBVAL (global output) INTEGER array
1594* On entry, RSCBVAL is an array of dimension LDVAL. On exit,
1595* this array contains the values of DESCB( RSRC_ ) to run the
1596* code with.
1597*
1598* CSCBVAL (global output) INTEGER array
1599* On entry, CSCBVAL is an array of dimension LDVAL. On exit,
1600* this array contains the values of DESCB( CSRC_ ) to run the
1601* code with.
1602*
1603* IBVAL (global output) INTEGER array
1604* On entry, IBVAL is an array of dimension LDVAL. On exit, this
1605* array contains the values of IB to run the code with.
1606*
1607* JBVAL (global output) INTEGER array
1608* On entry, JBVAL is an array of dimension LDVAL. On exit, this
1609* array contains the values of JB to run the code with.
1610*
1611* MCVAL (global output) INTEGER array
1612* On entry, MCVAL is an array of dimension LDVAL. On exit, this
1613* array contains the values of DESCC( M_ ) to run the code
1614* with.
1615*
1616* NCVAL (global output) INTEGER array
1617* On entry, NCVAL is an array of dimension LDVAL. On exit, this
1618* array contains the values of DESCC( N_ ) to run the code
1619* with.
1620*
1621* IMBCVAL (global output) INTEGER array
1622* On entry, IMBCVAL is an array of dimension LDVAL. On exit,
1623* this array contains the values of DESCC( IMB_ ) to run the
1624* code with.
1625*
1626* MBCVAL (global output) INTEGER array
1627* On entry, MBCVAL is an array of dimension LDVAL. On exit,
1628* this array contains the values of DESCC( MB_ ) to run the
1629* code with.
1630*
1631* INBCVAL (global output) INTEGER array
1632* On entry, INBCVAL is an array of dimension LDVAL. On exit,
1633* this array contains the values of DESCC( INB_ ) to run the
1634* code with.
1635*
1636* NBCVAL (global output) INTEGER array
1637* On entry, NBCVAL is an array of dimension LDVAL. On exit,
1638* this array contains the values of DESCC( NB_ ) to run the
1639* code with.
1640*
1641* RSCCVAL (global output) INTEGER array
1642* On entry, RSCCVAL is an array of dimension LDVAL. On exit,
1643* this array contains the values of DESCC( RSRC_ ) to run the
1644* code with.
1645*
1646* CSCCVAL (global output) INTEGER array
1647* On entry, CSCCVAL is an array of dimension LDVAL. On exit,
1648* this array contains the values of DESCC( CSRC_ ) to run the
1649* code with.
1650*
1651* ICVAL (global output) INTEGER array
1652* On entry, ICVAL is an array of dimension LDVAL. On exit, this
1653* array contains the values of IC to run the code with.
1654*
1655* JCVAL (global output) INTEGER array
1656* On entry, JCVAL is an array of dimension LDVAL. On exit, this
1657* array contains the values of JC to run the code with.
1658*
1659* LDVAL (global input) INTEGER
1660* On entry, LDVAL specifies the maximum number of different va-
1661* lues that can be used for DIAG, SIDE, TRANSA, TRANSB, UPLO,
1662* M, N, K, DESCA(:), IA, JA, DESCB(:), IB, JB, DESCC(:), IC,
1663* JC. This is also the maximum number of test cases.
1664*
1665* NGRIDS (global output) INTEGER
1666* On exit, NGRIDS specifies the number of different values that
1667* can be used for P and Q.
1668*
1669* PVAL (global output) INTEGER array
1670* On entry, PVAL is an array of dimension LDPVAL. On exit, this
1671* array contains the values of P to run the code with.
1672*
1673* LDPVAL (global input) INTEGER
1674* On entry, LDPVAL specifies the maximum number of different
1675* values that can be used for P.
1676*
1677* QVAL (global output) INTEGER array
1678* On entry, QVAL is an array of dimension LDQVAL. On exit, this
1679* array contains the values of Q to run the code with.
1680*
1681* LDQVAL (global input) INTEGER
1682* On entry, LDQVAL specifies the maximum number of different
1683* values that can be used for Q.
1684*
1685* NBLOG (global output) INTEGER
1686* On exit, NBLOG specifies the logical computational block size
1687* to run the tests with. NBLOG must be at least one.
1688*
1689* LTEST (global output) LOGICAL array
1690* On entry, LTEST is an array of dimension at least eleven. On
1691* exit, if LTEST( i ) is .TRUE., the i-th Level 3 PBLAS routine
1692* will be tested. See the input file for the ordering of the
1693* routines.
1694*
1695* SOF (global output) LOGICAL
1696* On exit, if SOF is .TRUE., the tester will stop on the first
1697* detected failure. Otherwise, it won't.
1698*
1699* TEE (global output) LOGICAL
1700* On exit, if TEE is .TRUE., the tester will perform the error
1701* exit tests. These tests won't be performed otherwise.
1702*
1703* IAM (local input) INTEGER
1704* On entry, IAM specifies the number of the process executing
1705* this routine.
1706*
1707* IGAP (global output) INTEGER
1708* On exit, IGAP specifies the user-specified gap used for pad-
1709* ding. IGAP must be at least zero.
1710*
1711* IVERB (global output) INTEGER
1712* On exit, IVERB specifies the output verbosity level: 0 for
1713* pass/fail, 1, 2 or 3 for matrix dump on errors.
1714*
1715* NPROCS (global input) INTEGER
1716* On entry, NPROCS specifies the total number of processes.
1717*
1718* THRESH (global output) REAL
1719* On exit, THRESH specifies the threshhold value for the test
1720* ratio.
1721*
1722* ALPHA (global output) COMPLEX*16
1723* On exit, ALPHA specifies the value of alpha to be used in all
1724* the test cases.
1725*
1726* BETA (global output) COMPLEX*16
1727* On exit, BETA specifies the value of beta to be used in all
1728* the test cases.
1729*
1730* WORK (local workspace) INTEGER array
1731* On entry, WORK is an array of dimension at least
1732* MAX( 3, 2*NGRIDS+38*NMAT+NSUBS+4 ) with NSUBS equal to 11.
1733* This array is used to pack all output arrays in order to send
1734* the information in one message.
1735*
1736* -- Written on April 1, 1998 by
1737* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1738*
1739* =====================================================================
1740*
1741* .. Parameters ..
1742 INTEGER NIN, NSUBS
1743 PARAMETER ( NIN = 11, NSUBS = 11 )
1744* ..
1745* .. Local Scalars ..
1746 LOGICAL LTESTT
1747 INTEGER I, ICTXT, J
1748 DOUBLE PRECISION EPS
1749* ..
1750* .. Local Arrays ..
1751 CHARACTER*7 SNAMET
1752 CHARACTER*79 USRINFO
1753* ..
1754* .. External Subroutines ..
1755 EXTERNAL BLACS_ABORT, BLACS_GET, BLACS_GRIDEXIT,
1756 $ BLACS_GRIDINIT, BLACS_SETUP, ICOPY, IGEBR2D,
1757 $ IGEBS2D, SGEBR2D, SGEBS2D, ZGEBR2D, ZGEBS2D
1758* ..
1759* .. External Functions ..
1760 DOUBLE PRECISION PDLAMCH
1761 EXTERNAL PDLAMCH
1762* ..
1763* .. Intrinsic Functions ..
1764 INTRINSIC CHAR, ICHAR, MAX, MIN
1765* ..
1766* .. Common Blocks ..
1767 CHARACTER*7 SNAMES( NSUBS )
1768 COMMON /SNAMEC/SNAMES
1769* ..
1770* .. Executable Statements ..
1771*
1772* Process 0 reads the input data, broadcasts to other processes and
1773* writes needed information to NOUT
1774*
1775.EQ. IF( IAM0 ) THEN
1776*
1777* Open file and skip data file header
1778*
1779 OPEN( NIN, FILE='pzblas3tst.dat', STATUS='old' )
1780 READ( NIN, FMT = * ) SUMMRY
1781 SUMMRY = ' '
1782*
1783* Read in user-supplied info about machine type, compiler, etc.
1784*
1785 READ( NIN, FMT = 9999 ) USRINFO
1786*
1787* Read name and unit number for summary output file
1788*
1789 READ( NIN, FMT = * ) SUMMRY
1790 READ( NIN, FMT = * ) NOUT
1791.NE..AND..NE. IF( NOUT0 NOUT6 )
1792 $ OPEN( NOUT, FILE = SUMMRY, STATUS = 'unknown' )
1793*
1794* Read and check the parameter values for the tests.
1795*
1796* Read the flag that indicates if Stop on Failure
1797*
1798 READ( NIN, FMT = * ) SOF
1799*
1800* Read the flag that indicates if Test Error Exits
1801*
1802 READ( NIN, FMT = * ) TEE
1803*
1804* Read the verbosity level
1805*
1806 READ( NIN, FMT = * ) IVERB
1807.LT..OR..GT. IF( IVERB0 IVERB3 )
1808 $ IVERB = 0
1809*
1810* Read the leading dimension gap
1811*
1812 READ( NIN, FMT = * ) IGAP
1813.LT. IF( IGAP0 )
1814 $ IGAP = 0
1815*
1816* Read the threshold value for test ratio
1817*
1818 READ( NIN, FMT = * ) THRESH
1819.LT. IF( THRESH0.0 )
1820 $ THRESH = 16.0
1821*
1822* Get logical computational block size
1823*
1824 READ( NIN, FMT = * ) NBLOG
1825.LT. IF( NBLOG1 )
1826 $ NBLOG = 32
1827*
1828* Get number of grids
1829*
1830 READ( NIN, FMT = * ) NGRIDS
1831.LT..OR..GT. IF( NGRIDS1 NGRIDSLDPVAL ) THEN
1832 WRITE( NOUT, FMT = 9998 ) 'grids', LDPVAL
1833 GO TO 120
1834.GT. ELSE IF( NGRIDSLDQVAL ) THEN
1835 WRITE( NOUT, FMT = 9998 ) 'grids', LDQVAL
1836 GO TO 120
1837 END IF
1838*
1839* Get values of P and Q
1840*
1841 READ( NIN, FMT = * ) ( PVAL( I ), I = 1, NGRIDS )
1842 READ( NIN, FMT = * ) ( QVAL( I ), I = 1, NGRIDS )
1843*
1844* Read ALPHA, BETA
1845*
1846 READ( NIN, FMT = * ) ALPHA
1847 READ( NIN, FMT = * ) BETA
1848*
1849* Read number of tests.
1850*
1851 READ( NIN, FMT = * ) NMAT
1852.LT..OR..GT. IF( NMAT1 NMATLDVAL ) THEN
1853 WRITE( NOUT, FMT = 9998 ) 'tests', LDVAL
1854 GO TO 120
1855 ENDIF
1856*
1857* Read in input data into arrays.
1858*
1859 READ( NIN, FMT = * ) ( DIAGVAL( I ), I = 1, NMAT )
1860 READ( NIN, FMT = * ) ( SIDEVAL( I ), I = 1, NMAT )
1861 READ( NIN, FMT = * ) ( TRNAVAL( I ), I = 1, NMAT )
1862 READ( NIN, FMT = * ) ( TRNBVAL( I ), I = 1, NMAT )
1863 READ( NIN, FMT = * ) ( UPLOVAL( I ), I = 1, NMAT )
1864 READ( NIN, FMT = * ) ( MVAL ( I ), I = 1, NMAT )
1865 READ( NIN, FMT = * ) ( NVAL ( I ), I = 1, NMAT )
1866 READ( NIN, FMT = * ) ( KVAL ( I ), I = 1, NMAT )
1867 READ( NIN, FMT = * ) ( MAVAL ( I ), I = 1, NMAT )
1868 READ( NIN, FMT = * ) ( NAVAL ( I ), I = 1, NMAT )
1869 READ( NIN, FMT = * ) ( IMBAVAL( I ), I = 1, NMAT )
1870 READ( NIN, FMT = * ) ( INBAVAL( I ), I = 1, NMAT )
1871 READ( NIN, FMT = * ) ( MBAVAL ( I ), I = 1, NMAT )
1872 READ( NIN, FMT = * ) ( NBAVAL ( I ), I = 1, NMAT )
1873 READ( NIN, FMT = * ) ( RSCAVAL( I ), I = 1, NMAT )
1874 READ( NIN, FMT = * ) ( CSCAVAL( I ), I = 1, NMAT )
1875 READ( NIN, FMT = * ) ( IAVAL ( I ), I = 1, NMAT )
1876 READ( NIN, FMT = * ) ( JAVAL ( I ), I = 1, NMAT )
1877 READ( NIN, FMT = * ) ( MBVAL ( I ), I = 1, NMAT )
1878 READ( NIN, FMT = * ) ( NBVAL ( I ), I = 1, NMAT )
1879 READ( NIN, FMT = * ) ( IMBBVAL( I ), I = 1, NMAT )
1880 READ( NIN, FMT = * ) ( INBBVAL( I ), I = 1, NMAT )
1881 READ( NIN, FMT = * ) ( MBBVAL ( I ), I = 1, NMAT )
1882 READ( NIN, FMT = * ) ( NBBVAL ( I ), I = 1, NMAT )
1883 READ( NIN, FMT = * ) ( RSCBVAL( I ), I = 1, NMAT )
1884 READ( NIN, FMT = * ) ( CSCBVAL( I ), I = 1, NMAT )
1885 READ( NIN, FMT = * ) ( IBVAL ( I ), I = 1, NMAT )
1886 READ( NIN, FMT = * ) ( JBVAL ( I ), I = 1, NMAT )
1887 READ( NIN, FMT = * ) ( MCVAL ( I ), I = 1, NMAT )
1888 READ( NIN, FMT = * ) ( NCVAL ( I ), I = 1, NMAT )
1889 READ( NIN, FMT = * ) ( IMBCVAL( I ), I = 1, NMAT )
1890 READ( NIN, FMT = * ) ( INBCVAL( I ), I = 1, NMAT )
1891 READ( NIN, FMT = * ) ( MBCVAL ( I ), I = 1, NMAT )
1892 READ( NIN, FMT = * ) ( NBCVAL ( I ), I = 1, NMAT )
1893 READ( NIN, FMT = * ) ( RSCCVAL( I ), I = 1, NMAT )
1894 READ( NIN, FMT = * ) ( CSCCVAL( I ), I = 1, NMAT )
1895 READ( NIN, FMT = * ) ( ICVAL ( I ), I = 1, NMAT )
1896 READ( NIN, FMT = * ) ( JCVAL ( I ), I = 1, NMAT )
1897*
1898* Read names of subroutines and flags which indicate
1899* whether they are to be tested.
1900*
1901 DO 10 I = 1, NSUBS
1902 LTEST( I ) = .FALSE.
1903 10 CONTINUE
1904 20 CONTINUE
1905 READ( NIN, FMT = 9996, END = 50 ) SNAMET, LTESTT
1906 DO 30 I = 1, NSUBS
1907.EQ. IF( SNAMETSNAMES( I ) )
1908 $ GO TO 40
1909 30 CONTINUE
1910*
1911 WRITE( NOUT, FMT = 9995 )SNAMET
1912 GO TO 120
1913*
1914 40 CONTINUE
1915 LTEST( I ) = LTESTT
1916 GO TO 20
1917*
1918 50 CONTINUE
1919*
1920* Close input file
1921*
1922 CLOSE ( NIN )
1923*
1924* For pvm only: if virtual machine not set up, allocate it and
1925* spawn the correct number of processes.
1926*
1927.LT. IF( NPROCS1 ) THEN
1928 NPROCS = 0
1929 DO 60 I = 1, NGRIDS
1930 NPROCS = MAX( NPROCS, PVAL( I )*QVAL( I ) )
1931 60 CONTINUE
1932 CALL BLACS_SETUP( IAM, NPROCS )
1933 END IF
1934*
1935* Temporarily define blacs grid to include all processes so
1936* information can be broadcast to all processes
1937*
1938 CALL BLACS_GET( -1, 0, ICTXT )
1939 CALL BLACS_GRIDINIT( ICTXT, 'row-major', 1, NPROCS )
1940*
1941* Compute machine epsilon
1942*
1943 EPS = PDLAMCH( ICTXT, 'eps' )
1944*
1945* Pack information arrays and broadcast
1946*
1947 CALL SGEBS2D( ICTXT, 'all', ' ', 1, 1, THRESH, 1 )
1948 CALL ZGEBS2D( ICTXT, 'all', ' ', 1, 1, ALPHA, 1 )
1949 CALL ZGEBS2D( ICTXT, 'all', ' ', 1, 1, BETA, 1 )
1950*
1951 WORK( 1 ) = NGRIDS
1952 WORK( 2 ) = NMAT
1953 WORK( 3 ) = NBLOG
1954 CALL IGEBS2D( ICTXT, 'all', ' ', 3, 1, WORK, 3 )
1955*
1956 I = 1
1957 IF( SOF ) THEN
1958 WORK( I ) = 1
1959 ELSE
1960 WORK( I ) = 0
1961 END IF
1962 I = I + 1
1963 IF( TEE ) THEN
1964 WORK( I ) = 1
1965 ELSE
1966 WORK( I ) = 0
1967 END IF
1968 I = I + 1
1969 WORK( I ) = IVERB
1970 I = I + 1
1971 WORK( I ) = IGAP
1972 I = I + 1
1973 DO 70 J = 1, NMAT
1974 WORK( I ) = ICHAR( DIAGVAL( J ) )
1975 WORK( I+1 ) = ICHAR( SIDEVAL( J ) )
1976 WORK( I+2 ) = ICHAR( TRNAVAL( J ) )
1977 WORK( I+3 ) = ICHAR( TRNBVAL( J ) )
1978 WORK( I+4 ) = ICHAR( UPLOVAL( J ) )
1979 I = I + 5
1980 70 CONTINUE
1981 CALL ICOPY( NGRIDS, PVAL, 1, WORK( I ), 1 )
1982 I = I + NGRIDS
1983 CALL ICOPY( NGRIDS, QVAL, 1, WORK( I ), 1 )
1984 I = I + NGRIDS
1985 CALL ICOPY( NMAT, MVAL, 1, WORK( I ), 1 )
1986 I = I + NMAT
1987 CALL ICOPY( NMAT, NVAL, 1, WORK( I ), 1 )
1988 I = I + NMAT
1989 CALL ICOPY( NMAT, KVAL, 1, WORK( I ), 1 )
1990 I = I + NMAT
1991 CALL ICOPY( NMAT, MAVAL, 1, WORK( I ), 1 )
1992 I = I + NMAT
1993 CALL ICOPY( NMAT, NAVAL, 1, WORK( I ), 1 )
1994 I = I + NMAT
1995 CALL ICOPY( NMAT, IMBAVAL, 1, WORK( I ), 1 )
1996 I = I + NMAT
1997 CALL ICOPY( NMAT, INBAVAL, 1, WORK( I ), 1 )
1998 I = I + NMAT
1999 CALL ICOPY( NMAT, MBAVAL, 1, WORK( I ), 1 )
2000 I = I + NMAT
2001 CALL ICOPY( NMAT, NBAVAL, 1, WORK( I ), 1 )
2002 I = I + NMAT
2003 CALL ICOPY( NMAT, RSCAVAL, 1, WORK( I ), 1 )
2004 I = I + NMAT
2005 CALL ICOPY( NMAT, CSCAVAL, 1, WORK( I ), 1 )
2006 I = I + NMAT
2007 CALL ICOPY( NMAT, IAVAL, 1, WORK( I ), 1 )
2008 I = I + NMAT
2009 CALL ICOPY( NMAT, JAVAL, 1, WORK( I ), 1 )
2010 I = I + NMAT
2011 CALL ICOPY( NMAT, MBVAL, 1, WORK( I ), 1 )
2012 I = I + NMAT
2013 CALL ICOPY( NMAT, NBVAL, 1, WORK( I ), 1 )
2014 I = I + NMAT
2015 CALL ICOPY( NMAT, IMBBVAL, 1, WORK( I ), 1 )
2016 I = I + NMAT
2017 CALL ICOPY( NMAT, INBBVAL, 1, WORK( I ), 1 )
2018 I = I + NMAT
2019 CALL ICOPY( NMAT, MBBVAL, 1, WORK( I ), 1 )
2020 I = I + NMAT
2021 CALL ICOPY( NMAT, NBBVAL, 1, WORK( I ), 1 )
2022 I = I + NMAT
2023 CALL ICOPY( NMAT, RSCBVAL, 1, WORK( I ), 1 )
2024 I = I + NMAT
2025 CALL ICOPY( NMAT, CSCBVAL, 1, WORK( I ), 1 )
2026 I = I + NMAT
2027 CALL ICOPY( NMAT, IBVAL, 1, WORK( I ), 1 )
2028 I = I + NMAT
2029 CALL ICOPY( NMAT, JBVAL, 1, WORK( I ), 1 )
2030 I = I + NMAT
2031 CALL ICOPY( NMAT, MCVAL, 1, WORK( I ), 1 )
2032 I = I + NMAT
2033 CALL ICOPY( NMAT, NCVAL, 1, WORK( I ), 1 )
2034 I = I + NMAT
2035 CALL ICOPY( NMAT, IMBCVAL, 1, WORK( I ), 1 )
2036 I = I + NMAT
2037 CALL ICOPY( NMAT, INBCVAL, 1, WORK( I ), 1 )
2038 I = I + NMAT
2039 CALL ICOPY( NMAT, MBCVAL, 1, WORK( I ), 1 )
2040 I = I + NMAT
2041 CALL ICOPY( NMAT, NBCVAL, 1, WORK( I ), 1 )
2042 I = I + NMAT
2043 CALL ICOPY( NMAT, RSCCVAL, 1, WORK( I ), 1 )
2044 I = I + NMAT
2045 CALL ICOPY( NMAT, CSCCVAL, 1, WORK( I ), 1 )
2046 I = I + NMAT
2047 CALL ICOPY( NMAT, ICVAL, 1, WORK( I ), 1 )
2048 I = I + NMAT
2049 CALL ICOPY( NMAT, JCVAL, 1, WORK( I ), 1 )
2050 I = I + NMAT
2051*
2052 DO 80 J = 1, NSUBS
2053 IF( LTEST( J ) ) THEN
2054 WORK( I ) = 1
2055 ELSE
2056 WORK( I ) = 0
2057 END IF
2058 I = I + 1
2059 80 CONTINUE
2060 I = I - 1
2061 CALL IGEBS2D( ICTXT, 'all', ' ', I, 1, WORK, I )
2062*
2063* regurgitate input
2064*
2065 WRITE( NOUT, FMT = 9999 ) 'level 3 pblas testing program.'
2066 WRITE( NOUT, FMT = 9999 ) USRINFO
2067 WRITE( NOUT, FMT = * )
2068 WRITE( NOUT, FMT = 9999 )
2069 $ 'tests of the complex double precision '//
2070 $ 'level 3 pblas'
2071 WRITE( NOUT, FMT = * )
2072 WRITE( NOUT, FMT = 9993 ) NMAT
2073 WRITE( NOUT, FMT = 9979 ) NBLOG
2074 WRITE( NOUT, FMT = 9992 ) NGRIDS
2075 WRITE( NOUT, FMT = 9990 )
2076 $ 'p', ( PVAL(I), I = 1, MIN(NGRIDS, 5) )
2077.GT. IF( NGRIDS5 )
2078 $ WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 6,
2079 $ MIN( 10, NGRIDS ) )
2080.GT. IF( NGRIDS10 )
2081 $ WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 11,
2082 $ MIN( 15, NGRIDS ) )
2083.GT. IF( NGRIDS15 )
2084 $ WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 16, NGRIDS )
2085 WRITE( NOUT, FMT = 9990 )
2086 $ 'q', ( QVAL(I), I = 1, MIN(NGRIDS, 5) )
2087.GT. IF( NGRIDS5 )
2088 $ WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 6,
2089 $ MIN( 10, NGRIDS ) )
2090.GT. IF( NGRIDS10 )
2091 $ WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 11,
2092 $ MIN( 15, NGRIDS ) )
2093.GT. IF( NGRIDS15 )
2094 $ WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 16, NGRIDS )
2095 WRITE( NOUT, FMT = 9988 ) SOF
2096 WRITE( NOUT, FMT = 9987 ) TEE
2097 WRITE( NOUT, FMT = 9983 ) IGAP
2098 WRITE( NOUT, FMT = 9986 ) IVERB
2099 WRITE( NOUT, FMT = 9980 ) THRESH
2100 WRITE( NOUT, FMT = 9982 ) ALPHA
2101 WRITE( NOUT, FMT = 9981 ) BETA
2102 IF( LTEST( 1 ) ) THEN
2103 WRITE( NOUT, FMT = 9985 ) SNAMES( 1 ), ' ... yes'
2104 ELSE
2105 WRITE( NOUT, FMT = 9985 ) SNAMES( 1 ), ' ... no '
2106 END IF
2107 DO 90 I = 2, NSUBS
2108 IF( LTEST( I ) ) THEN
2109 WRITE( NOUT, FMT = 9984 ) SNAMES( I ), ' ... yes'
2110 ELSE
2111 WRITE( NOUT, FMT = 9984 ) SNAMES( I ), ' ... no '
2112 END IF
2113 90 CONTINUE
2114 WRITE( NOUT, FMT = 9994 ) EPS
2115 WRITE( NOUT, FMT = * )
2116*
2117 ELSE
2118*
2119* If in pvm, must participate setting up virtual machine
2120*
2121.LT. IF( NPROCS1 )
2122 $ CALL BLACS_SETUP( IAM, NPROCS )
2123*
2124* Temporarily define blacs grid to include all processes so
2125* information can be broadcast to all processes
2126*
2127 CALL BLACS_GET( -1, 0, ICTXT )
2128 CALL BLACS_GRIDINIT( ICTXT, 'row-major', 1, NPROCS )
2129*
2130* Compute machine epsilon
2131*
2132 EPS = PDLAMCH( ICTXT, 'eps' )
2133*
2134 CALL SGEBR2D( ICTXT, 'all', ' ', 1, 1, THRESH, 1, 0, 0 )
2135 CALL ZGEBR2D( ICTXT, 'all', ' ', 1, 1, ALPHA, 1, 0, 0 )
2136 CALL ZGEBR2D( ICTXT, 'all', ' ', 1, 1, BETA, 1, 0, 0 )
2137*
2138 CALL IGEBR2D( ICTXT, 'all', ' ', 3, 1, WORK, 3, 0, 0 )
2139 NGRIDS = WORK( 1 )
2140 NMAT = WORK( 2 )
2141 NBLOG = WORK( 3 )
2142*
2143 I = 2*NGRIDS + 38*NMAT + NSUBS + 4
2144 CALL IGEBR2D( ICTXT, 'all', ' ', I, 1, WORK, I, 0, 0 )
2145*
2146 I = 1
2147.EQ. IF( WORK( I )1 ) THEN
2148 SOF = .TRUE.
2149 ELSE
2150 SOF = .FALSE.
2151 END IF
2152 I = I + 1
2153.EQ. IF( WORK( I )1 ) THEN
2154 TEE = .TRUE.
2155 ELSE
2156 TEE = .FALSE.
2157 END IF
2158 I = I + 1
2159 IVERB = WORK( I )
2160 I = I + 1
2161 IGAP = WORK( I )
2162 I = I + 1
2163 DO 100 J = 1, NMAT
2164 DIAGVAL( J ) = CHAR( WORK( I ) )
2165 SIDEVAL( J ) = CHAR( WORK( I+1 ) )
2166 TRNAVAL( J ) = CHAR( WORK( I+2 ) )
2167 TRNBVAL( J ) = CHAR( WORK( I+3 ) )
2168 UPLOVAL( J ) = CHAR( WORK( I+4 ) )
2169 I = I + 5
2170 100 CONTINUE
2171 CALL ICOPY( NGRIDS, WORK( I ), 1, PVAL, 1 )
2172 I = I + NGRIDS
2173 CALL ICOPY( NGRIDS, WORK( I ), 1, QVAL, 1 )
2174 I = I + NGRIDS
2175 CALL ICOPY( NMAT, WORK( I ), 1, MVAL, 1 )
2176 I = I + NMAT
2177 CALL ICOPY( NMAT, WORK( I ), 1, NVAL, 1 )
2178 I = I + NMAT
2179 CALL ICOPY( NMAT, WORK( I ), 1, KVAL, 1 )
2180 I = I + NMAT
2181 CALL ICOPY( NMAT, WORK( I ), 1, MAVAL, 1 )
2182 I = I + NMAT
2183 CALL ICOPY( NMAT, WORK( I ), 1, NAVAL, 1 )
2184 I = I + NMAT
2185 CALL ICOPY( NMAT, WORK( I ), 1, IMBAVAL, 1 )
2186 I = I + NMAT
2187 CALL ICOPY( NMAT, WORK( I ), 1, INBAVAL, 1 )
2188 I = I + NMAT
2189 CALL ICOPY( NMAT, WORK( I ), 1, MBAVAL, 1 )
2190 I = I + NMAT
2191 CALL ICOPY( NMAT, WORK( I ), 1, NBAVAL, 1 )
2192 I = I + NMAT
2193 CALL ICOPY( NMAT, WORK( I ), 1, RSCAVAL, 1 )
2194 I = I + NMAT
2195 CALL ICOPY( NMAT, WORK( I ), 1, CSCAVAL, 1 )
2196 I = I + NMAT
2197 CALL ICOPY( NMAT, WORK( I ), 1, IAVAL, 1 )
2198 I = I + NMAT
2199 CALL ICOPY( NMAT, WORK( I ), 1, JAVAL, 1 )
2200 I = I + NMAT
2201 CALL ICOPY( NMAT, WORK( I ), 1, MBVAL, 1 )
2202 I = I + NMAT
2203 CALL ICOPY( NMAT, WORK( I ), 1, NBVAL, 1 )
2204 I = I + NMAT
2205 CALL ICOPY( NMAT, WORK( I ), 1, IMBBVAL, 1 )
2206 I = I + NMAT
2207 CALL ICOPY( NMAT, WORK( I ), 1, INBBVAL, 1 )
2208 I = I + NMAT
2209 CALL ICOPY( NMAT, WORK( I ), 1, MBBVAL, 1 )
2210 I = I + NMAT
2211 CALL ICOPY( NMAT, WORK( I ), 1, NBBVAL, 1 )
2212 I = I + NMAT
2213 CALL ICOPY( NMAT, WORK( I ), 1, RSCBVAL, 1 )
2214 I = I + NMAT
2215 CALL ICOPY( NMAT, WORK( I ), 1, CSCBVAL, 1 )
2216 I = I + NMAT
2217 CALL ICOPY( NMAT, WORK( I ), 1, IBVAL, 1 )
2218 I = I + NMAT
2219 CALL ICOPY( NMAT, WORK( I ), 1, JBVAL, 1 )
2220 I = I + NMAT
2221 CALL ICOPY( NMAT, WORK( I ), 1, MCVAL, 1 )
2222 I = I + NMAT
2223 CALL ICOPY( NMAT, WORK( I ), 1, NCVAL, 1 )
2224 I = I + NMAT
2225 CALL ICOPY( NMAT, WORK( I ), 1, IMBCVAL, 1 )
2226 I = I + NMAT
2227 CALL ICOPY( NMAT, WORK( I ), 1, INBCVAL, 1 )
2228 I = I + NMAT
2229 CALL ICOPY( NMAT, WORK( I ), 1, MBCVAL, 1 )
2230 I = I + NMAT
2231 CALL ICOPY( NMAT, WORK( I ), 1, NBCVAL, 1 )
2232 I = I + NMAT
2233 CALL ICOPY( NMAT, WORK( I ), 1, RSCCVAL, 1 )
2234 I = I + NMAT
2235 CALL ICOPY( NMAT, WORK( I ), 1, CSCCVAL, 1 )
2236 I = I + NMAT
2237 CALL ICOPY( NMAT, WORK( I ), 1, ICVAL, 1 )
2238 I = I + NMAT
2239 CALL ICOPY( NMAT, WORK( I ), 1, JCVAL, 1 )
2240 I = I + NMAT
2241*
2242 DO 110 J = 1, NSUBS
2243.EQ. IF( WORK( I )1 ) THEN
2244 LTEST( J ) = .TRUE.
2245 ELSE
2246 LTEST( J ) = .FALSE.
2247 END IF
2248 I = I + 1
2249 110 CONTINUE
2250*
2251 END IF
2252*
2253 CALL BLACS_GRIDEXIT( ICTXT )
2254*
2255 RETURN
2256*
2257 120 WRITE( NOUT, FMT = 9997 )
2258 CLOSE( NIN )
2259.NE..AND..NE. IF( NOUT6 NOUT0 )
2260 $ CLOSE( NOUT )
2261 CALL BLACS_ABORT( ICTXT, 1 )
2262*
2263 STOP
2264*
2265 9999 FORMAT( A )
2266 9998 FORMAT( ' number of values of ',5A, ' is less than 1 or greater ',
2267 $ 'than ', I2 )
2268 9997 FORMAT( ' illegal input in file ',40A,'. aborting run.' )
2269 9996 FORMAT( A7, L2 )
2270 9995 FORMAT( ' subprogram name ', A7, ' not recognized',
2271 $ /' ******* tests abandoned *******' )
2272 9994 FORMAT( 2X, 'relative machine precision (eps) is taken to be ',
2273 $ E18.6 )
2274 9993 FORMAT( 2X, 'number of tests : ', I6 )
2275 9992 FORMAT( 2X, 'number of process grids : ', I6 )
2276 9991 FORMAT( 2X, ' : ', 5I6 )
2277 9990 FORMAT( 2X, A1, ' : ', 5I6 )
2278 9988 FORMAT( 2X, 'stop on failure flag : ', L6 )
2279 9987 FORMAT( 2X, 'test for error exits flag : ', L6 )
2280 9986 FORMAT( 2X, 'verbosity level : ', I6 )
2281 9985 FORMAT( 2X, 'routines to be tested : ', A, A8 )
2282 9984 FORMAT( 2X, ' ', A, A8 )
2283 9983 FORMAT( 2X, 'leading dimension gap : ', I6 )
2284 9982 FORMAT( 2X, 'alpha : (', G16.6,
2285 $ ',', G16.6, ')' )
2286 9981 FORMAT( 2X, 'beta : (', G16.6,
2287 $ ',', G16.6, ')' )
2288 9980 FORMAT( 2X, 'threshold value : ', G16.6 )
2289 9979 FORMAT( 2X, 'logical block size : ', I6 )
2290*
2291* End of PZBLA3TSTINFO
2292*
2293 END
2294 SUBROUTINE PZBLAS3TSTCHKE( LTEST, INOUT, NPROCS )
2295*
2296* -- PBLAS test routine (version 2.0) --
2297* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2298* and University of California, Berkeley.
2299* April 1, 1998
2300*
2301* .. Scalar Arguments ..
2302 INTEGER INOUT, NPROCS
2303* ..
2304* .. Array Arguments ..
2305 LOGICAL LTEST( * )
2306* ..
2307*
2308* Purpose
2309* =======
2310*
2311* PZBLAS3TSTCHKE tests the error exits of the Level 3 PBLAS.
2312*
2313* Arguments
2314* =========
2315*
2316* LTEST (global input) LOGICAL array
2317* On entry, LTEST is an array of dimension at least 11 (NSUBS).
2318* If LTEST( 1 ) is .TRUE., PZGEMM will be tested;
2319* If LTEST( 2 ) is .TRUE., PZSYMM will be tested;
2320* If LTEST( 3 ) is .TRUE., PZHEMM will be tested;
2321* If LTEST( 4 ) is .TRUE., PZSYRK will be tested;
2322* If LTEST( 5 ) is .TRUE., PZHERK will be tested;
2323* If LTEST( 6 ) is .TRUE., PZSYR2K will be tested;
2324* If LTEST( 7 ) is .TRUE., PZHER2K will be tested;
2325* If LTEST( 8 ) is .TRUE., PZTRMM will be tested;
2326* If LTEST( 9 ) is .TRUE., PZTRSM will be tested;
2327* If LTEST( 10 ) is .TRUE., PZGEADD will be tested;
2328* If LTEST( 11 ) is .TRUE., PZTRADD will be tested;
2329*
2330* INOUT (global input) INTEGER
2331* On entry, INOUT specifies the unit number for output file.
2332* When INOUT is 6, output to screen, when INOUT = 0, output to
2333* stderr. INOUT is only defined in process 0.
2334*
2335* NPROCS (global input) INTEGER
2336* On entry, NPROCS specifies the total number of processes cal-
2337* ling this routine.
2338*
2339* Calling sequence encodings
2340* ==========================
2341*
2342* code Formal argument list Examples
2343*
2344* 11 (n, v1,v2) _SWAP, _COPY
2345* 12 (n,s1, v1 ) _SCAL, _SCAL
2346* 13 (n,s1, v1,v2) _AXPY, _DOT_
2347* 14 (n,s1,i1,v1 ) _AMAX
2348* 15 (n,u1, v1 ) _ASUM, _NRM2
2349*
2350* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
2351* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
2352* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
2353* 24 ( m,n,s1,v1,v2,m1) _GER_
2354* 25 (uplo, n,s1,v1, m1) _SYR
2355* 26 (uplo, n,u1,v1, m1) _HER
2356* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
2357*
2358* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
2359* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
2360* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
2361* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
2362* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
2363* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
2364* 37 ( m,n, s1,m1, s2,m3) _TRAN_
2365* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
2366* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
2367* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
2368*
2369* -- Written on April 1, 1998 by
2370* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2371*
2372* =====================================================================
2373*
2374* .. Parameters ..
2375 INTEGER NSUBS
2376 PARAMETER ( NSUBS = 11 )
2377* ..
2378* .. Local Scalars ..
2379 LOGICAL ABRTSAV
2380 INTEGER I, ICTXT, MYCOL, MYROW, NPCOL, NPROW
2381* ..
2382* .. Local Arrays ..
2383 INTEGER SCODE( NSUBS )
2384* ..
2385* .. External Subroutines ..
2386 EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
2387 $ BLACS_GRIDINIT, PZDIMEE, PZGEADD, PZGEMM,
2388 $ PZHEMM, PZHER2K, PZHERK, PZMATEE, PZOPTEE,
2389 $ PZSYMM, PZSYR2K, PZSYRK, PZTRADD, PZTRMM,
2390 $ PZTRSM
2391* ..
2392* .. Common Blocks ..
2393 LOGICAL ABRTFLG
2394 INTEGER NOUT
2395 CHARACTER*7 SNAMES( NSUBS )
2396 COMMON /SNAMEC/SNAMES
2397 COMMON /PBERRORC/NOUT, ABRTFLG
2398* ..
2399* .. Data Statements ..
2400 DATA SCODE/31, 32, 32, 33, 34, 35, 36, 38, 38, 39,
2401 $ 40/
2402* ..
2403* .. Executable Statements ..
2404*
2405* Temporarily define blacs grid to include all processes so
2406* information can be broadcast to all processes.
2407*
2408 CALL BLACS_GET( -1, 0, ICTXT )
2409 CALL BLACS_GRIDINIT( ICTXT, 'row-major', 1, NPROCS )
2410 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
2411*
2412* Set ABRTFLG to FALSE so that the PBLAS error handler won't abort
2413* on errors during these tests and set the output device unit for
2414* it.
2415*
2416 ABRTSAV = ABRTFLG
2417 ABRTFLG = .FALSE.
2418 NOUT = INOUT
2419*
2420* Test PZGEMM
2421*
2422 I = 1
2423 IF( LTEST( I ) ) THEN
2424 CALL PZOPTEE( ICTXT, NOUT, PZGEMM, SCODE( I ), SNAMES( I ) )
2425 CALL PZDIMEE( ICTXT, NOUT, PZGEMM, SCODE( I ), SNAMES( I ) )
2426 CALL PZMATEE( ICTXT, NOUT, PZGEMM, SCODE( I ), SNAMES( I ) )
2427 END IF
2428*
2429* Test PZSYMM
2430*
2431 I = I + 1
2432 IF( LTEST( I ) ) THEN
2433 CALL PZOPTEE( ICTXT, NOUT, PZSYMM, SCODE( I ), SNAMES( I ) )
2434 CALL PZDIMEE( ICTXT, NOUT, PZSYMM, SCODE( I ), SNAMES( I ) )
2435 CALL PZMATEE( ICTXT, NOUT, PZSYMM, SCODE( I ), SNAMES( I ) )
2436 END IF
2437*
2438* Test PZHEMM
2439*
2440 I = I + 1
2441 IF( LTEST( I ) ) THEN
2442 CALL PZOPTEE( ICTXT, NOUT, PZHEMM, SCODE( I ), SNAMES( I ) )
2443 CALL PZDIMEE( ICTXT, NOUT, PZHEMM, SCODE( I ), SNAMES( I ) )
2444 CALL PZMATEE( ICTXT, NOUT, PZHEMM, SCODE( I ), SNAMES( I ) )
2445 END IF
2446*
2447* Test PZSYRK
2448*
2449 I = I + 1
2450 IF( LTEST( I ) ) THEN
2451 CALL PZOPTEE( ICTXT, NOUT, PZSYRK, SCODE( I ), SNAMES( I ) )
2452 CALL PZDIMEE( ICTXT, NOUT, PZSYRK, SCODE( I ), SNAMES( I ) )
2453 CALL PZMATEE( ICTXT, NOUT, PZSYRK, SCODE( I ), SNAMES( I ) )
2454 END IF
2455*
2456* Test PZHERK
2457*
2458 I = I + 1
2459 IF( LTEST( I ) ) THEN
2460 CALL PZOPTEE( ICTXT, NOUT, PZHERK, SCODE( I ), SNAMES( I ) )
2461 CALL PZDIMEE( ICTXT, NOUT, PZHERK, SCODE( I ), SNAMES( I ) )
2462 CALL PZMATEE( ICTXT, NOUT, PZHERK, SCODE( I ), SNAMES( I ) )
2463 END IF
2464*
2465* Test PZSYR2K
2466*
2467 I = I + 1
2468 IF( LTEST( I ) ) THEN
2469 CALL PZOPTEE( ICTXT, NOUT, PZSYR2K, SCODE( I ), SNAMES( I ) )
2470 CALL PZDIMEE( ICTXT, NOUT, PZSYR2K, SCODE( I ), SNAMES( I ) )
2471 CALL PZMATEE( ICTXT, NOUT, PZSYR2K, SCODE( I ), SNAMES( I ) )
2472 END IF
2473*
2474* Test PZHER2K
2475*
2476 I = I + 1
2477 IF( LTEST( I ) ) THEN
2478 CALL PZOPTEE( ICTXT, NOUT, PZHER2K, SCODE( I ), SNAMES( I ) )
2479 CALL PZDIMEE( ICTXT, NOUT, PZHER2K, SCODE( I ), SNAMES( I ) )
2480 CALL PZMATEE( ICTXT, NOUT, PZHER2K, SCODE( I ), SNAMES( I ) )
2481 END IF
2482*
2483* Test PZTRMM
2484*
2485 I = I + 1
2486 IF( LTEST( I ) ) THEN
2487 CALL PZOPTEE( ICTXT, NOUT, PZTRMM, SCODE( I ), SNAMES( I ) )
2488 CALL PZDIMEE( ICTXT, NOUT, PZTRMM, SCODE( I ), SNAMES( I ) )
2489 CALL PZMATEE( ICTXT, NOUT, PZTRMM, SCODE( I ), SNAMES( I ) )
2490 END IF
2491*
2492* Test PZTRSM
2493*
2494 I = I + 1
2495 IF( LTEST( I ) ) THEN
2496 CALL PZOPTEE( ICTXT, NOUT, PZTRSM, SCODE( I ), SNAMES( I ) )
2497 CALL PZDIMEE( ICTXT, NOUT, PZTRSM, SCODE( I ), SNAMES( I ) )
2498 CALL PZMATEE( ICTXT, NOUT, PZTRSM, SCODE( I ), SNAMES( I ) )
2499 END IF
2500*
2501* Test PZGEADD
2502*
2503 I = I + 1
2504 IF( LTEST( I ) ) THEN
2505 CALL PZOPTEE( ICTXT, NOUT, PZGEADD, SCODE( I ), SNAMES( I ) )
2506 CALL PZDIMEE( ICTXT, NOUT, PZGEADD, SCODE( I ), SNAMES( I ) )
2507 CALL PZMATEE( ICTXT, NOUT, PZGEADD, SCODE( I ), SNAMES( I ) )
2508 END IF
2509*
2510* Test PZTRADD
2511*
2512 I = I + 1
2513 IF( LTEST( I ) ) THEN
2514 CALL PZOPTEE( ICTXT, NOUT, PZTRADD, SCODE( I ), SNAMES( I ) )
2515 CALL PZDIMEE( ICTXT, NOUT, PZTRADD, SCODE( I ), SNAMES( I ) )
2516 CALL PZMATEE( ICTXT, NOUT, PZTRADD, SCODE( I ), SNAMES( I ) )
2517 END IF
2518*
2519.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
2520 $ WRITE( NOUT, FMT = 9999 )
2521*
2522 CALL BLACS_GRIDEXIT( ICTXT )
2523*
2524* Reset ABRTFLG to the value it had before calling this routine
2525*
2526 ABRTFLG = ABRTSAV
2527*
2528 9999 FORMAT( 2X, 'error-exit tests completed.' )
2529*
2530 RETURN
2531*
2532* End of PZBLAS3TSTCHKE
2533*
2534 END
2535 SUBROUTINE PZCHKARG3( ICTXT, NOUT, SNAME, SIDE, UPLO, TRANSA,
2536 $ TRANSB, DIAG, M, N, K, ALPHA, IA, JA,
2537 $ DESCA, IB, JB, DESCB, BETA, IC, JC, DESCC,
2538 $ INFO )
2539*
2540* -- PBLAS test routine (version 2.0) --
2541* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2542* and University of California, Berkeley.
2543* April 1, 1998
2544*
2545* .. Scalar Arguments ..
2546 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2547 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N,
2548 $ NOUT
2549 COMPLEX*16 ALPHA, BETA
2550* ..
2551* .. Array Arguments ..
2552 CHARACTER*7 SNAME
2553 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
2554* ..
2555*
2556* Purpose
2557* =======
2558*
2559* PZCHKARG3 checks the input-only arguments of the Level 3 PBLAS. When
2560* INFO = 0, this routine makes a copy of its arguments (which are INPUT
2561* only arguments to PBLAS routines). Otherwise, it verifies the values
2562* of these arguments against the saved copies.
2563*
2564* Arguments
2565* =========
2566*
2567* ICTXT (local input) INTEGER
2568* On entry, ICTXT specifies the BLACS context handle, indica-
2569* ting the global context of the operation. The context itself
2570* is global, but the value of ICTXT is local.
2571*
2572* NOUT (global input) INTEGER
2573* On entry, NOUT specifies the unit number for the output file.
2574* When NOUT is 6, output to screen, when NOUT is 0, output to
2575* stderr. NOUT is only defined for process 0.
2576*
2577* SNAME (global input) CHARACTER*(*)
2578* On entry, SNAME specifies the subroutine name calling this
2579* subprogram.
2580*
2581* SIDE (global input) CHARACTER*1
2582* On entry, SIDE specifies the SIDE option in the Level 3 PBLAS
2583* operation.
2584*
2585* UPLO (global input) CHARACTER*1
2586* On entry, UPLO specifies the UPLO option in the Level 3 PBLAS
2587* operation.
2588*
2589* TRANSA (global input) CHARACTER*1
2590* On entry, TRANSA specifies the TRANSA option in the Level 3
2591* PBLAS operation.
2592*
2593* TRANSB (global input) CHARACTER*1
2594* On entry, TRANSB specifies the TRANSB option in the Level 3
2595* PBLAS operation.
2596*
2597* DIAG (global input) CHARACTER*1
2598* On entry, DIAG specifies the DIAG option in the Level 3 PBLAS
2599* operation.
2600*
2601* M (global input) INTEGER
2602* On entry, M specifies the dimension of the submatrix ope-
2603* rands.
2604*
2605* N (global input) INTEGER
2606* On entry, N specifies the dimension of the submatrix ope-
2607* rands.
2608*
2609* K (global input) INTEGER
2610* On entry, K specifies the dimension of the submatrix ope-
2611* rands.
2612*
2613* ALPHA (global input) COMPLEX*16
2614* On entry, ALPHA specifies the scalar alpha.
2615*
2616* IA (global input) INTEGER
2617* On entry, IA specifies A's global row index, which points to
2618* the beginning of the submatrix sub( A ).
2619*
2620* JA (global input) INTEGER
2621* On entry, JA specifies A's global column index, which points
2622* to the beginning of the submatrix sub( A ).
2623*
2624* DESCA (global and local input) INTEGER array
2625* On entry, DESCA is an integer array of dimension DLEN_. This
2626* is the array descriptor for the matrix A.
2627*
2628* IB (global input) INTEGER
2629* On entry, IB specifies B's global row index, which points to
2630* the beginning of the submatrix sub( B ).
2631*
2632* JB (global input) INTEGER
2633* On entry, JB specifies B's global column index, which points
2634* to the beginning of the submatrix sub( B ).
2635*
2636* DESCB (global and local input) INTEGER array
2637* On entry, DESCB is an integer array of dimension DLEN_. This
2638* is the array descriptor for the matrix B.
2639*
2640* BETA (global input) COMPLEX*16
2641* On entry, BETA specifies the scalar beta.
2642*
2643* IC (global input) INTEGER
2644* On entry, IC specifies C's global row index, which points to
2645* the beginning of the submatrix sub( C ).
2646*
2647* JC (global input) INTEGER
2648* On entry, JC specifies C's global column index, which points
2649* to the beginning of the submatrix sub( C ).
2650*
2651* DESCC (global and local input) INTEGER array
2652* On entry, DESCC is an integer array of dimension DLEN_. This
2653* is the array descriptor for the matrix C.
2654*
2655* INFO (global input/global output) INTEGER
2656* When INFO = 0 on entry, the values of the arguments which are
2657* INPUT only arguments to a PBLAS routine are copied into sta-
2658* tic variables and INFO is unchanged on exit. Otherwise, the
2659* values of the arguments are compared against the saved co-
2660* pies. In case no error has been found INFO is zero on return,
2661* otherwise it is non zero.
2662*
2663* -- Written on April 1, 1998 by
2664* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2665*
2666* =====================================================================
2667*
2668* .. Parameters ..
2669 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2670 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2671 $ RSRC_
2672 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
2673 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
2674 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
2675 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
2676* ..
2677* .. Local Scalars ..
2678 CHARACTER*1 DIAGREF, SIDEREF, TRANSAREF, TRANSBREF, UPLOREF
2679 INTEGER I, IAREF, IBREF, ICREF, JAREF, JBREF, JCREF,
2680 $ KREF, MREF, MYCOL, MYROW, NPCOL, NPROW, NREF
2681 COMPLEX*16 ALPHAREF, BETAREF
2682* ..
2683* .. Local Arrays ..
2684 CHARACTER*15 ARGNAME
2685 INTEGER DESCAREF( DLEN_ ), DESCBREF( DLEN_ ),
2686 $ DESCCREF( DLEN_ )
2687* ..
2688* .. External Subroutines ..
2689 EXTERNAL BLACS_GRIDINFO, IGSUM2D
2690* ..
2691* .. External Functions ..
2692 LOGICAL LSAME
2693 EXTERNAL LSAME
2694* ..
2695* .. Save Statements ..
2696 SAVE
2697* ..
2698* .. Executable Statements ..
2699*
2700* Get grid parameters
2701*
2702 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
2703*
2704* Check if first call. If yes, then save.
2705*
2706.EQ. IF( INFO0 ) THEN
2707*
2708 DIAGREF = DIAG
2709 SIDEREF = SIDE
2710 TRANSAREF = TRANSA
2711 TRANSBREF = TRANSB
2712 UPLOREF = UPLO
2713 MREF = M
2714 NREF = N
2715 KREF = K
2716 ALPHAREF = ALPHA
2717 IAREF = IA
2718 JAREF = JA
2719 DO 10 I = 1, DLEN_
2720 DESCAREF( I ) = DESCA( I )
2721 10 CONTINUE
2722 IBREF = IB
2723 JBREF = JB
2724 DO 20 I = 1, DLEN_
2725 DESCBREF( I ) = DESCB( I )
2726 20 CONTINUE
2727 BETAREF = BETA
2728 ICREF = IC
2729 JCREF = JC
2730 DO 30 I = 1, DLEN_
2731 DESCCREF( I ) = DESCC( I )
2732 30 CONTINUE
2733*
2734 ELSE
2735*
2736* Test saved args. Return with first mismatch.
2737*
2738 ARGNAME = ' '
2739.NOT. IF( LSAME( DIAG, DIAGREF ) ) THEN
2740 WRITE( ARGNAME, FMT = '(A)' ) 'diag'
2741.NOT. ELSE IF( LSAME( SIDE, SIDEREF ) ) THEN
2742 WRITE( ARGNAME, FMT = '(A)' ) 'side'
2743.NOT. ELSE IF( LSAME( TRANSA, TRANSAREF ) ) THEN
2744 WRITE( ARGNAME, FMT = '(A)' ) 'TRANSA'
2745 ELSE IF( .NOT. lsame( transb, transbref ) ) THEN
2746 WRITE( argname, fmt = '(A)' ) 'TRANSB'
2747 ELSE IF( .NOT. lsame( uplo, uploref ) ) THEN
2748 WRITE( argname, fmt = '(A)' ) 'UPLO'
2749 ELSE IF( m.NE.mref ) THEN
2750 WRITE( argname, fmt = '(A)' ) 'M'
2751 ELSE IF( n.NE.nref ) THEN
2752 WRITE( argname, fmt = '(A)' ) 'N'
2753 ELSE IF( k.NE.kref ) THEN
2754 WRITE( argname, fmt = '(A)' ) 'K'
2755 ELSE IF( alpha.NE.alpharef ) THEN
2756 WRITE( argname, fmt = '(A)' ) 'ALPHA'
2757 ELSE IF( ia.NE.iaref ) THEN
2758 WRITE( argname, fmt = '(A)' ) 'IA'
2759 ELSE IF( ja.NE.jaref ) THEN
2760 WRITE( argname, fmt = '(A)' ) 'JA'
2761 ELSE IF( desca( dtype_ ).NE.descaref( dtype_ ) ) THEN
2762 WRITE( argname, fmt = '(A)' ) 'DESCA( DTYPE_ )'
2763 ELSE IF( desca( m_ ).NE.descaref( m_ ) ) THEN
2764 WRITE( argname, fmt = '(A)' ) 'DESCA( M_ )'
2765 ELSE IF( desca( n_ ).NE.descaref( n_ ) ) THEN
2766 WRITE( argname, fmt = '(A)' ) 'DESCA( N_ )'
2767 ELSE IF( desca( imb_ ).NE.descaref( imb_ ) ) THEN
2768 WRITE( argname, fmt = '(A)' ) 'DESCA( IMB_ )'
2769 ELSE IF( desca( inb_ ).NE.descaref( inb_ ) ) THEN
2770 WRITE( argname, fmt = '(A)' ) 'DESCA( INB_ )'
2771 ELSE IF( desca( mb_ ).NE.descaref( mb_ ) ) THEN
2772 WRITE( argname, fmt = '(A)' ) 'DESCA( MB_ )'
2773 ELSE IF( desca( nb_ ).NE.descaref( nb_ ) ) THEN
2774 WRITE( argname, fmt = '(A)' ) 'DESCA( NB_ )'
2775 ELSE IF( desca( rsrc_ ).NE.descaref( rsrc_ ) ) THEN
2776 WRITE( argname, fmt = '(A)' ) 'DESCA( RSRC_ )'
2777 ELSE IF( desca( csrc_ ).NE.descaref( csrc_ ) ) THEN
2778 WRITE( argname, fmt = '(A)' ) 'DESCA( CSRC_ )'
2779 ELSE IF( desca( ctxt_ ).NE.descaref( ctxt_ ) ) THEN
2780 WRITE( argname, fmt = '(A)' ) 'DESCA( CTXT_ )'
2781 ELSE IF( desca( lld_ ).NE.descaref( lld_ ) ) THEN
2782 WRITE( argname, fmt = '(A)' ) 'DESCA( LLD_ )'
2783 ELSE IF( ib.NE.ibref ) THEN
2784 WRITE( argname, fmt = '(A)' ) 'IB'
2785 ELSE IF( jb.NE.jbref ) THEN
2786 WRITE( argname, fmt = '(a)' ) 'jb'
2787.NE. ELSE IF( DESCB( DTYPE_ )DESCBREF( DTYPE_ ) ) THEN
2788 WRITE( ARGNAME, FMT = '(a)' ) 'descb( dtype_ )'
2789.NE. ELSE IF( DESCB( M_ )DESCBREF( M_ ) ) THEN
2790 WRITE( ARGNAME, FMT = '(a)' ) 'descb( m_ )'
2791.NE. ELSE IF( DESCB( N_ )DESCBREF( N_ ) ) THEN
2792 WRITE( ARGNAME, FMT = '(a)' ) 'descb( n_ )'
2793.NE. ELSE IF( DESCB( IMB_ )DESCBREF( IMB_ ) ) THEN
2794 WRITE( ARGNAME, FMT = '(a)' ) 'descb( imb_ )'
2795.NE. ELSE IF( DESCB( INB_ )DESCBREF( INB_ ) ) THEN
2796 WRITE( ARGNAME, FMT = '(a)' ) 'descb( inb_ )'
2797.NE. ELSE IF( DESCB( MB_ )DESCBREF( MB_ ) ) THEN
2798 WRITE( ARGNAME, FMT = '(a)' ) 'descb( mb_ )'
2799.NE. ELSE IF( DESCB( NB_ )DESCBREF( NB_ ) ) THEN
2800 WRITE( ARGNAME, FMT = '(a)' ) 'descb( nb_ )'
2801.NE. ELSE IF( DESCB( RSRC_ )DESCBREF( RSRC_ ) ) THEN
2802 WRITE( ARGNAME, FMT = '(a)' ) 'descb( rsrc_ )'
2803.NE. ELSE IF( DESCB( CSRC_ )DESCBREF( CSRC_ ) ) THEN
2804 WRITE( ARGNAME, FMT = '(a)' ) 'descb( csrc_ )'
2805.NE. ELSE IF( DESCB( CTXT_ )DESCBREF( CTXT_ ) ) THEN
2806 WRITE( ARGNAME, FMT = '(a)' ) 'descb( ctxt_ )'
2807.NE. ELSE IF( DESCB( LLD_ )DESCBREF( LLD_ ) ) THEN
2808 WRITE( ARGNAME, FMT = '(a)' ) 'descb( lld_ )'
2809.NE. ELSE IF( BETABETAREF ) THEN
2810 WRITE( ARGNAME, FMT = '(a)' ) 'beta'
2811.NE. ELSE IF( ICICREF ) THEN
2812 WRITE( ARGNAME, FMT = '(a)' ) 'ic'
2813.NE. ELSE IF( JCJCREF ) THEN
2814 WRITE( ARGNAME, FMT = '(a)' ) 'jc'
2815.NE. ELSE IF( DESCC( DTYPE_ )DESCCREF( DTYPE_ ) ) THEN
2816 WRITE( ARGNAME, FMT = '(a)' ) 'descc( dtype_ )'
2817.NE. ELSE IF( DESCC( M_ )DESCCREF( M_ ) ) THEN
2818 WRITE( ARGNAME, FMT = '(a)' ) 'descc( m_ )'
2819.NE. ELSE IF( DESCC( N_ )DESCCREF( N_ ) ) THEN
2820 WRITE( ARGNAME, FMT = '(a)' ) 'DESCC( N_ )'
2821 ELSE IF( descc( imb_ ).NE.desccref( imb_ ) ) THEN
2822 WRITE( argname, fmt = '(A)' ) 'DESCC( IMB_ )'
2823 ELSE IF( descc( inb_ ).NE.desccref( inb_ ) ) THEN
2824 WRITE( argname, fmt = '(A)' ) 'DESCC( INB_ )'
2825 ELSE IF( descc( mb_ ).NE.desccref( mb_ ) ) THEN
2826 WRITE( argname, fmt = '(A)' ) 'DESCC( MB_ )'
2827 ELSE IF( descc( nb_ ).NE.desccref( nb_ ) ) THEN
2828 WRITE( argname, fmt = '(A)' ) 'DESCC( NB_ )'
2829 ELSE IF( descc( rsrc_ ).NE.desccref( rsrc_ ) ) THEN
2830 WRITE( argname, fmt = '(A)' ) 'DESCC( RSRC_ )'
2831 ELSE IF( descc( csrc_ ).NE.desccref( csrc_ ) ) THEN
2832 WRITE( argname, fmt = '(A)' ) 'DESCC( CSRC_ )'
2833 ELSE IF( descc( ctxt_ ).NE.desccref( ctxt_ ) ) THEN
2834 WRITE( argname, fmt = '(A)' ) 'DESCC( CTXT_ )'
2835 ELSE IF( descc( lld_ ).NE.desccref( lld_ ) ) THEN
2836 WRITE( argname, fmt = '(A)' ) 'DESCC( LLD_ )'
2837 ELSE
2838 info = 0
2839 END IF
2840*
2841 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
2842*
2843 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2844*
2845 IF( info.NE.0 ) THEN
2846 WRITE( nout, fmt = 9999 ) argname, sname
2847 ELSE
2848 WRITE( nout, fmt = 9998 ) sname
2849 END IF
2850*
2851 END IF
2852*
2853 END IF
2854*
2855 9999 FORMAT( 2x, ' ***** Input-only parameter check: ', a,
2856 $ ' FAILED changed ', a, ' *****' )
2857 9998 FORMAT( 2x, ' ***** input-only parameter check: ', A,
2858 $ ' passed *****' )
2859*
2860 RETURN
2861*
2862* End of PZCHKARG3
2863*
2864 END
2865 SUBROUTINE PZBLAS3TSTCHK( ICTXT, NOUT, NROUT, SIDE, UPLO, TRANSA,
2866 $ TRANSB, DIAG, M, N, K, ALPHA, A, PA, IA,
2867 $ JA, DESCA, B, PB, IB, JB, DESCB, BETA,
2868 $ C, PC, IC, JC, DESCC, THRESH, ROGUE,
2869 $ WORK, RWORK, INFO )
2870*
2871* -- PBLAS test routine (version 2.0) --
2872* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2873* and University of California, Berkeley.
2874* April 1, 1998
2875*
2876* .. Scalar Arguments ..
2877 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2878 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N,
2879 $ NOUT, NROUT
2880 REAL THRESH
2881 COMPLEX*16 ALPHA, BETA, ROGUE
2882* ..
2883* .. Array Arguments ..
2884 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
2885 DOUBLE PRECISION RWORK( * )
2886 COMPLEX*16 A( * ), B( * ), C( * ), PA( * ), PB( * ),
2887 $ PC( * ), WORK( * )
2888* ..
2889*
2890* Purpose
2891* =======
2892*
2893* PZBLAS3TSTCHK performs the computational tests of the Level 3 PBLAS.
2894*
2895* Notes
2896* =====
2897*
2898* A description vector is associated with each 2D block-cyclicly dis-
2899* tributed matrix. This vector stores the information required to
2900* establish the mapping between a matrix entry and its corresponding
2901* process and memory location.
2902*
2903* In the following comments, the character _ should be read as
2904* "of the distributed matrix". Let A be a generic term for any 2D
2905* block cyclicly distributed matrix. Its description vector is DESCA:
2906*
2907* NOTATION STORED IN EXPLANATION
2908* ---------------- --------------- ------------------------------------
2909* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2910* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2911* the NPROW x NPCOL BLACS process grid
2912* A is distributed over. The context
2913* itself is global, but the handle
2914* (the integer value) may vary.
2915* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2916* ted matrix A, M_A >= 0.
2917* N_A (global) DESCA( N_ ) The number of columns in the distri-
2918* buted matrix A, N_A >= 0.
2919* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2920* block of the matrix A, IMB_A > 0.
2921* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2922* left block of the matrix A,
2923* INB_A > 0.
2924* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2925* bute the last M_A-IMB_A rows of A,
2926* MB_A > 0.
2927* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2928* bute the last N_A-INB_A columns of
2929* A, NB_A > 0.
2930* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2931* row of the matrix A is distributed,
2932* NPROW > RSRC_A >= 0.
2933* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2934* first column of A is distributed.
2935* NPCOL > CSRC_A >= 0.
2936* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2937* array storing the local blocks of
2938* the distributed matrix A,
2939* IF( Lc( 1, N_A ) > 0 )
2940* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2941* ELSE
2942* LLD_A >= 1.
2943*
2944* Let K be the number of rows of a matrix A starting at the global in-
2945* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2946* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2947* receive if these K rows were distributed over NPROW processes. If K
2948* is the number of columns of a matrix A starting at the global index
2949* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2950* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2951* these K columns were distributed over NPCOL processes.
2952*
2953* The values of Lr() and Lc() may be determined via a call to the func-
2954* tion PB_NUMROC:
2955* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2956* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2957*
2958* Arguments
2959* =========
2960*
2961* ICTXT (local input) INTEGER
2962* On entry, ICTXT specifies the BLACS context handle, indica-
2963* ting the global context of the operation. The context itself
2964* is global, but the value of ICTXT is local.
2965*
2966* NOUT (global input) INTEGER
2967* On entry, NOUT specifies the unit number for the output file.
2968* When NOUT is 6, output to screen, when NOUT is 0, output to
2969* stderr. NOUT is only defined for process 0.
2970*
2971* NROUT (global input) INTEGER
2972* On entry, NROUT specifies which routine will be tested as
2973* follows:
2974* If NROUT = 1, PZGEMM will be tested;
2975* else if NROUT = 2, PZSYMM will be tested;
2976* else if NROUT = 3, PZHEMM will be tested;
2977* else if NROUT = 4, PZSYRK will be tested;
2978* else if NROUT = 5, PZHERK will be tested;
2979* else if NROUT = 6, PZSYR2K will be tested;
2980* else if NROUT = 7, PZHER2K will be tested;
2981* else if NROUT = 8, PZTRMM will be tested;
2982* else if NROUT = 9, PZTRSM will be tested;
2983* else if NROUT = 10, PZGEADD will be tested;
2984* else if NROUT = 11, PZTRADD will be tested;
2985*
2986* SIDE (global input) CHARACTER*1
2987* On entry, SIDE specifies if the multiplication should be per-
2988* formed from the left or the right.
2989*
2990* UPLO (global input) CHARACTER*1
2991* On entry, UPLO specifies if the upper or lower part of the
2992* matrix operand is to be referenced.
2993*
2994* TRANSA (global input) CHARACTER*1
2995* On entry, TRANSA specifies if the matrix operand A is to be
2996* transposed.
2997*
2998* TRANSB (global input) CHARACTER*1
2999* On entry, TRANSB specifies if the matrix operand B is to be
3000* transposed.
3001*
3002* DIAG (global input) CHARACTER*1
3003* On entry, DIAG specifies if the triangular matrix operand is
3004* unit or non-unit.
3005*
3006* M (global input) INTEGER
3007* On entry, M specifies the number of rows of C.
3008*
3009* N (global input) INTEGER
3010* On entry, N specifies the number of columns of C.
3011*
3012* K (global input) INTEGER
3013* On entry, K specifies the number of columns (resp. rows) of A
3014* when TRANSA = 'N' (resp. TRANSA <> 'N') in PxGEMM, PxSYRK,
3015* PxSYR2K, PxHERK and PxHER2K.
3016*
3017* ALPHA (global input) COMPLEX*16
3018* On entry, ALPHA specifies the scalar alpha.
3019*
3020* A (local input/local output) COMPLEX*16 array
3021* On entry, A is an array of dimension (DESCA( M_ ),*). This
3022* array contains a local copy of the initial entire matrix PA.
3023*
3024* PA (local input) COMPLEX*16 array
3025* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
3026* array contains the local entries of the matrix PA.
3027*
3028* IA (global input) INTEGER
3029* On entry, IA specifies A's global row index, which points to
3030* the beginning of the submatrix sub( A ).
3031*
3032* JA (global input) INTEGER
3033* On entry, JA specifies A's global column index, which points
3034* to the beginning of the submatrix sub( A ).
3035*
3036* DESCA (global and local input) INTEGER array
3037* On entry, DESCA is an integer array of dimension DLEN_. This
3038* is the array descriptor for the matrix A.
3039*
3040* B (local input/local output) COMPLEX*16 array
3041* On entry, B is an array of dimension (DESCB( M_ ),*). This
3042* array contains a local copy of the initial entire matrix PB.
3043*
3044* PB (local input) COMPLEX*16 array
3045* On entry, PB is an array of dimension (DESCB( LLD_ ),*). This
3046* array contains the local entries of the matrix PB.
3047*
3048* IB (global input) INTEGER
3049* On entry, IB specifies B's global row index, which points to
3050* the beginning of the submatrix sub( B ).
3051*
3052* JB (global input) INTEGER
3053* On entry, JB specifies B's global column index, which points
3054* to the beginning of the submatrix sub( B ).
3055*
3056* DESCB (global and local input) INTEGER array
3057* On entry, DESCB is an integer array of dimension DLEN_. This
3058* is the array descriptor for the matrix B.
3059*
3060* BETA (global input) COMPLEX*16
3061* On entry, BETA specifies the scalar beta.
3062*
3063* C (local input/local output) COMPLEX*16 array
3064* On entry, C is an array of dimension (DESCC( M_ ),*). This
3065* array contains a local copy of the initial entire matrix PC.
3066*
3067* PC (local input) COMPLEX*16 array
3068* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
3069* array contains the local pieces of the matrix PC.
3070*
3071* IC (global input) INTEGER
3072* On entry, IC specifies C's global row index, which points to
3073* the beginning of the submatrix sub( C ).
3074*
3075* JC (global input) INTEGER
3076* On entry, JC specifies C's global column index, which points
3077* to the beginning of the submatrix sub( C ).
3078*
3079* DESCC (global and local input) INTEGER array
3080* On entry, DESCC is an integer array of dimension DLEN_. This
3081* is the array descriptor for the matrix C.
3082*
3083* THRESH (global input) REAL
3084* On entry, THRESH is the threshold value for the test ratio.
3085*
3086* ROGUE (global input) COMPLEX*16
3087* On entry, ROGUE specifies the constant used to pad the
3088* non-referenced part of triangular, symmetric or Hermitian ma-
3089* trices.
3090*
3091* WORK (workspace) COMPLEX*16 array
3092* On entry, WORK is an array of dimension LWORK where LWORK is
3093* at least MAX( M, MAX( N, K ) ). This array is used to store
3094* a copy of a column of C (see PZMMCH).
3095*
3096* RWORK (workspace) DOUBLE PRECISION array
3097* On entry, RWORK is an array of dimension LRWORK where LRWORK
3098* is at least MAX( M, MAX( N, K ) ). This array is used to sto-
3099* re the computed gauges (see PZMMCH).
3100*
3101* INFO (global output) INTEGER
3102* On exit, if INFO = 0, no error has been found, otherwise
3103* if( MOD( INFO, 2 ) = 1 ) then an error on A has been found,
3104* if( MOD( INFO/2, 2 ) = 1 ) then an error on B has been found,
3105* if( MOD( INFO/4, 2 ) = 1 ) then an error on C has been found.
3106*
3107* -- Written on April 1, 1998 by
3108* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3109*
3110* =====================================================================
3111*
3112* .. Parameters ..
3113 DOUBLE PRECISION RZERO
3114 PARAMETER ( RZERO = 0.0D+0 )
3115 COMPLEX*16 ONE, ZERO
3116 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
3117 $ ZERO = ( 0.0D+0, 0.0D+0 ) )
3118 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3119 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3120 $ RSRC_
3121 PARAMETER ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
3122 $ DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
3123 $ IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
3124 $ RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
3125* ..
3126* .. Local Scalars ..
3127 INTEGER I, MYCOL, MYROW, NPCOL, NPROW
3128 DOUBLE PRECISION ERR
3129 COMPLEX*16 ALPHA1, BETA1
3130* ..
3131* .. Local Arrays ..
3132 INTEGER IERR( 3 )
3133* ..
3134* .. External Subroutines ..
3135 EXTERNAL BLACS_GRIDINFO, PB_ZLASET, PZCHKMIN, PZMMCH,
3136 $ PZMMCH1, PZMMCH2, PZMMCH3, PZTRMM, ZTRSM
3137* ..
3138* .. External Functions ..
3139 LOGICAL LSAME
3140 EXTERNAL LSAME
3141* ..
3142* .. Intrinsic Functions ..
3143 INTRINSIC DBLE, DCMPLX
3144* ..
3145* .. Executable Statements ..
3146*
3147 INFO = 0
3148*
3149* Quick return if possible
3150*
3151.LE..OR..LE. IF( ( M0 )( N0 ) )
3152 $ RETURN
3153*
3154* Start the operations
3155*
3156 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
3157*
3158 DO 10 I = 1, 3
3159 IERR( I ) = 0
3160 10 CONTINUE
3161*
3162.EQ. IF( NROUT1 ) THEN
3163*
3164* Test PZGEMM
3165*
3166* Check the resulting matrix C
3167*
3168 CALL PZMMCH( ICTXT, TRANSA, TRANSB, M, N, K, ALPHA, A, IA, JA,
3169 $ DESCA, B, IB, JB, DESCB, BETA, C, PC, IC, JC,
3170 $ DESCC, WORK, RWORK, ERR, IERR( 3 ) )
3171*
3172.NE. IF( IERR( 3 )0 ) THEN
3173.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3174 $ WRITE( NOUT, FMT = 9998 )
3175.GT. ELSE IF( ERRDBLE( THRESH ) ) THEN
3176.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3177 $ WRITE( NOUT, FMT = 9997 ) ERR
3178 END IF
3179*
3180* Check the input-only arguments
3181*
3182 IF( LSAME( TRANSA, 'n' ) ) THEN
3183 CALL PZCHKMIN( ERR, M, K, A, PA, IA, JA, DESCA, IERR( 1 ) )
3184 ELSE
3185 CALL PZCHKMIN( ERR, K, M, A, PA, IA, JA, DESCA, IERR( 1 ) )
3186 END IF
3187 IF( LSAME( TRANSB, 'n' ) ) THEN
3188 CALL PZCHKMIN( ERR, K, N, B, PB, IB, JB, DESCB, IERR( 2 ) )
3189 ELSE
3190 CALL PZCHKMIN( ERR, N, K, B, PB, IB, JB, DESCB, IERR( 2 ) )
3191 END IF
3192*
3193.EQ. ELSE IF( NROUT2 ) THEN
3194*
3195* Test PZSYMM
3196*
3197* Check the resulting matrix C
3198*
3199 IF( LSAME( SIDE, 'l' ) ) THEN
3200 CALL PZMMCH( ICTXT, 'no transpose', 'no transpose', M, N, M,
3201 $ ALPHA, A, IA, JA, DESCA, B, IB, JB, DESCB,
3202 $ BETA, C, PC, IC, JC, DESCC, WORK, RWORK, ERR,
3203 $ IERR( 3 ) )
3204 ELSE
3205 CALL PZMMCH( ICTXT, 'no transpose', 'no transpose', M, N, N,
3206 $ ALPHA, B, IB, JB, DESCB, A, IA, JA, DESCA,
3207 $ BETA, C, PC, IC, JC, DESCC, WORK, RWORK, ERR,
3208 $ IERR( 3 ) )
3209 END IF
3210*
3211.NE. IF( IERR( 3 )0 ) THEN
3212.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3213 $ WRITE( NOUT, FMT = 9998 )
3214.GT. ELSE IF( ERRDBLE( THRESH ) ) THEN
3215.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3216 $ WRITE( NOUT, FMT = 9997 ) ERR
3217 END IF
3218*
3219* Check the input-only arguments
3220*
3221 IF( LSAME( UPLO, 'l' ) ) THEN
3222 IF( LSAME( SIDE, 'l' ) ) THEN
3223 CALL PB_ZLASET( 'upper', M-1, M-1, 0, ROGUE, ROGUE,
3224 $ A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
3225 ELSE
3226 CALL PB_ZLASET( 'upper', N-1, N-1, 0, ROGUE, ROGUE,
3227 $ A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
3228 END IF
3229 ELSE
3230 IF( LSAME( SIDE, 'l' ) ) THEN
3231 CALL PB_ZLASET( 'lower', M-1, M-1, 0, ROGUE, ROGUE,
3232 $ A( IA+1+(JA-1)*DESCA( M_ ) ),
3233 $ DESCA( M_ ) )
3234 ELSE
3235 CALL PB_ZLASET( 'lower', N-1, N-1, 0, ROGUE, ROGUE,
3236 $ A( IA+1+(JA-1)*DESCA( M_ ) ),
3237 $ DESCA( M_ ) )
3238 END IF
3239 END IF
3240*
3241 IF( LSAME( SIDE, 'l' ) ) THEN
3242 CALL PZCHKMIN( ERR, M, M, A, PA, IA, JA, DESCA, IERR( 1 ) )
3243 ELSE
3244 CALL PZCHKMIN( ERR, N, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
3245 END IF
3246 CALL PZCHKMIN( ERR, M, N, B, PB, IB, JB, DESCB, IERR( 2 ) )
3247*
3248.EQ. ELSE IF( NROUT3 ) THEN
3249*
3250* Test PZHEMM
3251*
3252* Check the resulting matrix C
3253*
3254 IF( LSAME( SIDE, 'l' ) ) THEN
3255 CALL PZMMCH( ICTXT, 'no transpose', 'no transpose', M, N, M,
3256 $ ALPHA, A, IA, JA, DESCA, B, IB, JB, DESCB,
3257 $ BETA, C, PC, IC, JC, DESCC, WORK, RWORK, ERR,
3258 $ IERR( 3 ) )
3259 ELSE
3260 CALL PZMMCH( ICTXT, 'no transpose', 'no transpose', M, N, N,
3261 $ ALPHA, B, IB, JB, DESCB, A, IA, JA, DESCA,
3262 $ BETA, C, PC, IC, JC, DESCC, WORK, RWORK, ERR,
3263 $ IERR( 3 ) )
3264 END IF
3265*
3266.NE. IF( IERR( 3 )0 ) THEN
3267.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3268 $ WRITE( NOUT, FMT = 9998 )
3269.GT. ELSE IF( ERRDBLE( THRESH ) ) THEN
3270.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3271 $ WRITE( NOUT, FMT = 9997 ) ERR
3272 END IF
3273*
3274* Check the input-only arguments
3275*
3276 IF( LSAME( UPLO, 'l' ) ) THEN
3277 IF( LSAME( SIDE, 'l' ) ) THEN
3278 CALL PB_ZLASET( 'upper', M-1, M-1, 0, ROGUE, ROGUE,
3279 $ A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
3280 ELSE
3281 CALL PB_ZLASET( 'upper', N-1, N-1, 0, ROGUE, ROGUE,
3282 $ A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
3283 END IF
3284 ELSE
3285 IF( LSAME( SIDE, 'l' ) ) THEN
3286 CALL PB_ZLASET( 'lower', M-1, M-1, 0, ROGUE, ROGUE,
3287 $ A( IA+1+(JA-1)*DESCA( M_ ) ),
3288 $ DESCA( M_ ) )
3289 ELSE
3290 CALL PB_ZLASET( 'lower', N-1, N-1, 0, ROGUE, ROGUE,
3291 $ A( IA+1+(JA-1)*DESCA( M_ ) ),
3292 $ DESCA( M_ ) )
3293 END IF
3294 END IF
3295*
3296 IF( LSAME( SIDE, 'l' ) ) THEN
3297 CALL PZCHKMIN( ERR, M, M, A, PA, IA, JA, DESCA, IERR( 1 ) )
3298 ELSE
3299 CALL PZCHKMIN( ERR, N, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
3300 END IF
3301 CALL PZCHKMIN( ERR, M, N, B, PB, IB, JB, DESCB, IERR( 2 ) )
3302*
3303.EQ. ELSE IF( NROUT4 ) THEN
3304*
3305* Test PZSYRK
3306*
3307* Check the resulting matrix C
3308*
3309 IF( LSAME( TRANSA, 'n' ) ) THEN
3310 CALL PZMMCH1( ICTXT, UPLO, 'no transpose', N, K, ALPHA, A,
3311 $ IA, JA, DESCA, BETA, C, PC, IC, JC, DESCC,
3312 $ WORK, RWORK, ERR, IERR( 3 ) )
3313 ELSE
3314 CALL PZMMCH1( ICTXT, UPLO, 'transpose', N, K, ALPHA, A, IA,
3315 $ JA, DESCA, BETA, C, PC, IC, JC, DESCC, WORK,
3316 $ RWORK, ERR, IERR( 3 ) )
3317 END IF
3318*
3319.NE. IF( IERR( 3 )0 ) THEN
3320.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3321 $ WRITE( NOUT, FMT = 9998 )
3322.GT. ELSE IF( ERRDBLE( THRESH ) ) THEN
3323.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3324 $ WRITE( NOUT, FMT = 9997 ) ERR
3325 END IF
3326*
3327* Check the input-only arguments
3328*
3329 IF( LSAME( TRANSA, 'n' ) ) THEN
3330 CALL PZCHKMIN( ERR, N, K, A, PA, IA, JA, DESCA, IERR( 1 ) )
3331 ELSE
3332 CALL PZCHKMIN( ERR, K, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
3333 END IF
3334*
3335.EQ. ELSE IF( NROUT5 ) THEN
3336*
3337* Test PZHERK
3338*
3339* Check the resulting matrix C
3340*
3341 BETA1 = DCMPLX( DBLE( BETA ), RZERO )
3342 ALPHA1 = DCMPLX( DBLE( ALPHA ), RZERO )
3343 IF( LSAME( TRANSA, 'n' ) ) THEN
3344 CALL PZMMCH1( ICTXT, UPLO, 'hermitian', N, K, ALPHA1, A, IA,
3345 $ JA, DESCA, BETA1, C, PC, IC, JC, DESCC, WORK,
3346 $ RWORK, ERR, IERR( 3 ) )
3347 ELSE
3348 CALL PZMMCH1( ICTXT, UPLO, 'conjugate transpose', N, K,
3349 $ ALPHA1, A, IA, JA, DESCA, BETA1, C, PC, IC,
3350 $ JC, DESCC, WORK, RWORK, ERR, IERR( 3 ) )
3351 END IF
3352*
3353.NE. IF( IERR( 3 )0 ) THEN
3354.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3355 $ WRITE( NOUT, FMT = 9998 )
3356.GT. ELSE IF( ERRDBLE( THRESH ) ) THEN
3357.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3358 $ WRITE( NOUT, FMT = 9997 ) ERR
3359 END IF
3360*
3361* Check the input-only arguments
3362*
3363 IF( LSAME( TRANSA, 'n' ) ) THEN
3364 CALL pzchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3365 ELSE
3366 CALL pzchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3367 END IF
3368*
3369 ELSE IF( nrout.EQ.6 ) THEN
3370*
3371* Test PZSYR2K
3372*
3373* Check the resulting matrix C
3374*
3375 IF( lsame( transa, 'N' ) ) THEN
3376 CALL pzmmch2( ictxt, uplo, 'No transpose', n, k, alpha, a,
3377 $ ia, ja, desca, b, ib, jb, descb, beta, c, pc,
3378 $ ic, jc, descc, work, rwork, err, ierr( 3 ) )
3379 ELSE
3380 CALL pzmmch2( ictxt, uplo, 'Transpose', n, k, alpha, a,
3381 $ ia, ja, desca, b, ib, jb, descb, beta, c, pc,
3382 $ ic, jc, descc, work, rwork, err,
3383 $ ierr( 3 ) )
3384 END IF
3385*
3386 IF( ierr( 3 ).NE.0 ) THEN
3387 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3388 $ WRITE( nout, fmt = 9998 )
3389 ELSE IF( err.GT.dble( thresh ) ) THEN
3390 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3391 $ WRITE( nout, fmt = 9997 ) err
3392 END IF
3393*
3394* Check the input-only arguments
3395*
3396 IF( lsame( transa, 'N' ) ) THEN
3397 CALL pzchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3398 CALL pzchkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3399 ELSE
3400 CALL pzchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3401 CALL pzchkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3402 END IF
3403*
3404 ELSE IF( nrout.EQ.7 ) THEN
3405*
3406* Test PZHER2K
3407*
3408* Check the resulting matrix C
3409*
3410 beta1 = dcmplx( dble( beta ), rzero )
3411 IF( lsame( transa, 'N' ) ) THEN
3412 CALL pzmmch2( ictxt, uplo, 'Hermitian', n, k, alpha, a, ia,
3413 $ ja, desca, b, ib, jb, descb, beta1, c, pc, ic,
3414 $ jc, descc, work, rwork, err, ierr( 3 ) )
3415 ELSE
3416 CALL pzmmch2( ictxt, uplo, 'Conjugate transpose', n, k,
3417 $ alpha, a, ia, ja, desca, b, ib, jb, descb,
3418 $ beta1, c, pc, ic, jc, descc, work, rwork, err,
3419 $ ierr( 3 ) )
3420 END IF
3421*
3422 IF( ierr( 3 ).NE.0 ) THEN
3423 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3424 $ WRITE( nout, fmt = 9998 )
3425 ELSE IF( err.GT.dble( thresh ) ) THEN
3426 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3427 $ WRITE( nout, fmt = 9997 ) err
3428 END IF
3429*
3430* Check the input-only arguments
3431*
3432 IF( lsame( transa, 'N' ) ) THEN
3433 CALL pzchkmin( err, n, k, a, pa, ia, ja, desca, ierr( 1 ) )
3434 CALL pzchkmin( err, n, k, b, pb, ib, jb, descb, ierr( 2 ) )
3435 ELSE
3436 CALL pzchkmin( err, k, n, a, pa, ia, ja, desca, ierr( 1 ) )
3437 CALL pzchkmin( err, k, n, b, pb, ib, jb, descb, ierr( 2 ) )
3438 END IF
3439*
3440 ELSE IF( nrout.EQ.8 ) THEN
3441*
3442* Test PZTRMM
3443*
3444* Check the resulting matrix B
3445*
3446 IF( lsame( side, 'L' ) ) THEN
3447 CALL pzmmch( ictxt, transa, 'No transpose', m, n, m,
3448 $ alpha, a, ia, ja, desca, c, ib, jb, descb,
3449 $ zero, b, pb, ib, jb, descb, work, rwork, err,
3450 $ ierr( 2 ) )
3451 ELSE
3452 CALL pzmmch( ictxt, 'No transpose', transa, m, n, n,
3453 $ alpha, c, ib, jb, descb, a, ia, ja, desca,
3454 $ zero, b, pb, ib, jb, descb, work, rwork, err,
3455 $ ierr( 2 ) )
3456 END IF
3457*
3458 IF( ierr( 2 ).NE.0 ) THEN
3459 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3460 $ WRITE( nout, fmt = 9998 )
3461 ELSE IF( err.GT.dble( thresh ) ) THEN
3462 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3463 $ WRITE( nout, fmt = 9997 ) err
3464 END IF
3465*
3466* Check the input-only arguments
3467*
3468 IF( lsame( side, 'L' ) ) THEN
3469 IF( lsame( uplo, 'L' ) ) THEN
3470 IF( lsame( diag, 'N' ) ) THEN
3471 CALL pb_zlaset( 'Upper', m-1, m-1, 0, rogue, rogue,
3472 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3473 ELSE
3474 CALL pb_zlaset( 'Upper', m, m, 0, rogue, one,
3475 $ a( ia+(ja-1)*desca( m_ ) ),
3476 $ desca( m_ ) )
3477 END IF
3478 ELSE
3479 IF( lsame( diag, 'N' ) ) THEN
3480 CALL pb_zlaset( 'Lower', m-1, m-1, 0, rogue, rogue,
3481 $ a( ia+1+(ja-1)*desca( m_ ) ),
3482 $ desca( m_ ) )
3483 ELSE
3484 CALL pb_zlaset( 'Lower', m, m, 0, rogue, one,
3485 $ a( ia+(ja-1)*desca( m_ ) ),
3486 $ desca( m_ ) )
3487 END IF
3488 END IF
3489 CALL pzchkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3490 ELSE
3491 IF( lsame( uplo, 'L' ) ) THEN
3492 IF( lsame( diag, 'N' ) ) THEN
3493 CALL pb_zlaset( 'Upper', n-1, n-1, 0, rogue, rogue,
3494 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3495 ELSE
3496 CALL pb_zlaset( 'Upper', n, n, 0, rogue, one,
3497 $ a( ia+(ja-1)*desca( m_ ) ),
3498 $ desca( m_ ) )
3499 END IF
3500 ELSE
3501 IF( lsame( diag, 'N' ) ) THEN
3502 CALL pb_zlaset( 'Lower', n-1, n-1, 0, rogue, rogue,
3503 $ a( ia+1+(ja-1)*desca( m_ ) ),
3504 $ desca( m_ ) )
3505 ELSE
3506 CALL pb_zlaset( 'Lower', n, n, 0, rogue, one,
3507 $ a( ia+(ja-1)*desca( m_ ) ),
3508 $ desca( m_ ) )
3509 END IF
3510 END IF
3511 CALL pzchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3512 END IF
3513*
3514 ELSE IF( nrout.EQ.9 ) THEN
3515*
3516* Test PZTRSM
3517*
3518* Check the resulting matrix B
3519*
3520 CALL ztrsm( side, uplo, transa, diag, m, n, alpha,
3521 $ a( ia+(ja-1)*desca( m_ ) ), desca( m_ ),
3522 $ b( ib+(jb-1)*descb( m_ ) ), descb( m_ ) )
3523 CALL pztrmm( side, uplo, transa, diag, m, n, alpha, pa, ia, ja,
3524 $ desca, pb, ib, jb, descb )
3525 IF( lsame( side, 'L' ) ) THEN
3526 CALL pzmmch( ictxt, transa, 'No transpose', m, n, m, alpha,
3527 $ a, ia, ja, desca, b, ib, jb, descb, zero, c,
3528 $ pb, ib, jb, descb, work, rwork, err,
3529 $ ierr( 2 ) )
3530 ELSE
3531 CALL pzmmch( ictxt, 'No transpose', transa, m, n, n, alpha,
3532 $ b, ib, jb, descb, a, ia, ja, desca, zero, c,
3533 $ pb, ib, jb, descb, work, rwork, err,
3534 $ ierr( 2 ) )
3535 END IF
3536*
3537 IF( ierr( 2 ).NE.0 ) THEN
3538 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3539 $ WRITE( nout, fmt = 9998 )
3540 ELSE IF( err.GT.dble( thresh ) ) THEN
3541 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3542 $ WRITE( nout, fmt = 9997 ) err
3543 END IF
3544*
3545* Check the input-only arguments
3546*
3547 IF( lsame( side, 'L' ) ) THEN
3548 IF( lsame( uplo, 'L' ) ) THEN
3549 IF( lsame( diag, 'N' ) ) THEN
3550 CALL pb_zlaset( 'Upper', m-1, m-1, 0, rogue, rogue,
3551 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3552 ELSE
3553 CALL pb_zlaset( 'Upper', m, m, 0, rogue, one,
3554 $ a( ia+(ja-1)*desca( m_ ) ),
3555 $ desca( m_ ) )
3556 END IF
3557 ELSE
3558 IF( lsame( diag, 'N' ) ) THEN
3559 CALL pb_zlaset( 'Lower', m-1, m-1, 0, rogue, rogue,
3560 $ a( ia+1+(ja-1)*desca( m_ ) ),
3561 $ desca( m_ ) )
3562 ELSE
3563 CALL pb_zlaset( 'Lower', m, m, 0, rogue, one,
3564 $ a( ia+(ja-1)*desca( m_ ) ),
3565 $ desca( m_ ) )
3566 END IF
3567 END IF
3568 CALL pzchkmin( err, m, m, a, pa, ia, ja, desca, ierr( 1 ) )
3569 ELSE
3570 IF( lsame( uplo, 'L' ) ) THEN
3571 IF( lsame( diag, 'N' ) ) THEN
3572 CALL pb_zlaset( 'Upper', n-1, n-1, 0, rogue, rogue,
3573 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
3574 ELSE
3575 CALL pb_zlaset( 'Upper', n, n, 0, rogue, one,
3576 $ a( ia+(ja-1)*desca( m_ ) ),
3577 $ desca( m_ ) )
3578 END IF
3579 ELSE
3580 IF( lsame( diag, 'N' ) ) THEN
3581 CALL pb_zlaset( 'Lower', n-1, n-1, 0, rogue, rogue,
3582 $ a( ia+1+(ja-1)*desca( m_ ) ),
3583 $ desca( m_ ) )
3584 ELSE
3585 CALL pb_zlaset( 'Lower', n, n, 0, rogue, one,
3586 $ a( ia+(ja-1)*desca( m_ ) ),
3587 $ desca( m_ ) )
3588 END IF
3589 END IF
3590 CALL pzchkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
3591 END IF
3592 ELSE IF( nrout.EQ.10 ) THEN
3593*
3594* Test PZGEADD
3595*
3596* Check the resulting matrix C
3597*
3598 CALL pzmmch3( 'All', transa, m, n, alpha, a, ia, ja, desca,
3599 $ beta, c, pc, ic, jc, descc, err, ierr( 3 ) )
3600*
3601* Check the input-only arguments
3602*
3603 IF( lsame( transa, 'N' ) ) THEN
3604 CALL pzchkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
3605 ELSE
3606 CALL pzchkmin( err, n, m, a, pa, ia, ja, desca, ierr( 1 ) )
3607 END IF
3608*
3609 ELSE IF( nrout.EQ.11 ) THEN
3610*
3611* Test PZTRADD
3612*
3613* Check the resulting matrix C
3614*
3615 CALL pzmmch3( uplo, transa, m, n, alpha, a, ia, ja, desca,
3616 $ beta, c, pc, ic, jc, descc, err, ierr( 3 ) )
3617*
3618* Check the input-only arguments
3619*
3620 IF( lsame( transa, 'N' ) ) THEN
3621 CALL pzchkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
3622 ELSE
3623 CALL pzchkmin( err, n, m, a, pa, ia, ja, desca, ierr( 1 ) )
3624 END IF
3625*
3626 END IF
3627*
3628 IF( ierr( 1 ).NE.0 ) THEN
3629 info = info + 1
3630 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3631 $ WRITE( nout, fmt = 9999 ) 'A'
3632 END IF
3633*
3634 IF( ierr( 2 ).NE.0 ) THEN
3635 info = info + 2
3636 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3637 $ WRITE( nout, fmt = 9999 ) 'B'
3638 END IF
3639*
3640 IF( ierr( 3 ).NE.0 ) THEN
3641 info = info + 4
3642 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
3643 $ WRITE( nout, fmt = 9999 ) 'C'
3644 END IF
3645*
3646 9999 FORMAT( 2x, ' ***** ERROR: Matrix operand ', a,
3647 $ ' is incorrect.' )
3648 9998 FORMAT( 2x, ' ***** FATAL ERROR - Computed result is less ',
3649 $ 'than half accurate *****' )
3650 9997 FORMAT( 2x, ' ***** Test completed with maximum test ratio: ',
3651 $ f11.5, ' SUSPECT *****' )
3652*
3653 RETURN
3654*
3655* End of PZBLAS3TSTCHK
3656*
3657 END
the
end diagonal values have been computed in the(sparse) matrix id.SOL
alpha
#define alpha
Definition eval.h:35
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
ztrsm
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
pb_zlaset
subroutine pb_zlaset(uplo, m, n, ioffd, alpha, beta, a, lda)
Definition pzblastst.f:10049
pzmmch
subroutine pzmmch(ictxt, transa, transb, m, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pzblastst.f:5336
pzmmch2
subroutine pzmmch2(ictxt, uplo, trans, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, pc, ic, jc, descc, ct, g, err, info)
Definition pzblastst.f:6169
pzmmch3
subroutine pzmmch3(uplo, trans, m, n, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, err, info)
Definition pzblastst.f:6585
pzchkmin
subroutine pzchkmin(errmax, m, n, a, pa, ia, ja, desca, info)
Definition pzblastst.f:3332