SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
•All Classes Files Functions Variables Typedefs Macros
pdblas3tim.f
Go to the documentation of this file.
1 BLOCK DATA
2 INTEGER NSUBS
3 parameter(nsubs = 8)
4 CHARACTER*7 SNAMES( NSUBS )
5 COMMON /snamec/snames
6 DATA snames/'PDGEMM ', 'PDSYMM ', 'PDSYRK ',
7 $ 'PDSYR2K', 'PDTRMM ', 'PDTRSM ',
8 $ 'PDGEADD', 'PDTRADD'/
9 END BLOCK DATA
10
11 PROGRAM pdbla3tim
12*
13* -- PBLAS timing driver (version 2.0.2) --
14* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
15* May 1 2012
16*
17* Purpose
18* =======
19*
20* PDBLA3TIM is the main timing program for the Level 3 PBLAS routines.
21*
22* The program must be driven by a short data file. An annotated exam-
23* ple of a data file can be obtained by deleting the first 3 characters
24* from the following 56 lines:
25* 'Level 3 PBLAS, Timing input file'
26* 'Intel iPSC/860 hypercube, gamma model.'
27* 'PDBLAS3TIM.SUMM' output file name (if any)
28* 6 device out
29* 10 value of the logical computational blocksize NB
30* 1 number of process grids (ordered pairs of P & Q)
31* 2 2 1 4 2 3 8 values of P
32* 2 2 4 1 3 2 1 values of Q
33* 1.0D0 value of ALPHA
34* 1.0D0 value of BETA
35* 2 number of tests problems
36* 'N' 'U' values of DIAG
37* 'L' 'R' values of SIDE
38* 'N' 'T' values of TRANSA
39* 'N' 'T' values of TRANSB
40* 'U' 'L' values of UPLO
41* 3 4 values of M
42* 3 4 values of N
43* 3 4 values of K
44* 6 10 values of M_A
45* 6 10 values of N_A
46* 2 5 values of IMB_A
47* 2 5 values of INB_A
48* 2 5 values of MB_A
49* 2 5 values of NB_A
50* 0 1 values of RSRC_A
51* 0 0 values of CSRC_A
52* 1 1 values of IA
53* 1 1 values of JA
54* 6 10 values of M_B
55* 6 10 values of N_B
56* 2 5 values of IMB_B
57* 2 5 values of INB_B
58* 2 5 values of MB_B
59* 2 5 values of NB_B
60* 0 1 values of RSRC_B
61* 0 0 values of CSRC_B
62* 1 1 values of IB
63* 1 1 values of JB
64* 6 10 values of M_C
65* 6 10 values of N_C
66* 2 5 values of IMB_C
67* 2 5 values of INB_C
68* 2 5 values of MB_C
69* 2 5 values of NB_C
70* 0 1 values of RSRC_C
71* 0 0 values of CSRC_C
72* 1 1 values of IC
73* 1 1 values of JC
74* PDGEMM T put F for no test in the same column
75* PDSYMM T put F for no test in the same column
76* PDSYRK T put F for no test in the same column
77* PDSYR2K T put F for no test in the same column
78* PDTRMM T put F for no test in the same column
79* PDTRSM T put F for no test in the same column
80* PDGEADD T put F for no test in the same column
81* PDTRADD T put F for no test in the same column
82*
83* Internal Parameters
84* ===================
85*
86* TOTMEM INTEGER
87* TOTMEM is a machine-specific parameter indicating the maxi-
88* mum amount of available memory per process in bytes. The
89* user should customize TOTMEM to his platform. Remember to
90* leave room in memory for the operating system, the BLACS
91* buffer, etc. For example, on a system with 8 MB of memory
92* per process (e.g., one processor on an Intel iPSC/860), the
93* parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS,
94* code, BLACS buffer, etc). However, for PVM, we usually set
95* TOTMEM = 2000000. Some experimenting with the maximum value
96* of TOTMEM may be required. By default, TOTMEM is 2000000.
97*
98* DBLESZ INTEGER
99* DBLESZ indicates the length in bytes on the given platform
100* for a double precision real. By default, DBLESZ is set to
101* eight.
102*
103* MEM DOUBLE PRECISION array
104* MEM is an array of dimension TOTMEM / DBLESZ.
105* All arrays used by SCALAPACK routines are allocated from this
106* array MEM and referenced by pointers. The integer IPA, for
107* example, is a pointer to the starting element of MEM for the
108* matrix A.
109*
110* -- Written on April 1, 1998 by
111* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
112*
113* =====================================================================
114*
115* .. Parameters ..
116 INTEGER maxtests, maxgrids, dblesz, totmem, memsiz,
117 $ nsubs
118 DOUBLE PRECISION one
119 parameter( maxtests = 20, maxgrids = 20, dblesz = 8,
120 $ one = 1.0d+0, totmem = 2000000, nsubs = 8,
121 $ memsiz = totmem / dblesz )
122 INTEGER block_cyclic_2d_inb, csrc_, ctxt_, dlen_,
123 $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
124 $ rsrc_
125 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
126 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
127 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
128 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
129* ..
130* .. Local Scalars ..
131 CHARACTER*1 adiagdo, aform, cform, diag, side, transa,
132 $ transb, uplo
133 INTEGER csrca, csrcb, csrcc, i, ia, iam, iaseed, ib,
134 $ ibseed, ic, icseed, ictxt, imba, imbb, imbc,
135 $ imida, imidb, imidc, inba, inbb, inbc, ipa,
136 $ ipb, ipc, iposta, ipostb, ipostc, iprea, ipreb,
137 $ iprec, j, ja, jb, jc, k, l, m, ma, mb, mba,
138 $ mbb, mbc, mc, memreqd, mpa, mpb, mpc, mycol,
139 $ myrow, n, na, nb, nba, nbb, nbc, nc, ncola,
140 $ ncolb, ncolc, ngrids, nout, npcol, nprocs,
141 $ nprow, nqa, nqb, nqc, nrowa, nrowb, nrowc,
142 $ ntests, offda, offdc, rsrca, rsrcb, rsrcc
143 DOUBLE PRECISION alpha, beta, cflops, nops, scale, wflops
144* ..
145* .. Local Arrays ..
146 LOGICAL ltest( nsubs ), bcheck( nsubs ),
147 $ ccheck( nsubs )
148 CHARACTER*1 diagval( maxtests ), sideval( maxtests ),
149 $ trnaval( maxtests ), trnbval( maxtests ),
150 $ uploval( maxtests )
151 CHARACTER*80 outfile
152 INTEGER cscaval( maxtests ), cscbval( maxtests ),
153 $ csccval( maxtests ), desca( dlen_ ),
154 $ descb( dlen_ ), descc( dlen_ ),
155 $ iaval( maxtests ), ibval( maxtests ),
156 $ icval( maxtests ), ierr( 3 ),
157 $ imbaval( maxtests ), imbbval( maxtests ),
158 $ imbcval( maxtests ), inbaval( maxtests ),
159 $ inbbval( maxtests ), inbcval( maxtests ),
160 $ javal( maxtests ), jbval( maxtests ),
161 $ jcval( maxtests ), kval( maxtests ),
162 $ maval( maxtests ), mbaval( maxtests ),
163 $ mbbval( maxtests ), mbcval( maxtests ),
164 $ mbval( maxtests ), mcval( maxtests ),
165 $ mval( maxtests ), naval( maxtests ),
166 $ nbaval( maxtests ), nbbval( maxtests ),
167 $ nbcval( maxtests ), nbval( maxtests ),
168 $ ncval( maxtests ), nval( maxtests ),
169 $ pval( maxtests ), qval( maxtests ),
170 $ rscaval( maxtests ), rscbval( maxtests ),
171 $ rsccval( maxtests )
172 DOUBLE PRECISION ctime( 1 ), mem( memsiz ), wtime( 1 )
173* ..
174* .. External Subroutines ..
175 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
176 $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
177 $ blacs_pinfo, igsum2d, pb_boot, pb_combine,
178 $ pb_timer, pdbla3timinfo, pdgeadd, pdgemm,
179 $ pdlagen, pdlascal, pdsymm, pdsyr2k, pdsyrk,
180 $ pdtradd, pdtrmm, pdtrsm, pmdescchk, pmdimchk
181* ..
182* .. External Functions ..
183 LOGICAL lsame
184 DOUBLE PRECISION pdopbl3
185 EXTERNAL lsame, pdopbl3
186* ..
187* .. Intrinsic Functions ..
188 INTRINSIC dble, max
189* ..
190* .. Common Blocks ..
191 CHARACTER*7 snames( nsubs )
192 LOGICAL abrtflg
193 INTEGER info, nblog
194 COMMON /snamec/snames
195 COMMON /infoc/info, nblog
196 COMMON /pberrorc/nout, abrtflg
197* ..
198* .. Data Statements ..
199 DATA bcheck/.true., .true., .false., .true., .true.,
200 $ .true., .false., .false./
201 DATA ccheck/.true., .true., .true., .true., .false.,
202 $ .false., .true., .true./
203* ..
204* .. Executable Statements ..
205*
206* Initialization
207*
208* Set flag so that the PBLAS error handler won't abort on errors, so
209* that the tester will detect unsupported operations.
210*
211 abrtflg = .false.
212*
213* Seeds for random matrix generations.
214*
215 iaseed = 100
216 ibseed = 200
217 icseed = 300
218*
219* Get starting information
220*
221 CALL blacs_pinfo( iam, nprocs )
222 CALL pdbla3timinfo( outfile, nout, ntests, diagval, sideval,
223 $ trnaval, trnbval, uploval, mval, nval,
224 $ kval, maval, naval, imbaval, mbaval,
225 $ inbaval, nbaval, rscaval, cscaval, iaval,
226 $ javal, mbval, nbval, imbbval, mbbval,
227 $ inbbval, nbbval, rscbval, cscbval, ibval,
228 $ jbval, mcval, ncval, imbcval, mbcval,
229 $ inbcval, nbcval, rsccval, csccval, icval,
230 $ jcval, maxtests, ngrids, pval, maxgrids,
231 $ qval, maxgrids, nblog, ltest, iam, nprocs,
232 $ alpha, beta, mem )
233*
234 IF( iam.EQ.0 )
235 $ WRITE( nout, fmt = 9984 )
236*
237* Loop over different process grids
238*
239 DO 60 i = 1, ngrids
240*
241 nprow = pval( i )
242 npcol = qval( i )
243*
244* Make sure grid information is correct
245*
246 ierr( 1 ) = 0
247 IF( nprow.LT.1 ) THEN
248 IF( iam.EQ.0 )
249 $ WRITE( nout, fmt = 9999 ) 'GRID SIZE', 'NPROW', nprow
250 ierr( 1 ) = 1
251 ELSE IF( npcol.LT.1 ) THEN
252 IF( iam.EQ.0 )
253 $ WRITE( nout, fmt = 9999 ) 'GRID SIZE', 'NPCOL', npcol
254 ierr( 1 ) = 1
255 ELSE IF( nprow*npcol.GT.nprocs ) THEN
256 IF( iam.EQ.0 )
257 $ WRITE( nout, fmt = 9998 ) nprow*npcol, nprocs
258 ierr( 1 ) = 1
259 END IF
260*
261 IF( ierr( 1 ).GT.0 ) THEN
262 IF( iam.EQ.0 )
263 $ WRITE( nout, fmt = 9997 ) 'GRID'
264 GO TO 60
265 END IF
266*
267* Define process grid
268*
269 CALL blacs_get( -1, 0, ictxt )
270 CALL blacs_gridinit( ictxt, 'Row-major', nprow, npcol )
271 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
272*
273* Go to bottom of process grid loop if this case doesn't use my
274* process
275*
276 IF( myrow.GE.nprow .OR. mycol.GE.npcol )
277 $ GO TO 60
278*
279* Loop over number of tests
280*
281 DO 50 j = 1, ntests
282*
283* Get the test parameters
284*
285 diag = diagval( j )
286 side = sideval( j )
287 transa = trnaval( j )
288 transb = trnbval( j )
289 uplo = uploval( j )
290*
291 m = mval( j )
292 n = nval( j )
293 k = kval( j )
294*
295 ma = maval( j )
296 na = naval( j )
297 imba = imbaval( j )
298 mba = mbaval( j )
299 inba = inbaval( j )
300 nba = nbaval( j )
301 rsrca = rscaval( j )
302 csrca = cscaval( j )
303 ia = iaval( j )
304 ja = javal( j )
305*
306 mb = mbval( j )
307 nb = nbval( j )
308 imbb = imbbval( j )
309 mbb = mbbval( j )
310 inbb = inbbval( j )
311 nbb = nbbval( j )
312 rsrcb = rscbval( j )
313 csrcb = cscbval( j )
314 ib = ibval( j )
315 jb = jbval( j )
316*
317 mc = mcval( j )
318 nc = ncval( j )
319 imbc = imbcval( j )
320 mbc = mbcval( j )
321 inbc = inbcval( j )
322 nbc = nbcval( j )
323 rsrcc = rsccval( j )
324 csrcc = csccval( j )
325 ic = icval( j )
326 jc = jcval( j )
327*
328 IF( iam.EQ.0 ) THEN
329*
330 WRITE( nout, fmt = * )
331 WRITE( nout, fmt = 9996 ) j, nprow, npcol
332 WRITE( nout, fmt = * )
333*
334 WRITE( nout, fmt = 9995 )
335 WRITE( nout, fmt = 9994 )
336 WRITE( nout, fmt = 9995 )
337 WRITE( nout, fmt = 9993 ) m, n, k, side, uplo, transa,
338 $ transb, diag
339*
340 WRITE( nout, fmt = 9995 )
341 WRITE( nout, fmt = 9992 )
342 WRITE( nout, fmt = 9995 )
343 WRITE( nout, fmt = 9991 ) ia, ja, ma, na, imba, inba,
344 $ mba, nba, rsrca, csrca
345*
346 WRITE( nout, fmt = 9995 )
347 WRITE( nout, fmt = 9990 )
348 WRITE( nout, fmt = 9995 )
349 WRITE( nout, fmt = 9991 ) ib, jb, mb, nb, imbb, inbb,
350 $ mbb, nbb, rsrcb, csrcb
351*
352 WRITE( nout, fmt = 9995 )
353 WRITE( nout, fmt = 9989 )
354 WRITE( nout, fmt = 9995 )
355 WRITE( nout, fmt = 9991 ) ic, jc, mc, nc, imbc, inbc,
356 $ mbc, nbc, rsrcc, csrcc
357*
358 WRITE( nout, fmt = 9995 )
359 WRITE( nout, fmt = 9980 )
360*
361 END IF
362*
363* Check the validity of the input test parameters
364*
365 IF( .NOT.lsame( side, 'L' ).AND.
366 $ .NOT.lsame( side, 'R' ) ) THEN
367 IF( iam.EQ.0 )
368 $ WRITE( nout, fmt = 9997 ) 'SIDE'
369 GO TO 40
370 END IF
371*
372 IF( .NOT.lsame( uplo, 'U' ).AND.
373 $ .NOT.lsame( uplo, 'L' ) ) THEN
374 IF( iam.EQ.0 )
375 $ WRITE( nout, fmt = 9997 ) 'UPLO'
376 GO TO 40
377 END IF
378*
379 IF( .NOT.lsame( transa, 'N' ).AND.
380 $ .NOT.lsame( transa, 'T' ).AND.
381 $ .NOT.lsame( transa, 'C' ) ) THEN
382 IF( iam.EQ.0 )
383 $ WRITE( nout, fmt = 9997 ) 'TRANSA'
384 GO TO 40
385 END IF
386*
387 IF( .NOT.lsame( transb, 'N' ).AND.
388 $ .NOT.lsame( transb, 'T' ).AND.
389 $ .NOT.lsame( transb, 'C' ) ) THEN
390 IF( iam.EQ.0 )
391 $ WRITE( nout, fmt = 9997 ) 'TRANSB'
392 GO TO 40
393 END IF
394*
395 IF( .NOT.lsame( diag , 'U' ).AND.
396 $ .NOT.lsame( diag , 'N' ) )THEN
397 IF( iam.EQ.0 )
398 $ WRITE( nout, fmt = 9997 ) 'DIAG'
399 GO TO 40
400 END IF
401*
402* Check and initialize the matrix descriptors
403*
404 CALL pmdescchk( ictxt, nout, 'A', desca,
405 $ block_cyclic_2d_inb, ma, na, imba, inba,
406 $ mba, nba, rsrca, csrca, mpa, nqa, iprea,
407 $ imida, iposta, 0, 0, ierr( 1 ) )
408*
409 CALL pmdescchk( ictxt, nout, 'B', descb,
410 $ block_cyclic_2d_inb, mb, nb, imbb, inbb,
411 $ mbb, nbb, rsrcb, csrcb, mpb, nqb, ipreb,
412 $ imidb, ipostb, 0, 0, ierr( 2 ) )
413*
414 CALL pmdescchk( ictxt, nout, 'C', descc,
415 $ block_cyclic_2d_inb, mc, nc, imbc, inbc,
416 $ mbc, nbc, rsrcc, csrcc, mpc, nqc, iprec,
417 $ imidc, ipostc, 0, 0, ierr( 3 ) )
418*
419 IF( ierr( 1 ).GT.0 .OR. ierr( 2 ).GT.0 .OR.
420 $ ierr( 3 ).GT.0 ) THEN
421 GO TO 40
422 END IF
423*
424* Assign pointers into MEM for matrices corresponding to
425* the distributed matrices A, X and Y.
426*
427 ipa = iprea + 1
428 ipb = ipa + desca( lld_ )*nqa
429 ipc = ipb + descb( lld_ )*nqb
430*
431* Check if sufficient memory.
432*
433 memreqd = ipc + descc( lld_ )*nqc - 1
434 ierr( 1 ) = 0
435 IF( memreqd.GT.memsiz ) THEN
436 IF( iam.EQ.0 )
437 $ WRITE( nout, fmt = 9987 ) memreqd*dblesz
438 ierr( 1 ) = 1
439 END IF
440*
441* Check all processes for an error
442*
443 CALL igsum2d( ictxt, 'All', ' ', 1, 1, ierr, 1, -1, 0 )
444*
445 IF( ierr( 1 ).GT.0 ) THEN
446 IF( iam.EQ.0 )
447 $ WRITE( nout, fmt = 9988 )
448 GO TO 40
449 END IF
450*
451* Loop over all PBLAS 3 routines
452*
453 DO 30 l = 1, nsubs
454*
455* Continue only if this subroutine has to be tested.
456*
457 IF( .NOT.ltest( l ) )
458 $ GO TO 30
459*
460* Define the size of the operands
461*
462 IF( l.EQ.1 ) THEN
463*
464* PDGEMM
465*
466 nrowc = m
467 ncolc = n
468 IF( lsame( transa, 'N' ) ) THEN
469 nrowa = m
470 ncola = k
471 ELSE
472 nrowa = k
473 ncola = m
474 END IF
475 IF( lsame( transb, 'N' ) ) THEN
476 nrowb = k
477 ncolb = n
478 ELSE
479 nrowb = n
480 ncolb = k
481 END IF
482 ELSE IF( l.EQ.2 ) THEN
483*
484* PDSYMM
485*
486 nrowc = m
487 ncolc = n
488 nrowb = m
489 ncolb = n
490 IF( lsame( side, 'L' ) ) THEN
491 nrowa = m
492 ncola = m
493 ELSE
494 nrowa = n
495 ncola = n
496 END IF
497 ELSE IF( l.EQ.3 ) THEN
498*
499* PDSYRK
500*
501 nrowc = n
502 ncolc = n
503 IF( lsame( transa, 'N' ) ) THEN
504 nrowa = n
505 ncola = k
506 ELSE
507 nrowa = k
508 ncola = n
509 END IF
510 nrowb = 0
511 ncolb = 0
512 ELSE IF( l.EQ.4 ) THEN
513*
514* PDSYR2K
515*
516 nrowc = n
517 ncolc = n
518 IF( lsame( transa, 'N' ) ) THEN
519 nrowa = n
520 ncola = k
521 nrowb = n
522 ncolb = k
523 ELSE
524 nrowa = k
525 ncola = n
526 nrowb = k
527 ncolb = n
528 END IF
529 ELSE IF( l.EQ.5 .OR. l.EQ.6 ) THEN
530*
531* PDTRMM, PDTRSM
532*
533 nrowb = m
534 ncolb = n
535 IF( lsame( side, 'L' ) ) THEN
536 nrowa = m
537 ncola = m
538 ELSE
539 nrowa = n
540 ncola = n
541 END IF
542 nrowc = 0
543 ncolc = 0
544 ELSE IF( l.EQ.7 .OR. l.EQ.8 ) THEN
545*
546* PDGEADD, PDTRADD
547*
548 IF( lsame( transa, 'N' ) ) THEN
549 nrowa = m
550 ncola = n
551 ELSE
552 nrowa = n
553 ncola = m
554 END IF
555 nrowc = m
556 ncolc = n
557 nrowb = 0
558 ncolb = 0
559*
560 END IF
561*
562* Check the validity of the operand sizes
563*
564 CALL pmdimchk( ictxt, nout, nrowa, ncola, 'A', ia, ja,
565 $ desca, ierr( 1 ) )
566 CALL pmdimchk( ictxt, nout, nrowb, ncolb, 'B', ib, jb,
567 $ descb, ierr( 2 ) )
568 CALL pmdimchk( ictxt, nout, nrowc, ncolc, 'C', ic, jc,
569 $ descc, ierr( 3 ) )
570*
571 IF( ierr( 1 ).NE.0 .OR. ierr( 2 ).NE.0 .OR.
572 $ ierr( 3 ).NE.0 ) THEN
573 GO TO 30
574 END IF
575*
576* Generate distributed matrices A, B and C
577*
578 IF( l.EQ.2 ) THEN
579*
580* PDSYMM
581*
582 aform = 'S'
583 adiagdo = 'N'
584 offda = ia - ja
585 cform = 'N'
586 offdc = 0
587*
588 ELSE IF( l.EQ.3 .OR. l.EQ.4 ) THEN
589*
590* PDSYRK, PDSYR2K
591*
592 aform = 'N'
593 adiagdo = 'N'
594 offda = 0
595 cform = 'S'
596 offdc = ic - jc
597*
598 ELSE IF( ( l.EQ.6 ).AND.( lsame( diag, 'N' ) ) ) THEN
599*
600* PDTRSM
601*
602 aform = 'N'
603 adiagdo = 'D'
604 offda = ia - ja
605 cform = 'N'
606 offdc = 0
607*
608 ELSE
609*
610* Default values
611*
612 aform = 'N'
613 adiagdo = 'N'
614 offda = 0
615 cform = 'N'
616 offdc = 0
617*
618 END IF
619*
620 CALL pdlagen( .false., aform, adiagdo, offda, ma, na,
621 $ 1, 1, desca, iaseed, mem( ipa ),
622 $ desca( lld_ ) )
623 IF( ( l.EQ.6 ).AND.( .NOT.( lsame( diag, 'N' ) ) ).AND.
624 $ ( max( nrowa, ncola ).GT.1 ) ) THEN
625 scale = one / dble( max( nrowa, ncola ) )
626 IF( lsame( uplo, 'L' ) ) THEN
627 CALL pdlascal( 'Lower', nrowa-1, ncola-1, scale,
628 $ mem( ipa ), ia+1, ja, desca )
629 ELSE
630 CALL pdlascal( 'Upper', nrowa-1, ncola-1, scale,
631 $ mem( ipa ), ia, ja+1, desca )
632 END IF
633*
634 END IF
635*
636 IF( bcheck( l ) )
637 $ CALL pdlagen( .false., 'None', 'No diag', 0, mb, nb,
638 $ 1, 1, descb, ibseed, mem( ipb ),
639 $ descb( lld_ ) )
640*
641 IF( ccheck( l ) )
642 $ CALL pdlagen( .false., cform, 'No diag', offdc, mc,
643 $ nc, 1, 1, descc, icseed, mem( ipc ),
644 $ descc( lld_ ) )
645*
646 info = 0
647 CALL pb_boot()
648 CALL blacs_barrier( ictxt, 'All' )
649*
650* Call the Level 3 PBLAS routine
651*
652 IF( l.EQ.1 ) THEN
653*
654* Test PDGEMM
655*
656 nops = pdopbl3( snames( l ), m, n, k )
657*
658 CALL pb_timer( 1 )
659 CALL pdgemm( transa, transb, m, n, k, alpha,
660 $ mem( ipa ), ia, ja, desca, mem( ipb ),
661 $ ib, jb, descb, beta, mem( ipc ), ic, jc,
662 $ descc )
663 CALL pb_timer( 1 )
664*
665 ELSE IF( l.EQ.2 ) THEN
666*
667* Test PDSYMM
668*
669 IF( lsame( side, 'L' ) ) THEN
670 nops = pdopbl3( snames( l ), m, n, 0 )
671 ELSE
672 nops = pdopbl3( snames( l ), m, n, 1 )
673 END IF
674*
675 CALL pb_timer( 1 )
676 CALL pdsymm( side, uplo, m, n, alpha, mem( ipa ), ia,
677 $ ja, desca, mem( ipb ), ib, jb, descb,
678 $ beta, mem( ipc ), ic, jc, descc )
679 CALL pb_timer( 1 )
680*
681 ELSE IF( l.EQ.3 ) THEN
682*
683* Test PDSYRK
684*
685 nops = pdopbl3( snames( l ), n, n, k )
686*
687 CALL pb_timer( 1 )
688 CALL pdsyrk( uplo, transa, n, k, alpha, mem( ipa ),
689 $ ia, ja, desca, beta, mem( ipc ), ic, jc,
690 $ descc )
691 CALL pb_timer( 1 )
692*
693 ELSE IF( l.EQ.4 ) THEN
694*
695* Test PDSYR2K
696*
697 nops = pdopbl3( snames( l ), n, n, k )
698*
699 CALL pb_timer( 1 )
700 CALL pdsyr2k( uplo, transa, n, k, alpha, mem( ipa ),
701 $ ia, ja, desca, mem( ipb ), ib, jb,
702 $ descb, beta, mem( ipc ), ic, jc,
703 $ descc )
704 CALL pb_timer( 1 )
705*
706 ELSE IF( l.EQ.5 ) THEN
707*
708* Test PDTRMM
709*
710 IF( lsame( side, 'L' ) ) THEN
711 nops = pdopbl3( snames( l ), m, n, 0 )
712 ELSE
713 nops = pdopbl3( snames( l ), m, n, 1 )
714 END IF
715*
716 CALL pb_timer( 1 )
717 CALL pdtrmm( side, uplo, transa, diag, m, n, alpha,
718 $ mem( ipa ), ia, ja, desca, mem( ipb ),
719 $ ib, jb, descb )
720 CALL pb_timer( 1 )
721*
722 ELSE IF( l.EQ.6 ) THEN
723*
724* Test PDTRSM
725*
726 IF( lsame( side, 'L' ) ) THEN
727 nops = pdopbl3( snames( l ), m, n, 0 )
728 ELSE
729 nops = pdopbl3( snames( l ), m, n, 1 )
730 END IF
731*
732 CALL pb_timer( 1 )
733 CALL pdtrsm( side, uplo, transa, diag, m, n, alpha,
734 $ mem( ipa ), ia, ja, desca, mem( ipb ),
735 $ ib, jb, descb )
736 CALL pb_timer( 1 )
737*
738 ELSE IF( l.EQ.7 ) THEN
739*
740* Test PDGEADD
741*
742 nops = pdopbl3( snames( l ), m, n, m )
743*
744 CALL pb_timer( 1 )
745 CALL pdgeadd( transa, m, n, alpha, mem( ipa ), ia, ja,
746 $ desca, beta, mem( ipc ), ic, jc, descc )
747 CALL pb_timer( 1 )
748*
749 ELSE IF( l.EQ.8 ) THEN
750*
751* Test PDTRADD
752*
753 IF( lsame( uplo, 'U' ) ) THEN
754 nops = pdopbl3( snames( l ), m, n, 0 )
755 ELSE
756 nops = pdopbl3( snames( l ), m, n, 1 )
757 END IF
758*
759 CALL pb_timer( 1 )
760 CALL pdtradd( uplo, transa, m, n, alpha, mem( ipa ),
761 $ ia, ja, desca, beta, mem( ipc ), ic, jc,
762 $ descc )
763 CALL pb_timer( 1 )
764*
765 END IF
766*
767* Check if the operation has been performed.
768*
769 IF( info.NE.0 ) THEN
770 IF( iam.EQ.0 )
771 $ WRITE( nout, fmt = 9982 ) info
772 GO TO 30
773 END IF
774*
775 CALL pb_combine( ictxt, 'All', '>', 'W', 1, 1, wtime )
776 CALL pb_combine( ictxt, 'All', '>', 'C', 1, 1, ctime )
777*
778* Only node 0 prints timing test result
779*
780 IF( iam.EQ.0 ) THEN
781*
782* Print WALL time if machine supports it
783*
784 IF( wtime( 1 ).GT.0.0d+0 ) THEN
785 wflops = nops / ( wtime( 1 ) * 1.0d+6 )
786 ELSE
787 wflops = 0.0d+0
788 END IF
789*
790* Print CPU time if machine supports it
791*
792 IF( ctime( 1 ).GT.0.0d+0 ) THEN
793 cflops = nops / ( ctime( 1 ) * 1.0d+6 )
794 ELSE
795 cflops = 0.0d+0
796 END IF
797*
798 WRITE( nout, fmt = 9981 ) snames( l ), wtime( 1 ),
799 $ wflops, ctime( 1 ), cflops
800*
801 END IF
802*
803 30 CONTINUE
804*
805 40 IF( iam.EQ.0 ) THEN
806 WRITE( nout, fmt = 9995 )
807 WRITE( nout, fmt = * )
808 WRITE( nout, fmt = 9986 ) j
809 END IF
810*
811 50 CONTINUE
812*
813 CALL blacs_gridexit( ictxt )
814*
815 60 CONTINUE
816*
817 IF( iam.EQ.0 ) THEN
818 WRITE( nout, fmt = * )
819 WRITE( nout, fmt = 9985 )
820 WRITE( nout, fmt = * )
821 END IF
822*
823 CALL blacs_exit( 0 )
824*
825 9999 FORMAT( 'ILLEGAL ', a, ': ', a, ' = ', i10,
826 $ ' should be at least 1' )
827 9998 FORMAT( 'ILLEGAL GRID: NPROW*NPCOL = ', i4,
828 $ '. It can be at most', i4 )
829 9997 FORMAT( 'Bad ', a, ' parameters: going on to next test case.' )
830 9996 FORMAT( 2x, 'Test number ', i2 , ' started on a ', i4, ' x ',
831 $ i4, ' process grid.' )
832 9995 FORMAT( 2x, ' ------------------------------------------------',
833 $ '-------------------' )
834 9994 FORMAT( 2x, ' M N K SIDE UPLO TRANSA ',
835 $ 'TRANSB DIAG' )
836 9993 FORMAT( 5x,i6,1x,i6,1x,i6,6x,a1,5x,a1,7x,a1,7x,a1,5x,a1 )
837 9992 FORMAT( 2x, ' IA JA MA NA IMBA INBA',
838 $ ' MBA NBA RSRCA CSRCA' )
839 9991 FORMAT( 5x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,
840 $ 1x,i5,1x,i5 )
841 9990 FORMAT( 2x, ' IB JB MB NB IMBB INBB',
842 $ ' MBB NBB RSRCB CSRCB' )
843 9989 FORMAT( 2x, ' IC JC MC NC IMBC INBC',
844 $ ' MBC NBC RSRCC CSRCC' )
845 9988 FORMAT( 'Not enough memory for this test: going on to',
846 $ ' next test case.' )
847 9987 FORMAT( 'Not enough memory. Need: ', i12 )
848 9986 FORMAT( 2x, 'Test number ', i2, ' completed.' )
849 9985 FORMAT( 2x, 'End of Tests.' )
850 9984 FORMAT( 2x, 'Tests started.' )
851 9983 FORMAT( 5x, a, ' ***** ', a, ' has an incorrect value: ',
852 $ ' BYPASS *****' )
853 9982 FORMAT( 2x, ' ***** Operation not supported, error code: ',
854 $ i5, ' *****' )
855 9981 FORMAT( 2x, '| ', a, 2x, f13.3, 2x, f13.3, 2x, f13.3, 2x, f13.3 )
856 9980 FORMAT( 2x, ' WALL time (s) WALL Mflops ',
857 $ ' CPU time (s) CPU Mflops' )
858*
859 stop
860*
861* End of PDBLA3TIM
862*
863 END
864 SUBROUTINE pdbla3timinfo( SUMMRY, NOUT, NMAT, DIAGVAL, SIDEVAL,
865 $ TRNAVAL, TRNBVAL, UPLOVAL, MVAL,
866 $ NVAL, KVAL, MAVAL, NAVAL, IMBAVAL,
867 $ MBAVAL, INBAVAL, NBAVAL, RSCAVAL,
868 $ CSCAVAL, IAVAL, JAVAL, MBVAL, NBVAL,
869 $ IMBBVAL, MBBVAL, INBBVAL, NBBVAL,
870 $ RSCBVAL, CSCBVAL, IBVAL, JBVAL,
871 $ MCVAL, NCVAL, IMBCVAL, MBCVAL,
872 $ INBCVAL, NBCVAL, RSCCVAL, CSCCVAL,
873 $ ICVAL, JCVAL, LDVAL, NGRIDS, PVAL,
874 $ LDPVAL, QVAL, LDQVAL, NBLOG, LTEST,
875 $ IAM, NPROCS, ALPHA, BETA, WORK )
876*
877* -- PBLAS test routine (version 2.0) --
878* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
879* and University of California, Berkeley.
880* April 1, 1998
881*
882* .. Scalar Arguments ..
883 INTEGER IAM, LDPVAL, LDQVAL, LDVAL, NBLOG, NGRIDS,
884 $ NMAT, NOUT, NPROCS
885 DOUBLE PRECISION ALPHA, BETA
886* ..
887* .. Array Arguments ..
888 CHARACTER*( * ) SUMMRY
889 CHARACTER*1 DIAGVAL( LDVAL ), SIDEVAL( LDVAL ),
890 $ TRNAVAL( LDVAL ), TRNBVAL( LDVAL ),
891 $ UPLOVAL( LDVAL )
892 LOGICAL LTEST( * )
893 INTEGER CSCAVAL( LDVAL ), CSCBVAL( LDVAL ),
894 $ csccval( ldval ), iaval( ldval ),
895 $ ibval( ldval ), icval( ldval ),
896 $ imbaval( ldval ), imbbval( ldval ),
897 $ imbcval( ldval ), inbaval( ldval ),
898 $ inbbval( ldval ), inbcval( ldval ),
899 $ javal( ldval ), jbval( ldval ), jcval( ldval ),
900 $ kval( ldval ), maval( ldval ), mbaval( ldval ),
901 $ mbbval( ldval ), mbcval( ldval ),
902 $ mbval( ldval ), mcval( ldval ), mval( ldval ),
903 $ naval( ldval ), nbaval( ldval ),
904 $ nbbval( ldval ), nbcval( ldval ),
905 $ nbval( ldval ), ncval( ldval ), nval( ldval ),
906 $ pval( ldpval ), qval( ldqval ),
907 $ rscaval( ldval ), rscbval( ldval ),
908 $ rsccval( ldval ), work( * )
909* ..
910*
911* Purpose
912* =======
913*
914* PDBLA3TIMINFO get the needed startup information for timing various
915* Level 3 PBLAS routines, and transmits it to all processes.
916*
917* Notes
918* =====
919*
920* For packing the information we assumed that the length in bytes of an
921* integer is equal to the length in bytes of a real single precision.
922*
923* Arguments
924* =========
925*
926* SUMMRY (global output) CHARACTER*(*)
927* On exit, SUMMRY is the name of output (summary) file (if
928* any). SUMMRY is only defined for process 0.
929*
930* NOUT (global output) INTEGER
931* On exit, NOUT specifies the unit number for the output file.
932* When NOUT is 6, output to screen, when NOUT is 0, output to
933* stderr. NOUT is only defined for process 0.
934*
935* NMAT (global output) INTEGER
936* On exit, NMAT specifies the number of different test cases.
937*
938* DIAGVAL (global output) CHARACTER array
939* On entry, DIAGVAL is an array of dimension LDVAL. On exit,
940* this array contains the values of DIAG to run the code with.
941*
942* SIDEVAL (global output) CHARACTER array
943* On entry, SIDEVAL is an array of dimension LDVAL. On exit,
944* this array contains the values of SIDE to run the code with.
945*
946* TRNAVAL (global output) CHARACTER array
947* On entry, TRNAVAL is an array of dimension LDVAL. On exit,
948* this array contains the values of TRANSA to run the code
949* with.
950*
951* TRNBVAL (global output) CHARACTER array
952* On entry, TRNBVAL is an array of dimension LDVAL. On exit,
953* this array contains the values of TRANSB to run the code
954* with.
955*
956* UPLOVAL (global output) CHARACTER array
957* On entry, UPLOVAL is an array of dimension LDVAL. On exit,
958* this array contains the values of UPLO to run the code with.
959*
960* MVAL (global output) INTEGER array
961* On entry, MVAL is an array of dimension LDVAL. On exit, this
962* array contains the values of M to run the code with.
963*
964* NVAL (global output) INTEGER array
965* On entry, NVAL is an array of dimension LDVAL. On exit, this
966* array contains the values of N to run the code with.
967*
968* KVAL (global output) INTEGER array
969* On entry, KVAL is an array of dimension LDVAL. On exit, this
970* array contains the values of K to run the code with.
971*
972* MAVAL (global output) INTEGER array
973* On entry, MAVAL is an array of dimension LDVAL. On exit, this
974* array contains the values of DESCA( M_ ) to run the code
975* with.
976*
977* NAVAL (global output) INTEGER array
978* On entry, NAVAL is an array of dimension LDVAL. On exit, this
979* array contains the values of DESCA( N_ ) to run the code
980* with.
981*
982* IMBAVAL (global output) INTEGER array
983* On entry, IMBAVAL is an array of dimension LDVAL. On exit,
984* this array contains the values of DESCA( IMB_ ) to run the
985* code with.
986*
987* MBAVAL (global output) INTEGER array
988* On entry, MBAVAL is an array of dimension LDVAL. On exit,
989* this array contains the values of DESCA( MB_ ) to run the
990* code with.
991*
992* INBAVAL (global output) INTEGER array
993* On entry, INBAVAL is an array of dimension LDVAL. On exit,
994* this array contains the values of DESCA( INB_ ) to run the
995* code with.
996*
997* NBAVAL (global output) INTEGER array
998* On entry, NBAVAL is an array of dimension LDVAL. On exit,
999* this array contains the values of DESCA( NB_ ) to run the
1000* code with.
1001*
1002* RSCAVAL (global output) INTEGER array
1003* On entry, RSCAVAL is an array of dimension LDVAL. On exit,
1004* this array contains the values of DESCA( RSRC_ ) to run the
1005* code with.
1006*
1007* CSCAVAL (global output) INTEGER array
1008* On entry, CSCAVAL is an array of dimension LDVAL. On exit,
1009* this array contains the values of DESCA( CSRC_ ) to run the
1010* code with.
1011*
1012* IAVAL (global output) INTEGER array
1013* On entry, IAVAL is an array of dimension LDVAL. On exit, this
1014* array contains the values of IA to run the code with.
1015*
1016* JAVAL (global output) INTEGER array
1017* On entry, JAVAL is an array of dimension LDVAL. On exit, this
1018* array contains the values of JA to run the code with.
1019*
1020* MBVAL (global output) INTEGER array
1021* On entry, MBVAL is an array of dimension LDVAL. On exit, this
1022* array contains the values of DESCB( M_ ) to run the code
1023* with.
1024*
1025* NBVAL (global output) INTEGER array
1026* On entry, NBVAL is an array of dimension LDVAL. On exit, this
1027* array contains the values of DESCB( N_ ) to run the code
1028* with.
1029*
1030* IMBBVAL (global output) INTEGER array
1031* On entry, IMBBVAL is an array of dimension LDVAL. On exit,
1032* this array contains the values of DESCB( IMB_ ) to run the
1033* code with.
1034*
1035* MBBVAL (global output) INTEGER array
1036* On entry, MBBVAL is an array of dimension LDVAL. On exit,
1037* this array contains the values of DESCB( MB_ ) to run the
1038* code with.
1039*
1040* INBBVAL (global output) INTEGER array
1041* On entry, INBBVAL is an array of dimension LDVAL. On exit,
1042* this array contains the values of DESCB( INB_ ) to run the
1043* code with.
1044*
1045* NBBVAL (global output) INTEGER array
1046* On entry, NBBVAL is an array of dimension LDVAL. On exit,
1047* this array contains the values of DESCB( NB_ ) to run the
1048* code with.
1049*
1050* RSCBVAL (global output) INTEGER array
1051* On entry, RSCBVAL is an array of dimension LDVAL. On exit,
1052* this array contains the values of DESCB( RSRC_ ) to run the
1053* code with.
1054*
1055* CSCBVAL (global output) INTEGER array
1056* On entry, CSCBVAL is an array of dimension LDVAL. On exit,
1057* this array contains the values of DESCB( CSRC_ ) to run the
1058* code with.
1059*
1060* IBVAL (global output) INTEGER array
1061* On entry, IBVAL is an array of dimension LDVAL. On exit, this
1062* array contains the values of IB to run the code with.
1063*
1064* JBVAL (global output) INTEGER array
1065* On entry, JBVAL is an array of dimension LDVAL. On exit, this
1066* array contains the values of JB to run the code with.
1067*
1068* MCVAL (global output) INTEGER array
1069* On entry, MCVAL is an array of dimension LDVAL. On exit, this
1070* array contains the values of DESCC( M_ ) to run the code
1071* with.
1072*
1073* NCVAL (global output) INTEGER array
1074* On entry, NCVAL is an array of dimension LDVAL. On exit, this
1075* array contains the values of DESCC( N_ ) to run the code
1076* with.
1077*
1078* IMBCVAL (global output) INTEGER array
1079* On entry, IMBCVAL is an array of dimension LDVAL. On exit,
1080* this array contains the values of DESCC( IMB_ ) to run the
1081* code with.
1082*
1083* MBCVAL (global output) INTEGER array
1084* On entry, MBCVAL is an array of dimension LDVAL. On exit,
1085* this array contains the values of DESCC( MB_ ) to run the
1086* code with.
1087*
1088* INBCVAL (global output) INTEGER array
1089* On entry, INBCVAL is an array of dimension LDVAL. On exit,
1090* this array contains the values of DESCC( INB_ ) to run the
1091* code with.
1092*
1093* NBCVAL (global output) INTEGER array
1094* On entry, NBCVAL is an array of dimension LDVAL. On exit,
1095* this array contains the values of DESCC( NB_ ) to run the
1096* code with.
1097*
1098* RSCCVAL (global output) INTEGER array
1099* On entry, RSCCVAL is an array of dimension LDVAL. On exit,
1100* this array contains the values of DESCC( RSRC_ ) to run the
1101* code with.
1102*
1103* CSCCVAL (global output) INTEGER array
1104* On entry, CSCCVAL is an array of dimension LDVAL. On exit,
1105* this array contains the values of DESCC( CSRC_ ) to run the
1106* code with.
1107*
1108* ICVAL (global output) INTEGER array
1109* On entry, ICVAL is an array of dimension LDVAL. On exit, this
1110* array contains the values of IC to run the code with.
1111*
1112* JCVAL (global output) INTEGER array
1113* On entry, JCVAL is an array of dimension LDVAL. On exit, this
1114* array contains the values of JC to run the code with.
1115*
1116* LDVAL (global input) INTEGER
1117* On entry, LDVAL specifies the maximum number of different va-
1118* lues that can be used for DIAG, SIDE, TRANSA, TRANSB, UPLO,
1119* M, N, K, DESCA(:), IA, JA, DESCB(:), IB, JB, DESCC(:), IC,
1120* JC. This is also the maximum number of test cases.
1121*
1122* NGRIDS (global output) INTEGER
1123* On exit, NGRIDS specifies the number of different values that
1124* can be used for P and Q.
1125*
1126* PVAL (global output) INTEGER array
1127* On entry, PVAL is an array of dimension LDPVAL. On exit, this
1128* array contains the values of P to run the code with.
1129*
1130* LDPVAL (global input) INTEGER
1131* On entry, LDPVAL specifies the maximum number of different
1132* values that can be used for P.
1133*
1134* QVAL (global output) INTEGER array
1135* On entry, QVAL is an array of dimension LDQVAL. On exit, this
1136* array contains the values of Q to run the code with.
1137*
1138* LDQVAL (global input) INTEGER
1139* On entry, LDQVAL specifies the maximum number of different
1140* values that can be used for Q.
1141*
1142* NBLOG (global output) INTEGER
1143* On exit, NBLOG specifies the logical computational block size
1144* to run the tests with. NBLOG must be at least one.
1145*
1146* LTEST (global output) LOGICAL array
1147* On entry, LTEST is an array of dimension at least eight. On
1148* exit, if LTEST( i ) is .TRUE., the i-th Level 3 PBLAS routine
1149* will be tested. See the input file for the ordering of the
1150* routines.
1151*
1152* IAM (local input) INTEGER
1153* On entry, IAM specifies the number of the process executing
1154* this routine.
1155*
1156* NPROCS (global input) INTEGER
1157* On entry, NPROCS specifies the total number of processes.
1158*
1159* ALPHA (global output) DOUBLE PRECISION
1160* On exit, ALPHA specifies the value of alpha to be used in all
1161* the test cases.
1162*
1163* BETA (global output) DOUBLE PRECISION
1164* On exit, BETA specifies the value of beta to be used in all
1165* the test cases.
1166*
1167* WORK (local workspace) INTEGER array
1168* On entry, WORK is an array of dimension at least
1169* MAX( 3, 2*NGRIDS+38*NMAT+NSUBS ) with NSUBS = 8. This array
1170* is used to pack all output arrays in order to send info in
1171* one message.
1172*
1173* -- Written on April 1, 1998 by
1174* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1175*
1176* =====================================================================
1177*
1178* .. Parameters ..
1179 INTEGER NIN, NSUBS
1180 PARAMETER ( NIN = 11, nsubs = 8 )
1181* ..
1182* .. Local Scalars ..
1183 LOGICAL LTESTT
1184 INTEGER I, ICTXT, J
1185* ..
1186* .. Local Arrays ..
1187 CHARACTER*7 SNAMET
1188 CHARACTER*79 USRINFO
1189* ..
1190* .. External Subroutines ..
1191 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
1192 $ blacs_gridinit, blacs_setup, dgebr2d, dgebs2d,
1193 $ icopy, igebr2d, igebs2d, sgebr2d, sgebs2d
1194* ..
1195* .. Intrinsic Functions ..
1196 INTRINSIC char, ichar, max, min
1197* ..
1198* .. Common Blocks ..
1199 CHARACTER*7 SNAMES( NSUBS )
1200 COMMON /SNAMEC/SNAMES
1201* ..
1202* .. Executable Statements ..
1203*
1204* Process 0 reads the input data, broadcasts to other processes and
1205* writes needed information to NOUT
1206*
1207 IF( iam.EQ.0 ) THEN
1208*
1209* Open file and skip data file header
1210*
1211 OPEN( nin, file='PDBLAS3TIM.dat', status='OLD' )
1212 READ( nin, fmt = * ) summry
1213 summry = ' '
1214*
1215* Read in user-supplied info about machine type, compiler, etc.
1216*
1217 READ( nin, fmt = 9999 ) usrinfo
1218*
1219* Read name and unit number for summary output file
1220*
1221 READ( nin, fmt = * ) summry
1222 READ( nin, fmt = * ) nout
1223 IF( nout.NE.0 .AND. nout.NE.6 )
1224 $ OPEN( nout, file = summry, status = 'UNKNOWN' )
1225*
1226* Read and check the parameter values for the tests.
1227*
1228* Get logical computational block size
1229*
1230 READ( nin, fmt = * ) nblog
1231 IF( nblog.LT.1 )
1232 $ nblog = 32
1233*
1234* Get number of grids
1235*
1236 READ( nin, fmt = * ) ngrids
1237 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
1238 WRITE( nout, fmt = 9998 ) 'Grids', ldpval
1239 GO TO 120
1240 ELSE IF( ngrids.GT.ldqval ) THEN
1241 WRITE( nout, fmt = 9998 ) 'Grids', ldqval
1242 GO TO 120
1243 END IF
1244*
1245* Get values of P and Q
1246*
1247 READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
1248 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
1249*
1250* Read ALPHA, BETA
1251*
1252 READ( nin, fmt = * ) alpha
1253 READ( nin, fmt = * ) beta
1254*
1255* Read number of tests.
1256*
1257 READ( nin, fmt = * ) nmat
1258 IF( nmat.LT.1 .OR. nmat.GT.ldval ) THEN
1259 WRITE( nout, fmt = 9998 ) 'Tests', ldval
1260 GO TO 120
1261 ENDIF
1262*
1263* Read in input data into arrays.
1264*
1265 READ( nin, fmt = * ) ( diagval( i ), i = 1, nmat )
1266 READ( nin, fmt = * ) ( sideval( i ), i = 1, nmat )
1267 READ( nin, fmt = * ) ( trnaval( i ), i = 1, nmat )
1268 READ( nin, fmt = * ) ( trnbval( i ), i = 1, nmat )
1269 READ( nin, fmt = * ) ( uploval( i ), i = 1, nmat )
1270 READ( nin, fmt = * ) ( mval( i ), i = 1, nmat )
1271 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
1272 READ( nin, fmt = * ) ( kval( i ), i = 1, nmat )
1273 READ( nin, fmt = * ) ( maval( i ), i = 1, nmat )
1274 READ( nin, fmt = * ) ( naval( i ), i = 1, nmat )
1275 READ( nin, fmt = * ) ( imbaval( i ), i = 1, nmat )
1276 READ( nin, fmt = * ) ( inbaval( i ), i = 1, nmat )
1277 READ( nin, fmt = * ) ( mbaval( i ), i = 1, nmat )
1278 READ( nin, fmt = * ) ( nbaval( i ), i = 1, nmat )
1279 READ( nin, fmt = * ) ( rscaval( i ), i = 1, nmat )
1280 READ( nin, fmt = * ) ( cscaval( i ), i = 1, nmat )
1281 READ( nin, fmt = * ) ( iaval( i ), i = 1, nmat )
1282 READ( nin, fmt = * ) ( javal( i ), i = 1, nmat )
1283 READ( nin, fmt = * ) ( mbval( i ), i = 1, nmat )
1284 READ( nin, fmt = * ) ( nbval( i ), i = 1, nmat )
1285 READ( nin, fmt = * ) ( imbbval( i ), i = 1, nmat )
1286 READ( nin, fmt = * ) ( inbbval( i ), i = 1, nmat )
1287 READ( nin, fmt = * ) ( mbbval( i ), i = 1, nmat )
1288 READ( nin, fmt = * ) ( nbbval( i ), i = 1, nmat )
1289 READ( nin, fmt = * ) ( rscbval( i ), i = 1, nmat )
1290 READ( nin, fmt = * ) ( cscbval( i ), i = 1, nmat )
1291 READ( nin, fmt = * ) ( ibval( i ), i = 1, nmat )
1292 READ( nin, fmt = * ) ( jbval( i ), i = 1, nmat )
1293 READ( nin, fmt = * ) ( mcval( i ), i = 1, nmat )
1294 READ( nin, fmt = * ) ( ncval( i ), i = 1, nmat )
1295 READ( nin, fmt = * ) ( imbcval( i ), i = 1, nmat )
1296 READ( nin, fmt = * ) ( inbcval( i ), i = 1, nmat )
1297 READ( nin, fmt = * ) ( mbcval( i ), i = 1, nmat )
1298 READ( nin, fmt = * ) ( nbcval( i ), i = 1, nmat )
1299 READ( nin, fmt = * ) ( rsccval( i ), i = 1, nmat )
1300 READ( nin, fmt = * ) ( csccval( i ), i = 1, nmat )
1301 READ( nin, fmt = * ) ( icval( i ), i = 1, nmat )
1302 READ( nin, fmt = * ) ( jcval( i ), i = 1, nmat )
1303*
1304* Read names of subroutines and flags which indicate
1305* whether they are to be tested.
1306*
1307 DO 10 i = 1, nsubs
1308 ltest( i ) = .false.
1309 10 CONTINUE
1310 20 CONTINUE
1311 READ( nin, fmt = 9996, END = 50 ) SNAMET, ltestt
1312 DO 30 i = 1, nsubs
1313 IF( snamet.EQ.snames( i ) )
1314 $ GO TO 40
1315 30 CONTINUE
1316*
1317 WRITE( nout, fmt = 9995 )snamet
1318 GO TO 120
1319*
1320 40 CONTINUE
1321 ltest( i ) = ltestt
1322 GO TO 20
1323*
1324 50 CONTINUE
1325*
1326* Close input file
1327*
1328 CLOSE ( nin )
1329*
1330* For pvm only: if virtual machine not set up, allocate it and
1331* spawn the correct number of processes.
1332*
1333 IF( nprocs.LT.1 ) THEN
1334 nprocs = 0
1335 DO 60 i = 1, ngrids
1336 nprocs = max( nprocs, pval( i )*qval( i ) )
1337 60 CONTINUE
1338 CALL blacs_setup( iam, nprocs )
1339 END IF
1340*
1341* Temporarily define blacs grid to include all processes so
1342* information can be broadcast to all processes
1343*
1344 CALL blacs_get( -1, 0, ictxt )
1345 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1346*
1347* Pack information arrays and broadcast
1348*
1349 CALL dgebs2d( ictxt, 'All', ' ', 1, 1, alpha, 1 )
1350 CALL dgebs2d( ictxt, 'All', ' ', 1, 1, beta, 1 )
1351*
1352 work( 1 ) = ngrids
1353 work( 2 ) = nmat
1354 work( 3 ) = nblog
1355 CALL igebs2d( ictxt, 'All', ' ', 3, 1, work, 3 )
1356*
1357 i = 1
1358 DO 70 j = 1, nmat
1359 work( i ) = ichar( diagval( j ) )
1360 work( i+1 ) = ichar( sideval( j ) )
1361 work( i+2 ) = ichar( trnaval( j ) )
1362 work( i+3 ) = ichar( trnbval( j ) )
1363 work( i+4 ) = ichar( uploval( j ) )
1364 i = i + 5
1365 70 CONTINUE
1366 CALL icopy( ngrids, pval, 1, work( i ), 1 )
1367 i = i + ngrids
1368 CALL icopy( ngrids, qval, 1, work( i ), 1 )
1369 i = i + ngrids
1370 CALL icopy( nmat, mval, 1, work( i ), 1 )
1371 i = i + nmat
1372 CALL icopy( nmat, nval, 1, work( i ), 1 )
1373 i = i + nmat
1374 CALL icopy( nmat, kval, 1, work( i ), 1 )
1375 i = i + nmat
1376 CALL icopy( nmat, maval, 1, work( i ), 1 )
1377 i = i + nmat
1378 CALL icopy( nmat, naval, 1, work( i ), 1 )
1379 i = i + nmat
1380 CALL icopy( nmat, imbaval, 1, work( i ), 1 )
1381 i = i + nmat
1382 CALL icopy( nmat, inbaval, 1, work( i ), 1 )
1383 i = i + nmat
1384 CALL icopy( nmat, mbaval, 1, work( i ), 1 )
1385 i = i + nmat
1386 CALL icopy( nmat, nbaval, 1, work( i ), 1 )
1387 i = i + nmat
1388 CALL icopy( nmat, rscaval, 1, work( i ), 1 )
1389 i = i + nmat
1390 CALL icopy( nmat, cscaval, 1, work( i ), 1 )
1391 i = i + nmat
1392 CALL icopy( nmat, iaval, 1, work( i ), 1 )
1393 i = i + nmat
1394 CALL icopy( nmat, javal, 1, work( i ), 1 )
1395 i = i + nmat
1396 CALL icopy( nmat, mbval, 1, work( i ), 1 )
1397 i = i + nmat
1398 CALL icopy( nmat, nbval, 1, work( i ), 1 )
1399 i = i + nmat
1400 CALL icopy( nmat, imbbval, 1, work( i ), 1 )
1401 i = i + nmat
1402 CALL icopy( nmat, inbbval, 1, work( i ), 1 )
1403 i = i + nmat
1404 CALL icopy( nmat, mbbval, 1, work( i ), 1 )
1405 i = i + nmat
1406 CALL icopy( nmat, nbbval, 1, work( i ), 1 )
1407 i = i + nmat
1408 CALL icopy( nmat, rscbval, 1, work( i ), 1 )
1409 i = i + nmat
1410 CALL icopy( nmat, cscbval, 1, work( i ), 1 )
1411 i = i + nmat
1412 CALL icopy( nmat, ibval, 1, work( i ), 1 )
1413 i = i + nmat
1414 CALL icopy( nmat, jbval, 1, work( i ), 1 )
1415 i = i + nmat
1416 CALL icopy( nmat, mcval, 1, work( i ), 1 )
1417 i = i + nmat
1418 CALL icopy( nmat, ncval, 1, work( i ), 1 )
1419 i = i + nmat
1420 CALL icopy( nmat, imbcval, 1, work( i ), 1 )
1421 i = i + nmat
1422 CALL icopy( nmat, inbcval, 1, work( i ), 1 )
1423 i = i + nmat
1424 CALL icopy( nmat, mbcval, 1, work( i ), 1 )
1425 i = i + nmat
1426 CALL icopy( nmat, nbcval, 1, work( i ), 1 )
1427 i = i + nmat
1428 CALL icopy( nmat, rsccval, 1, work( i ), 1 )
1429 i = i + nmat
1430 CALL icopy( nmat, csccval, 1, work( i ), 1 )
1431 i = i + nmat
1432 CALL icopy( nmat, icval, 1, work( i ), 1 )
1433 i = i + nmat
1434 CALL icopy( nmat, jcval, 1, work( i ), 1 )
1435 i = i + nmat
1436*
1437 DO 80 j = 1, nsubs
1438 IF( ltest( j ) ) THEN
1439 work( i ) = 1
1440 ELSE
1441 work( i ) = 0
1442 END IF
1443 i = i + 1
1444 80 CONTINUE
1445 i = i - 1
1446 CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
1447*
1448* regurgitate input
1449*
1450 WRITE( nout, fmt = 9999 )
1451 $ 'Level 3 PBLAS timing program.'
1452 WRITE( nout, fmt = 9999 ) usrinfo
1453 WRITE( nout, fmt = * )
1454 WRITE( nout, fmt = 9999 )
1455 $ 'Tests of the real double precision '//
1456 $ 'Level 3 PBLAS'
1457 WRITE( nout, fmt = * )
1458 WRITE( nout, fmt = 9992 ) nmat
1459 WRITE( nout, fmt = 9986 ) nblog
1460 WRITE( nout, fmt = 9991 ) ngrids
1461 WRITE( nout, fmt = 9989 )
1462 $ 'P', ( pval(i), i = 1, min(ngrids, 5) )
1463 IF( ngrids.GT.5 )
1464 $ WRITE( nout, fmt = 9990 ) ( pval(i), i = 6,
1465 $ min( 10, ngrids ) )
1466 IF( ngrids.GT.10 )
1467 $ WRITE( nout, fmt = 9990 ) ( pval(i), i = 11,
1468 $ min( 15, ngrids ) )
1469 IF( ngrids.GT.15 )
1470 $ WRITE( nout, fmt = 9990 ) ( pval(i), i = 16, ngrids )
1471 WRITE( nout, fmt = 9989 )
1472 $ 'Q', ( qval(i), i = 1, min(ngrids, 5) )
1473 IF( ngrids.GT.5 )
1474 $ WRITE( nout, fmt = 9990 ) ( qval(i), i = 6,
1475 $ min( 10, ngrids ) )
1476 IF( ngrids.GT.10 )
1477 $ WRITE( nout, fmt = 9990 ) ( qval(i), i = 11,
1478 $ min( 15, ngrids ) )
1479 IF( ngrids.GT.15 )
1480 $ WRITE( nout, fmt = 9990 ) ( qval(i), i = 16, ngrids )
1481 WRITE( nout, fmt = 9994 ) alpha
1482 WRITE( nout, fmt = 9993 ) beta
1483 IF( ltest( 1 ) ) THEN
1484 WRITE( nout, fmt = 9988 ) snames( 1 ), ' ... Yes'
1485 ELSE
1486 WRITE( nout, fmt = 9988 ) snames( 1 ), ' ... No '
1487 END IF
1488 DO 90 i = 2, nsubs
1489 IF( ltest( i ) ) THEN
1490 WRITE( nout, fmt = 9987 ) snames( i ), ' ... Yes'
1491 ELSE
1492 WRITE( nout, fmt = 9987 ) snames( i ), ' ... No '
1493 END IF
1494 90 CONTINUE
1495 WRITE( nout, fmt = * )
1496*
1497 ELSE
1498*
1499* If in pvm, must participate setting up virtual machine
1500*
1501 IF( nprocs.LT.1 )
1502 $ CALL blacs_setup( iam, nprocs )
1503*
1504* Temporarily define blacs grid to include all processes so
1505* information can be broadcast to all processes
1506*
1507 CALL blacs_get( -1, 0, ictxt )
1508 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1509*
1510 CALL dgebr2d( ictxt, 'All', ' ', 1, 1, alpha, 1, 0, 0 )
1511 CALL dgebr2d( ictxt, 'All', ' ', 1, 1, beta, 1, 0, 0 )
1512*
1513 CALL igebr2d( ictxt, 'All', ' ', 3, 1, work, 3, 0, 0 )
1514 ngrids = work( 1 )
1515 nmat = work( 2 )
1516 nblog = work( 3 )
1517*
1518 i = 2*ngrids + 38*nmat + nsubs
1519 CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
1520*
1521 i = 1
1522 DO 100 j = 1, nmat
1523 diagval( j ) = char( work( i ) )
1524 sideval( j ) = char( work( i+1 ) )
1525 trnaval( j ) = char( work( i+2 ) )
1526 trnbval( j ) = char( work( i+3 ) )
1527 uploval( j ) = char( work( i+4 ) )
1528 i = i + 5
1529 100 CONTINUE
1530 CALL icopy( ngrids, work( i ), 1, pval, 1 )
1531 i = i + ngrids
1532 CALL icopy( ngrids, work( i ), 1, qval, 1 )
1533 i = i + ngrids
1534 CALL icopy( nmat, work( i ), 1, mval, 1 )
1535 i = i + nmat
1536 CALL icopy( nmat, work( i ), 1, nval, 1 )
1537 i = i + nmat
1538 CALL icopy( nmat, work( i ), 1, kval, 1 )
1539 i = i + nmat
1540 CALL icopy( nmat, work( i ), 1, maval, 1 )
1541 i = i + nmat
1542 CALL icopy( nmat, work( i ), 1, naval, 1 )
1543 i = i + nmat
1544 CALL icopy( nmat, work( i ), 1, imbaval, 1 )
1545 i = i + nmat
1546 CALL icopy( nmat, work( i ), 1, inbaval, 1 )
1547 i = i + nmat
1548 CALL icopy( nmat, work( i ), 1, mbaval, 1 )
1549 i = i + nmat
1550 CALL icopy( nmat, work( i ), 1, nbaval, 1 )
1551 i = i + nmat
1552 CALL icopy( nmat, work( i ), 1, rscaval, 1 )
1553 i = i + nmat
1554 CALL icopy( nmat, work( i ), 1, cscaval, 1 )
1555 i = i + nmat
1556 CALL icopy( nmat, work( i ), 1, iaval, 1 )
1557 i = i + nmat
1558 CALL icopy( nmat, work( i ), 1, javal, 1 )
1559 i = i + nmat
1560 CALL icopy( nmat, work( i ), 1, mbval, 1 )
1561 i = i + nmat
1562 CALL icopy( nmat, work( i ), 1, nbval, 1 )
1563 i = i + nmat
1564 CALL icopy( nmat, work( i ), 1, imbbval, 1 )
1565 i = i + nmat
1566 CALL icopy( nmat, work( i ), 1, inbbval, 1 )
1567 i = i + nmat
1568 CALL icopy( nmat, work( i ), 1, mbbval, 1 )
1569 i = i + nmat
1570 CALL icopy( nmat, work( i ), 1, nbbval, 1 )
1571 i = i + nmat
1572 CALL icopy( nmat, work( i ), 1, rscbval, 1 )
1573 i = i + nmat
1574 CALL icopy( nmat, work( i ), 1, cscbval, 1 )
1575 i = i + nmat
1576 CALL icopy( nmat, work( i ), 1, ibval, 1 )
1577 i = i + nmat
1578 CALL icopy( nmat, work( i ), 1, jbval, 1 )
1579 i = i + nmat
1580 CALL icopy( nmat, work( i ), 1, mcval, 1 )
1581 i = i + nmat
1582 CALL icopy( nmat, work( i ), 1, ncval, 1 )
1583 i = i + nmat
1584 CALL icopy( nmat, work( i ), 1, imbcval, 1 )
1585 i = i + nmat
1586 CALL icopy( nmat, work( i ), 1, inbcval, 1 )
1587 i = i + nmat
1588 CALL icopy( nmat, work( i ), 1, mbcval, 1 )
1589 i = i + nmat
1590 CALL icopy( nmat, work( i ), 1, nbcval, 1 )
1591 i = i + nmat
1592 CALL icopy( nmat, work( i ), 1, rsccval, 1 )
1593 i = i + nmat
1594 CALL icopy( nmat, work( i ), 1, csccval, 1 )
1595 i = i + nmat
1596 CALL icopy( nmat, work( i ), 1, icval, 1 )
1597 i = i + nmat
1598 CALL icopy( nmat, work( i ), 1, jcval, 1 )
1599 i = i + nmat
1600*
1601 DO 110 j = 1, nsubs
1602 IF( work( i ).EQ.1 ) THEN
1603 ltest( j ) = .true.
1604 ELSE
1605 ltest( j ) = .false.
1606 END IF
1607 i = i + 1
1608 110 CONTINUE
1609*
1610 END IF
1611*
1612 CALL blacs_gridexit( ictxt )
1613*
1614 RETURN
1615*
1616 120 WRITE( nout, fmt = 9997 )
1617 CLOSE( nin )
1618 IF( nout.NE.6 .AND. nout.NE.0 )
1619 $ CLOSE( nout )
1620 CALL blacs_abort( ictxt, 1 )
1621*
1622 stop
1623*
1624 9999 FORMAT( a )
1625 9998 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
1626 $ 'than ', i2 )
1627 9997 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
1628 9996 FORMAT( a7, l2 )
1629 9995 FORMAT( ' Subprogram name ', a7, ' not recognized',
1630 $ /' ******* TESTS ABANDONED *******' )
1631 9994 FORMAT( 2x, 'Alpha : ', g16.6 )
1632 9993 FORMAT( 2x, 'Beta : ', g16.6 )
1633 9992 FORMAT( 2x, 'Number of Tests : ', i6 )
1634 9991 FORMAT( 2x, 'Number of process grids : ', i6 )
1635 9990 FORMAT( 2x, ' : ', 5i6 )
1636 9989 FORMAT( 2x, a1, ' : ', 5i6 )
1637 9988 FORMAT( 2x, 'Routines to be tested : ', a, a8 )
1638 9987 FORMAT( 2x, ' ', a, a8 )
1639 9986 FORMAT( 2x, 'Logical block size : ', i6 )
1640*
1641* End of PDBLA3TIMINFO
1642*
1643 END
pb_combine
subroutine pb_combine(ictxt, scope, op, tmtype, n, ibeg, times)
Definition pblastim.f:3211
pb_boot
subroutine pb_boot()
Definition pblastim.f:2927
pdopbl3
double precision function pdopbl3(subnam, m, n, k)
Definition pblastim.f:1313
pb_timer
subroutine pb_timer(i)
Definition pblastim.f:2976
pmdimchk
subroutine pmdimchk(ictxt, nout, m, n, matrix, ia, ja, desca, info)
Definition pblastst.f:202
icopy
subroutine icopy(n, sx, incx, sy, incy)
Definition pblastst.f:1525
pmdescchk
subroutine pmdescchk(ictxt, nout, matrix, desca, dta, ma, na, imba, inba, mba, nba, rsrca, csrca, mpa, nqa, iprea, imida, iposta, igap, gapmul, info)
Definition pblastst.f:746
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
pdbla3tim
program pdbla3tim
Definition pdblas3tim.f:11
pdbla3timinfo
subroutine pdbla3timinfo(summry, nout, nmat, diagval, sideval, trnaval, trnbval, uploval, mval, nval, kval, maval, naval, imbaval, mbaval, inbaval, nbaval, rscaval, cscaval, iaval, javal, mbval, nbval, imbbval, mbbval, inbbval, nbbval, rscbval, cscbval, ibval, jbval, mcval, ncval, imbcval, mbcval, inbcval, nbcval, rsccval, csccval, icval, jcval, ldval, ngrids, pval, ldpval, qval, ldqval, nblog, ltest, iam, nprocs, alpha, beta, work)
Definition pdblas3tim.f:876
pdlagen
subroutine pdlagen(inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
Definition pdblastst.f:7845
pdlascal
subroutine pdlascal(type, m, n, alpha, a, ia, ja, desca)
Definition pdblastst.f:7337
lsame
logical function lsame(ca, cb)
Definition tools.f:1724