ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
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
max
#define max(A, B)
Definition: pcgemr.c:180
pb_timer
subroutine pb_timer(I)
Definition: pblastim.f:2976
lsame
logical function lsame(CA, CB)
Definition: tools.f:1724
pslagen
subroutine pslagen(INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA, DESCA, IASEED, A, LDA)
Definition: psblastst.f:7846
pb_boot
subroutine pb_boot()
Definition: pblastim.f:2927
pb_combine
subroutine pb_combine(ICTXT, SCOPE, OP, TMTYPE, N, IBEG, TIMES)
Definition: pblastim.f:3211
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
psbla3tim
program psbla3tim
Definition: psblas3tim.f:11
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
pslascal
subroutine pslascal(TYPE, M, N, ALPHA, A, IA, JA, DESCA)
Definition: psblastst.f:7338
pdopbl3
double precision function pdopbl3(SUBNAM, M, N, K)
Definition: pblastim.f:1313
icopy
subroutine icopy(N, SX, INCX, SY, INCY)
Definition: pblastst.f:1525
pmdimchk
subroutine pmdimchk(ICTXT, NOUT, M, N, MATRIX, IA, JA, DESCA, INFO)
Definition: pblastst.f:202
min
#define min(A, B)
Definition: pcgemr.c:181