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