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