ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pdblas2tim.f
Go to the documentation of this file.
1  BLOCK DATA
2  INTEGER NSUBS
3  parameter(nsubs = 7)
4  CHARACTER*7 SNAMES( NSUBS )
5  COMMON /snamec/snames
6  DATA snames/'PDGEMV ', 'PDSYMV ', 'PDTRMV ',
7  $ 'PDTRSV ', 'PDGER ', 'PDSYR ',
8  $ 'PDSYR2 '/
9  END BLOCK DATA
10 
11  PROGRAM pdbla2tim
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 * PDBLA2TIM is the main timing program for the Level 2 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 55 lines:
25 * 'Level 2 PBLAS, Timing input file'
26 * 'Intel iPSC/860 hypercube, gamma model.'
27 * 'PDBLAS2TIM.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 * 'U' 'L' values of UPLO
37 * 'N' 'T' values of TRANS
38 * 'N' 'U' values of DIAG
39 * 3 4 values of M
40 * 3 4 values of N
41 * 6 10 values of M_A
42 * 6 10 values of N_A
43 * 2 5 values of IMB_A
44 * 2 5 values of INB_A
45 * 2 5 values of MB_A
46 * 2 5 values of NB_A
47 * 0 1 values of RSRC_A
48 * 0 0 values of CSRC_A
49 * 1 1 values of IA
50 * 1 1 values of JA
51 * 6 10 values of M_X
52 * 6 10 values of N_X
53 * 2 5 values of IMB_X
54 * 2 5 values of INB_X
55 * 2 5 values of MB_X
56 * 2 5 values of NB_X
57 * 0 1 values of RSRC_X
58 * 0 0 values of CSRC_X
59 * 1 1 values of IX
60 * 1 1 values of JX
61 * 1 1 values of INCX
62 * 6 10 values of M_Y
63 * 6 10 values of N_Y
64 * 2 5 values of IMB_Y
65 * 2 5 values of INB_Y
66 * 2 5 values of MB_Y
67 * 2 5 values of NB_Y
68 * 0 1 values of RSRC_Y
69 * 0 0 values of CSRC_Y
70 * 1 1 values of IY
71 * 1 1 values of JY
72 * 6 1 values of INCY
73 * PDGEMV T put F for no test in the same column
74 * PDSYMV T put F for no test in the same column
75 * PDTRMV T put F for no test in the same column
76 * PDTRSV T put F for no test in the same column
77 * PDGER T put F for no test in the same column
78 * PDSYR T put F for no test in the same column
79 * PDSYR2 T put F for no test in the same column
80 *
81 * Internal Parameters
82 * ===================
83 *
84 * TOTMEM INTEGER
85 * TOTMEM is a machine-specific parameter indicating the maxi-
86 * mum amount of available memory per process in bytes. The
87 * user should customize TOTMEM to his platform. Remember to
88 * leave room in memory for the operating system, the BLACS
89 * buffer, etc. For example, on a system with 8 MB of memory
90 * per process (e.g., one processor on an Intel iPSC/860), the
91 * parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS,
92 * code, BLACS buffer, etc). However, for PVM, we usually set
93 * TOTMEM = 2000000. Some experimenting with the maximum value
94 * of TOTMEM may be required. By default, TOTMEM is 2000000.
95 *
96 * DBLESZ INTEGER
97 * DBLESZ indicates the length in bytes on the given platform
98 * for a double precision real. By default, DBLESZ is set to
99 * eight.
100 *
101 * MEM DOUBLE PRECISION array
102 * MEM is an array of dimension TOTMEM / DBLESZ.
103 * All arrays used by SCALAPACK routines are allocated from this
104 * array MEM and referenced by pointers. The integer IPA, for
105 * example, is a pointer to the starting element of MEM for the
106 * matrix A.
107 *
108 * -- Written on April 1, 1998 by
109 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
110 *
111 * =====================================================================
112 *
113 * .. Parameters ..
114  INTEGER maxtests, maxgrids, dblesz, totmem, memsiz,
115  $ nsubs
116  DOUBLE PRECISION one
117  parameter( maxtests = 20, maxgrids = 20, dblesz = 8,
118  $ one = 1.0d+0, totmem = 2000000, nsubs = 7,
119  $ memsiz = totmem / dblesz )
120  INTEGER block_cyclic_2d_inb, csrc_, ctxt_, dlen_,
121  $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
122  $ rsrc_
123  parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
124  $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
125  $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
126  $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
127 * ..
128 * .. Local Scalars ..
129  CHARACTER*1 aform, diag, diagdo, trans, uplo
130  INTEGER csrca, csrcx, csrcy, i, ia, iam, iaseed, ictxt,
131  $ imba, imbx, imby, imida, imidx, imidy, inba,
132  $ inbx, inby, incx, incy, ipa, iposta, ipostx,
133  $ iposty, iprea, iprex, iprey, ipx, ipy, ix,
134  $ ixseed, iy, iyseed, j, ja, jx, jy, k, m, ma,
135  $ mba, mbx, mby, memreqd, mpa, mpx, mpy, mx, my,
136  $ mycol, myrow, n, na, nba, nbx, nby, ncola,
137  $ ngrids, nlx, nly, nout, npcol, nprocs, nprow,
138  $ nqa, nqx, nqy, nrowa, ntests, nx, ny, offd,
139  $ rsrca, rsrcx, rsrcy
140  DOUBLE PRECISION alpha, beta, cflops, nops, scale, wflops
141 * ..
142 * .. Local Arrays ..
143  LOGICAL ltest( nsubs ), ycheck( nsubs )
144  CHARACTER*1 diagval( maxtests ), tranval( maxtests ),
145  $ uploval( maxtests )
146  CHARACTER*80 outfile
147  INTEGER cscaval( maxtests ), cscxval( maxtests ),
148  $ cscyval( maxtests ), desca( dlen_ ),
149  $ descx( dlen_ ), descy( dlen_ ),
150  $ iaval( maxtests ), ierr( 3 ),
151  $ imbaval( maxtests ), imbxval( maxtests ),
152  $ imbyval( maxtests ), inbaval( maxtests ),
153  $ inbxval( maxtests ), inbyval( maxtests ),
154  $ incxval( maxtests ), incyval( maxtests ),
155  $ ixval( maxtests ), iyval( maxtests ),
156  $ javal( maxtests ), jxval( maxtests ),
157  $ jyval( maxtests ), maval( maxtests ),
158  $ mbaval( maxtests ), mbxval( maxtests ),
159  $ mbyval( maxtests ), mval( maxtests ),
160  $ mxval( maxtests ), myval( maxtests ),
161  $ naval( maxtests ), nbaval( maxtests ),
162  $ nbxval( maxtests ), nbyval( maxtests ),
163  $ nval( maxtests ), nxval( maxtests ),
164  $ nyval( maxtests ), pval( maxtests ),
165  $ qval( maxtests ), rscaval( maxtests ),
166  $ rscxval( maxtests ), rscyval( maxtests )
167  DOUBLE PRECISION ctime( 1 ), mem( memsiz ), wtime( 1 )
168 * ..
169 * .. External Subroutines ..
170  EXTERNAL blacs_barrier, blacs_exit, blacs_get,
171  $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
172  $ blacs_pinfo, igsum2d, pb_boot, pb_combine,
173  $ pb_timer, pdbla2timinfo, pdgemv, pdger,
174  $ pdlagen, pdlascal, pdsymv, pdsyr, pdsyr2,
175  $ pdtrmv, pdtrsv, pmdescchk, pmdimchk, pvdescchk,
176  $ pvdimchk
177 * ..
178 * .. External Functions ..
179  LOGICAL lsame
180  DOUBLE PRECISION pdopbl2
181  EXTERNAL lsame, pdopbl2
182 * ..
183 * .. Intrinsic Functions ..
184  INTRINSIC dble, max
185 * ..
186 * .. Common Blocks ..
187  CHARACTER*7 snames( nsubs )
188  LOGICAL abrtflg
189  INTEGER info, nblog
190  COMMON /snamec/snames
191  COMMON /infoc/info, nblog
192  COMMON /pberrorc/nout, abrtflg
193 * ..
194 * .. Data Statements ..
195  DATA ycheck/.true., .true., .false., .false.,
196  $ .true., .false., .true./
197 * ..
198 * .. Executable Statements ..
199 *
200 * Initialization
201 *
202 * Set flag so that the PBLAS error handler won't abort on errors, so
203 * that the tester will detect unsupported operations.
204 *
205  abrtflg = .true.
206 *
207 * Seeds for random matrix generations.
208 *
209  iaseed = 100
210  ixseed = 200
211  iyseed = 300
212 *
213 * Get starting information
214 *
215  CALL blacs_pinfo( iam, nprocs )
216  CALL pdbla2timinfo( outfile, nout, ntests, diagval, tranval,
217  $ uploval, mval, nval, maval, naval, imbaval,
218  $ mbaval, inbaval, nbaval, rscaval, cscaval,
219  $ iaval, javal, mxval, nxval, imbxval, mbxval,
220  $ inbxval, nbxval, rscxval, cscxval, ixval,
221  $ jxval, incxval, myval, nyval, imbyval,
222  $ mbyval, inbyval, nbyval, rscyval,
223  $ cscyval, iyval, jyval, incyval, maxtests,
224  $ ngrids, pval, maxgrids, qval, maxgrids,
225  $ nblog, ltest, iam, nprocs, alpha, beta, mem )
226 *
227  IF( iam.EQ.0 )
228  $ WRITE( nout, fmt = 9983 )
229 *
230 * Loop over different process grids
231 *
232  DO 60 i = 1, ngrids
233 *
234  nprow = pval( i )
235  npcol = qval( i )
236 *
237 * Make sure grid information is correct
238 *
239  ierr( 1 ) = 0
240  IF( nprow.LT.1 ) THEN
241  IF( iam.EQ.0 )
242  $ WRITE( nout, fmt = 9999 ) 'GRID SIZE', 'NPROW', nprow
243  ierr( 1 ) = 1
244  ELSE IF( npcol.LT.1 ) THEN
245  IF( iam.EQ.0 )
246  $ WRITE( nout, fmt = 9999 ) 'GRID SIZE', 'NPCOL', npcol
247  ierr( 1 ) = 1
248  ELSE IF( nprow*npcol.GT.nprocs ) THEN
249  IF( iam.EQ.0 )
250  $ WRITE( nout, fmt = 9998 ) nprow*npcol, nprocs
251  ierr( 1 ) = 1
252  END IF
253 *
254  IF( ierr( 1 ).GT.0 ) THEN
255  IF( iam.EQ.0 )
256  $ WRITE( nout, fmt = 9997 ) 'GRID'
257  GO TO 60
258  END IF
259 *
260 * Define process grid
261 *
262  CALL blacs_get( -1, 0, ictxt )
263  CALL blacs_gridinit( ictxt, 'Row-major', nprow, npcol )
264  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
265 *
266 * Go to bottom of process grid loop if this case doesn't use my
267 * process
268 *
269  IF( myrow.GE.nprow .OR. mycol.GE.npcol )
270  $ GO TO 60
271 *
272 * Loop over number of tests
273 *
274  DO 50 j = 1, ntests
275 *
276 * Get the test parameters
277 *
278  diag = diagval( j )
279  trans = tranval( j )
280  uplo = uploval( j )
281 *
282  m = mval( j )
283  n = nval( j )
284 *
285  ma = maval( j )
286  na = naval( j )
287  imba = imbaval( j )
288  mba = mbaval( j )
289  inba = inbaval( j )
290  nba = nbaval( j )
291  rsrca = rscaval( j )
292  csrca = cscaval( j )
293  ia = iaval( j )
294  ja = javal( j )
295 *
296  mx = mxval( j )
297  nx = nxval( j )
298  imbx = imbxval( j )
299  mbx = mbxval( j )
300  inbx = inbxval( j )
301  nbx = nbxval( j )
302  rsrcx = rscxval( j )
303  csrcx = cscxval( j )
304  ix = ixval( j )
305  jx = jxval( j )
306  incx = incxval( j )
307 *
308  my = myval( j )
309  ny = nyval( j )
310  imby = imbyval( j )
311  mby = mbyval( j )
312  inby = inbyval( j )
313  nby = nbyval( j )
314  rsrcy = rscyval( j )
315  csrcy = cscyval( j )
316  iy = iyval( j )
317  jy = jyval( j )
318  incy = incyval( j )
319 *
320  IF( iam.EQ.0 ) THEN
321 *
322  WRITE( nout, fmt = * )
323  WRITE( nout, fmt = 9996 ) j, nprow, npcol
324  WRITE( nout, fmt = * )
325 *
326  WRITE( nout, fmt = 9995 )
327  WRITE( nout, fmt = 9994 )
328  WRITE( nout, fmt = 9995 )
329  WRITE( nout, fmt = 9993 ) m, n, uplo, trans, diag
330 *
331  WRITE( nout, fmt = 9995 )
332  WRITE( nout, fmt = 9992 )
333  WRITE( nout, fmt = 9995 )
334  WRITE( nout, fmt = 9991 ) ia, ja, ma, na, imba, inba,
335  $ mba, nba, rsrca, csrca
336 *
337  WRITE( nout, fmt = 9995 )
338  WRITE( nout, fmt = 9990 )
339  WRITE( nout, fmt = 9995 )
340  WRITE( nout, fmt = 9989 ) ix, jx, mx, nx, imbx, inbx,
341  $ mbx, nbx, rsrcx, csrcx, incx
342 *
343  WRITE( nout, fmt = 9995 )
344  WRITE( nout, fmt = 9988 )
345  WRITE( nout, fmt = 9995 )
346  WRITE( nout, fmt = 9989 ) iy, jy, my, ny, imby, inby,
347  $ mby, nby, rsrcy, csrcy, incy
348 *
349  WRITE( nout, fmt = 9995 )
350  WRITE( nout, fmt = 9980 )
351 *
352  END IF
353 *
354 * Check the validity of the input test parameters
355 *
356  IF( .NOT.lsame( uplo, 'U' ).AND.
357  $ .NOT.lsame( uplo, 'L' ) ) THEN
358  IF( iam.EQ.0 )
359  $ WRITE( nout, fmt = 9997 ) 'UPLO'
360  GO TO 40
361  END IF
362 *
363  IF( .NOT.lsame( trans, 'N' ).AND.
364  $ .NOT.lsame( trans, 'T' ).AND.
365  $ .NOT.lsame( trans, 'C' ) ) THEN
366  IF( iam.EQ.0 )
367  $ WRITE( nout, fmt = 9997 ) 'TRANS'
368  GO TO 40
369  END IF
370 *
371  IF( .NOT.lsame( diag , 'U' ).AND.
372  $ .NOT.lsame( diag , 'N' ) )THEN
373  IF( iam.EQ.0 )
374  $ WRITE( nout, fmt = 9997 ) trans
375  WRITE( nout, fmt = 9997 ) 'DIAG'
376  GO TO 40
377  END IF
378 *
379 * Check and initialize the matrix descriptors
380 *
381  CALL pmdescchk( ictxt, nout, 'A', desca,
382  $ block_cyclic_2d_inb, ma, na, imba, inba,
383  $ mba, nba, rsrca, csrca, mpa, nqa, iprea,
384  $ imida, iposta, 0, 0, ierr( 1 ) )
385  CALL pvdescchk( ictxt, nout, 'X', descx,
386  $ block_cyclic_2d_inb, mx, nx, imbx, inbx,
387  $ mbx, nbx, rsrcx, csrcx, incx, mpx, nqx,
388  $ iprex, imidx, ipostx, 0, 0, ierr( 2 ) )
389  CALL pvdescchk( ictxt, nout, 'Y', descy,
390  $ block_cyclic_2d_inb, my, ny, imby, inby,
391  $ mby, nby, rsrcy, csrcy, incy, mpy, nqy,
392  $ iprey, imidy, iposty, 0, 0, ierr( 3 ) )
393 *
394  IF( ierr( 1 ).GT.0 .OR. ierr( 2 ).GT.0 .OR.
395  $ ierr( 3 ).GT.0 ) THEN
396  GO TO 40
397  END IF
398 *
399 * Assign pointers into MEM for matrices corresponding to
400 * the distributed matrices A, X and Y.
401 *
402  ipa = 1
403  ipx = ipa + desca( lld_ ) * nqa
404  ipy = ipx + descx( lld_ ) * nqx
405 *
406 * Check if sufficient memory.
407 *
408  memreqd = ipy + descy( lld_ ) * nqy - 1
409  ierr( 1 ) = 0
410  IF( memreqd.GT.memsiz ) THEN
411  IF( iam.EQ.0 )
412  $ WRITE( nout, fmt = 9986 ) memreqd*dblesz
413  ierr( 1 ) = 1
414  END IF
415 *
416 * Check all processes for an error
417 *
418  CALL igsum2d( ictxt, 'All', ' ', 1, 1, ierr, 1, -1, 0 )
419 *
420  IF( ierr( 1 ).GT.0 ) THEN
421  IF( iam.EQ.0 )
422  $ WRITE( nout, fmt = 9987 )
423  GO TO 40
424  END IF
425 *
426 * Loop over all PBLAS 2 routines
427 *
428  DO 30 k = 1, nsubs
429 *
430 * Continue only if this subroutine has to be tested.
431 *
432  IF( .NOT.ltest( k ) )
433  $ GO TO 30
434 *
435 * Define the size of the operands
436 *
437  IF( k.EQ.1 ) THEN
438  nrowa = m
439  ncola = n
440  IF( lsame( trans, 'N' ) ) THEN
441  nlx = n
442  nly = m
443  ELSE
444  nlx = m
445  nly = n
446  END IF
447  ELSE IF( k.EQ.5 ) THEN
448  nrowa = m
449  ncola = n
450  nlx = m
451  nly = n
452  ELSE
453  nrowa = n
454  ncola = n
455  nlx = n
456  nly = n
457  END IF
458 *
459 * Check the validity of the operand sizes
460 *
461  CALL pmdimchk( ictxt, nout, nrowa, ncola, 'A', ia, ja,
462  $ desca, ierr( 1 ) )
463  CALL pvdimchk( ictxt, nout, nlx, 'X', ix, jx, descx,
464  $ incx, ierr( 2 ) )
465  CALL pvdimchk( ictxt, nout, nly, 'Y', iy, jy, descy,
466  $ incy, ierr( 3 ) )
467 *
468  IF( ierr( 1 ).NE.0 .OR. ierr( 2 ).NE.0 .OR.
469  $ ierr( 3 ).NE.0 ) THEN
470  GO TO 30
471  END IF
472 *
473 * Generate distributed matrices A, X and Y
474 *
475  IF( k.EQ.2 .OR. k.EQ.6 .OR. k.EQ.7 ) THEN
476  aform = 'S'
477  diagdo = 'N'
478  offd = ia - ja
479  ELSE IF( ( k.EQ.4 ).AND.( lsame( diag, 'N' ) ) ) THEN
480  aform = 'N'
481  diagdo = 'D'
482  offd = ia - ja
483  ELSE
484  aform = 'N'
485  diagdo = 'N'
486  offd = 0
487  END IF
488 *
489  CALL pdlagen( .false., aform, diagdo, offd, ma, na,
490  $ 1, 1, desca, iaseed, mem( ipa ),
491  $ desca( lld_ ) )
492  CALL pdlagen( .false., 'None', 'No diag', 0, mx, nx,
493  $ 1, 1, descx, ixseed, mem( ipx ),
494  $ descx( lld_ ) )
495  IF( ycheck( k ) )
496  $ CALL pdlagen( .false., 'None', 'No diag', 0, my,
497  $ ny, 1, 1, descy, iyseed, mem( ipy ),
498  $ descy( lld_ ) )
499 *
500  IF( ( k.EQ.4 ).AND.( .NOT.( lsame( diag, 'N' ) ) ).AND.
501  $ ( max( nrowa, ncola ).GT.1 ) ) THEN
502  scale = one / dble( max( nrowa, ncola ) )
503  IF( lsame( uplo, 'L' ) ) THEN
504  CALL pdlascal( 'Lower', nrowa-1, ncola-1, scale,
505  $ mem( ipa ), ia+1, ja, desca )
506  ELSE
507  CALL pdlascal( 'Upper', nrowa-1, ncola-1, scale,
508  $ mem( ipa ), ia, ja+1, desca )
509  END IF
510  END IF
511 *
512  info = 0
513  CALL pb_boot()
514  CALL blacs_barrier( ictxt, 'All' )
515 *
516 * Call the Level 2 PBLAS routine
517 *
518  IF( k.EQ.1 ) THEN
519 *
520 * Test PDGEMV
521 *
522  CALL pb_timer( 1 )
523  CALL pdgemv( trans, m, n, alpha, mem( ipa ), ia, ja,
524  $ desca, mem( ipx ), ix, jx, descx, incx,
525  $ beta, mem( ipy ), iy, jy, descy, incy )
526  CALL pb_timer( 1 )
527 *
528  ELSE IF( k.EQ.2 ) THEN
529 *
530 * Test PDSYMV
531 *
532  CALL pb_timer( 1 )
533  CALL pdsymv( uplo, n, alpha, mem( ipa ), ia, ja,
534  $ desca, mem( ipx ), ix, jx, descx, incx,
535  $ beta, mem( ipy ), iy, jy, descy, incy )
536  CALL pb_timer( 1 )
537 *
538  ELSE IF( k.EQ.3 ) THEN
539 *
540 * Test PDTRMV
541 *
542  CALL pb_timer( 1 )
543  CALL pdtrmv( uplo, trans, diag, n, mem( ipa ), ia, ja,
544  $ desca, mem( ipx ), ix, jx, descx, incx )
545  CALL pb_timer( 1 )
546 *
547  ELSE IF( k.EQ.4 ) THEN
548 *
549 * Test PDTRSV
550 *
551  CALL pb_timer( 1 )
552  CALL pdtrsv( uplo, trans, diag, n, mem( ipa ), ia, ja,
553  $ desca, mem( ipx ), ix, jx, descx, incx )
554  CALL pb_timer( 1 )
555 *
556  ELSE IF( k.EQ.5 ) THEN
557 *
558 * Test PDGER
559 *
560  CALL pb_timer( 1 )
561  CALL pdger( m, n, alpha, mem( ipx ), ix, jx, descx,
562  $ incx, mem( ipy ), iy, jy, descy, incy,
563  $ mem( ipa ), ia, ja, desca )
564  CALL pb_timer( 1 )
565 *
566  ELSE IF( k.EQ.6 ) THEN
567 *
568 * Test PDSYR
569 *
570  CALL pb_timer( 1 )
571  CALL pdsyr( uplo, n, alpha, mem( ipx ), ix, jx, descx,
572  $ incx, mem( ipa ), ia, ja, desca )
573  CALL pb_timer( 1 )
574 *
575  ELSE IF( k.EQ.7 ) THEN
576 *
577 * Test PDSYR2
578 *
579  CALL pb_timer( 1 )
580  CALL pdsyr2( uplo, n, alpha, mem( ipx ), ix, jx,
581  $ descx, incx, mem( ipy ), iy, jy, descy,
582  $ incy, mem( ipa ), ia, ja, desca )
583  CALL pb_timer( 1 )
584 *
585  END IF
586 *
587 * Check if the operation has been performed.
588 *
589  IF( info.NE.0 ) THEN
590  IF( iam.EQ.0 )
591  $ WRITE( nout, fmt = 9982 ) info
592  GO TO 30
593  END IF
594 *
595  CALL pb_combine( ictxt, 'All', '>', 'W', 1, 1, wtime )
596  CALL pb_combine( ictxt, 'All', '>', 'C', 1, 1, ctime )
597 *
598 * Only node 0 prints timing test result
599 *
600  IF( iam.EQ.0 ) THEN
601 *
602 * Calculate total flops
603 *
604  nops = pdopbl2( snames( k ), nrowa, ncola, 0, 0 )
605 *
606 * Print WALL time if machine supports it
607 *
608  IF( wtime( 1 ).GT.0.0d+0 ) THEN
609  wflops = nops / ( wtime( 1 ) * 1.0d+6 )
610  ELSE
611  wflops = 0.0d+0
612  END IF
613 *
614 * Print CPU time if machine supports it
615 *
616  IF( ctime( 1 ).GT.0.0d+0 ) THEN
617  cflops = nops / ( ctime( 1 ) * 1.0d+6 )
618  ELSE
619  cflops = 0.0d+0
620  END IF
621 *
622  WRITE( nout, fmt = 9981 ) snames( k ), wtime( 1 ),
623  $ wflops, ctime( 1 ), cflops
624 *
625  END IF
626 *
627  30 CONTINUE
628 *
629  40 IF( iam.EQ.0 ) THEN
630  WRITE( nout, fmt = 9995 )
631  WRITE( nout, fmt = * )
632  WRITE( nout, fmt = 9985 ) j
633  END IF
634 *
635  50 CONTINUE
636 *
637  CALL blacs_gridexit( ictxt )
638 *
639  60 CONTINUE
640 *
641 * Print results
642 *
643  IF( iam.EQ.0 ) THEN
644  WRITE( nout, fmt = * )
645  WRITE( nout, fmt = 9984 )
646  WRITE( nout, fmt = * )
647  END IF
648 *
649  CALL blacs_exit( 0 )
650 *
651  9999 FORMAT( 'ILLEGAL ', a, ': ', a, ' = ', i10,
652  $ ' should be at least 1' )
653  9998 FORMAT( 'ILLEGAL GRID: NPROW*NPCOL = ', i4,
654  $ '. It can be at most', i4 )
655  9997 FORMAT( 'Bad ', a, ' parameters: going on to next test case.' )
656  9996 FORMAT( 2x, 'Test number ', i2 , ' started on a ', i4, ' x ',
657  $ i4, ' process grid.' )
658  9995 FORMAT( 2x, ' ------------------------------------------------',
659  $ '--------------------------' )
660  9994 FORMAT( 2x, ' M N UPLO TRANS DIAG' )
661  9993 FORMAT( 5x,i6,1x,i6,9x,a1,11x,a1,10x,a1 )
662  9992 FORMAT( 2x, ' IA JA MA NA IMBA INBA',
663  $ ' MBA NBA RSRCA CSRCA' )
664  9991 FORMAT( 5x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,
665  $ 1x,i5,1x,i5 )
666  9990 FORMAT( 2x, ' IX JX MX NX IMBX INBX',
667  $ ' MBX NBX RSRCX CSRCX INCX' )
668  9989 FORMAT( 5x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,
669  $ 1x,i5,1x,i5,1x,i6 )
670  9988 FORMAT( 2x, ' IY JY MY NY IMBY INBY',
671  $ ' MBY NBY RSRCY CSRCY INCY' )
672  9987 FORMAT( 'Not enough memory for this test: going on to',
673  $ ' next test case.' )
674  9986 FORMAT( 'Not enough memory. Need: ', i12 )
675  9985 FORMAT( 2x, 'Test number ', i2, ' completed.' )
676  9984 FORMAT( 2x, 'End of Tests.' )
677  9983 FORMAT( 2x, 'Tests started.' )
678  9982 FORMAT( 2x, ' ***** Operation not supported, error code: ',
679  $ i5, ' *****' )
680  9981 FORMAT( 2x, '| ', a, 2x, f13.3, 2x, f13.3, 2x, f13.3, 2x, f13.3 )
681  9980 FORMAT( 2x, ' WALL time (s) WALL Mflops ',
682  $ ' CPU time (s) CPU Mflops' )
683 *
684  stop
685 *
686 * End of PDBLA2TIM
687 *
688  END
689  SUBROUTINE pdbla2timinfo( SUMMRY, NOUT, NMAT, DIAGVAL, TRANVAL,
690  $ UPLOVAL, MVAL, NVAL, MAVAL, NAVAL,
691  $ IMBAVAL, MBAVAL, INBAVAL, NBAVAL,
692  $ RSCAVAL, CSCAVAL, IAVAL, JAVAL,
693  $ MXVAL, NXVAL, IMBXVAL, MBXVAL,
694  $ INBXVAL, NBXVAL, RSCXVAL, CSCXVAL,
695  $ IXVAL, JXVAL, INCXVAL, MYVAL, NYVAL,
696  $ IMBYVAL, MBYVAL, INBYVAL, NBYVAL,
697  $ RSCYVAL, CSCYVAL, IYVAL, JYVAL,
698  $ INCYVAL, LDVAL, NGRIDS, PVAL, LDPVAL,
699  $ QVAL, LDQVAL, NBLOG, LTEST, IAM, NPROCS,
700  $ ALPHA, BETA, WORK )
701 *
702 * -- PBLAS test routine (version 2.0) --
703 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
704 * and University of California, Berkeley.
705 * April 1, 1998
706 *
707 * .. Scalar Arguments ..
708  INTEGER IAM, LDPVAL, LDQVAL, LDVAL, NBLOG, NGRIDS,
709  $ NMAT, NOUT, NPROCS
710  DOUBLE PRECISION ALPHA, BETA
711 * ..
712 * .. Array Arguments ..
713  CHARACTER*( * ) SUMMRY
714  CHARACTER*1 DIAGVAL( LDVAL ), TRANVAL( LDVAL ),
715  $ UPLOVAL( LDVAL )
716  LOGICAL LTEST( * )
717  INTEGER CSCAVAL( LDVAL ), CSCXVAL( LDVAL ),
718  $ CSCYVAL( LDVAL ), IAVAL( LDVAL ),
719  $ imbaval( ldval ), imbxval( ldval ),
720  $ imbyval( ldval ), inbaval( ldval ),
721  $ inbxval( ldval ), inbyval( ldval ),
722  $ incxval( ldval ), incyval( ldval ),
723  $ ixval( ldval ), iyval( ldval ), javal( ldval ),
724  $ jxval( ldval ), jyval( ldval ), maval( ldval ),
725  $ mbaval( ldval ), mbxval( ldval ),
726  $ mbyval( ldval ), mval( ldval ), mxval( ldval ),
727  $ myval( ldval ), naval( ldval ),
728  $ nbaval( ldval ), nbxval( ldval ),
729  $ nbyval( ldval ), nval( ldval ), nxval( ldval ),
730  $ nyval( ldval ), pval( ldpval ), qval( ldqval ),
731  $ rscaval( ldval ), rscxval( ldval ),
732  $ rscyval( ldval ), work( * )
733 * ..
734 *
735 * Purpose
736 * =======
737 *
738 * PDBLA2TIMINFO get the needed startup information for timing various
739 * Level 2 PBLAS routines, and transmits it to all processes.
740 *
741 * Notes
742 * =====
743 *
744 * For packing the information we assumed that the length in bytes of an
745 * integer is equal to the length in bytes of a real single precision.
746 *
747 * Arguments
748 * =========
749 *
750 * SUMMRY (global output) CHARACTER*(*)
751 * On exit, SUMMRY is the name of output (summary) file (if
752 * any). SUMMRY is only defined for process 0.
753 *
754 * NOUT (global output) INTEGER
755 * On exit, NOUT specifies the unit number for the output file.
756 * When NOUT is 6, output to screen, when NOUT is 0, output to
757 * stderr. NOUT is only defined for process 0.
758 *
759 * NMAT (global output) INTEGER
760 * On exit, NMAT specifies the number of different test cases.
761 *
762 * DIAGVAL (global output) CHARACTER array
763 * On entry, DIAGVAL is an array of dimension LDVAL. On exit,
764 * this array contains the values of DIAG to run the code with.
765 *
766 * TRANVAL (global output) CHARACTER array
767 * On entry, TRANVAL is an array of dimension LDVAL. On exit,
768 * this array contains the values of TRANS to run the code
769 * with.
770 *
771 * UPLOVAL (global output) CHARACTER array
772 * On entry, UPLOVAL is an array of dimension LDVAL. On exit,
773 * this array contains the values of UPLO to run the code with.
774 *
775 * MVAL (global output) INTEGER array
776 * On entry, MVAL is an array of dimension LDVAL. On exit, this
777 * array contains the values of M to run the code with.
778 *
779 * NVAL (global output) INTEGER array
780 * On entry, NVAL is an array of dimension LDVAL. On exit, this
781 * array contains the values of N to run the code with.
782 *
783 * MAVAL (global output) INTEGER array
784 * On entry, MAVAL is an array of dimension LDVAL. On exit, this
785 * array contains the values of DESCA( M_ ) to run the code
786 * with.
787 *
788 * NAVAL (global output) INTEGER array
789 * On entry, NAVAL is an array of dimension LDVAL. On exit, this
790 * array contains the values of DESCA( N_ ) to run the code
791 * with.
792 *
793 * IMBAVAL (global output) INTEGER array
794 * On entry, IMBAVAL is an array of dimension LDVAL. On exit,
795 * this array contains the values of DESCA( IMB_ ) to run the
796 * code with.
797 *
798 * MBAVAL (global output) INTEGER array
799 * On entry, MBAVAL is an array of dimension LDVAL. On exit,
800 * this array contains the values of DESCA( MB_ ) to run the
801 * code with.
802 *
803 * INBAVAL (global output) INTEGER array
804 * On entry, INBAVAL is an array of dimension LDVAL. On exit,
805 * this array contains the values of DESCA( INB_ ) to run the
806 * code with.
807 *
808 * NBAVAL (global output) INTEGER array
809 * On entry, NBAVAL is an array of dimension LDVAL. On exit,
810 * this array contains the values of DESCA( NB_ ) to run the
811 * code with.
812 *
813 * RSCAVAL (global output) INTEGER array
814 * On entry, RSCAVAL is an array of dimension LDVAL. On exit,
815 * this array contains the values of DESCA( RSRC_ ) to run the
816 * code with.
817 *
818 * CSCAVAL (global output) INTEGER array
819 * On entry, CSCAVAL is an array of dimension LDVAL. On exit,
820 * this array contains the values of DESCA( CSRC_ ) to run the
821 * code with.
822 *
823 * IAVAL (global output) INTEGER array
824 * On entry, IAVAL is an array of dimension LDVAL. On exit, this
825 * array contains the values of IA to run the code with.
826 *
827 * JAVAL (global output) INTEGER array
828 * On entry, JAVAL is an array of dimension LDVAL. On exit, this
829 * array contains the values of JA to run the code with.
830 *
831 * MXVAL (global output) INTEGER array
832 * On entry, MXVAL is an array of dimension LDVAL. On exit, this
833 * array contains the values of DESCX( M_ ) to run the code
834 * with.
835 *
836 * NXVAL (global output) INTEGER array
837 * On entry, NXVAL is an array of dimension LDVAL. On exit, this
838 * array contains the values of DESCX( N_ ) to run the code
839 * with.
840 *
841 * IMBXVAL (global output) INTEGER array
842 * On entry, IMBXVAL is an array of dimension LDVAL. On exit,
843 * this array contains the values of DESCX( IMB_ ) to run the
844 * code with.
845 *
846 * MBXVAL (global output) INTEGER array
847 * On entry, MBXVAL is an array of dimension LDVAL. On exit,
848 * this array contains the values of DESCX( MB_ ) to run the
849 * code with.
850 *
851 * INBXVAL (global output) INTEGER array
852 * On entry, INBXVAL is an array of dimension LDVAL. On exit,
853 * this array contains the values of DESCX( INB_ ) to run the
854 * code with.
855 *
856 * NBXVAL (global output) INTEGER array
857 * On entry, NBXVAL is an array of dimension LDVAL. On exit,
858 * this array contains the values of DESCX( NB_ ) to run the
859 * code with.
860 *
861 * RSCXVAL (global output) INTEGER array
862 * On entry, RSCXVAL is an array of dimension LDVAL. On exit,
863 * this array contains the values of DESCX( RSRC_ ) to run the
864 * code with.
865 *
866 * CSCXVAL (global output) INTEGER array
867 * On entry, CSCXVAL is an array of dimension LDVAL. On exit,
868 * this array contains the values of DESCX( CSRC_ ) to run the
869 * code with.
870 *
871 * IXVAL (global output) INTEGER array
872 * On entry, IXVAL is an array of dimension LDVAL. On exit, this
873 * array contains the values of IX to run the code with.
874 *
875 * JXVAL (global output) INTEGER array
876 * On entry, JXVAL is an array of dimension LDVAL. On exit, this
877 * array contains the values of JX to run the code with.
878 *
879 * INCXVAL (global output) INTEGER array
880 * On entry, INCXVAL is an array of dimension LDVAL. On exit,
881 * this array contains the values of INCX to run the code with.
882 *
883 * MYVAL (global output) INTEGER array
884 * On entry, MYVAL is an array of dimension LDVAL. On exit, this
885 * array contains the values of DESCY( M_ ) to run the code
886 * with.
887 *
888 * NYVAL (global output) INTEGER array
889 * On entry, NYVAL is an array of dimension LDVAL. On exit, this
890 * array contains the values of DESCY( N_ ) to run the code
891 * with.
892 *
893 * IMBYVAL (global output) INTEGER array
894 * On entry, IMBYVAL is an array of dimension LDVAL. On exit,
895 * this array contains the values of DESCY( IMB_ ) to run the
896 * code with.
897 *
898 * MBYVAL (global output) INTEGER array
899 * On entry, MBYVAL is an array of dimension LDVAL. On exit,
900 * this array contains the values of DESCY( MB_ ) to run the
901 * code with.
902 *
903 * INBYVAL (global output) INTEGER array
904 * On entry, INBYVAL is an array of dimension LDVAL. On exit,
905 * this array contains the values of DESCY( INB_ ) to run the
906 * code with.
907 *
908 * NBYVAL (global output) INTEGER array
909 * On entry, NBYVAL is an array of dimension LDVAL. On exit,
910 * this array contains the values of DESCY( NB_ ) to run the
911 * code with.
912 *
913 * RSCYVAL (global output) INTEGER array
914 * On entry, RSCYVAL is an array of dimension LDVAL. On exit,
915 * this array contains the values of DESCY( RSRC_ ) to run the
916 * code with.
917 *
918 * CSCYVAL (global output) INTEGER array
919 * On entry, CSCYVAL is an array of dimension LDVAL. On exit,
920 * this array contains the values of DESCY( CSRC_ ) to run the
921 * code with.
922 *
923 * IYVAL (global output) INTEGER array
924 * On entry, IYVAL is an array of dimension LDVAL. On exit, this
925 * array contains the values of IY to run the code with.
926 *
927 * JYVAL (global output) INTEGER array
928 * On entry, JYVAL is an array of dimension LDVAL. On exit, this
929 * array contains the values of JY to run the code with.
930 *
931 * INCYVAL (global output) INTEGER array
932 * On entry, INCYVAL is an array of dimension LDVAL. On exit,
933 * this array contains the values of INCY to run the code with.
934 *
935 * LDVAL (global input) INTEGER
936 * On entry, LDVAL specifies the maximum number of different va-
937 * lues that can be used for DIAG, TRANS, UPLO, M, N, DESCA(:),
938 * IA, JA, DESCX(:), IX, JX, INCX, DESCY(:), IY, JY and INCY.
939 * This is also the maximum number of test cases.
940 *
941 * NGRIDS (global output) INTEGER
942 * On exit, NGRIDS specifies the number of different values that
943 * can be used for P and Q.
944 *
945 * PVAL (global output) INTEGER array
946 * On entry, PVAL is an array of dimension LDPVAL. On exit, this
947 * array contains the values of P to run the code with.
948 *
949 * LDPVAL (global input) INTEGER
950 * On entry, LDPVAL specifies the maximum number of different
951 * values that can be used for P.
952 *
953 * QVAL (global output) INTEGER array
954 * On entry, QVAL is an array of dimension LDQVAL. On exit, this
955 * array contains the values of Q to run the code with.
956 *
957 * LDQVAL (global input) INTEGER
958 * On entry, LDQVAL specifies the maximum number of different
959 * values that can be used for Q.
960 *
961 * NBLOG (global output) INTEGER
962 * On exit, NBLOG specifies the logical computational block size
963 * to run the tests with. NBLOG must be at least one.
964 *
965 * LTEST (global output) LOGICAL array
966 * On entry, LTEST is an array of dimension at least seven. On
967 * exit, if LTEST( i ) is .TRUE., the i-th Level 2 PBLAS routine
968 * will be tested. See the input file for the ordering of the
969 * routines.
970 *
971 * IAM (local input) INTEGER
972 * On entry, IAM specifies the number of the process executing
973 * this routine.
974 *
975 * NPROCS (global input) INTEGER
976 * On entry, NPROCS specifies the total number of processes.
977 *
978 * ALPHA (global output) DOUBLE PRECISION
979 * On exit, ALPHA specifies the value of alpha to be used in all
980 * the test cases.
981 *
982 * BETA (global output) DOUBLE PRECISION
983 * On exit, BETA specifies the value of beta to be used in all
984 * the test cases.
985 *
986 * WORK (local workspace) INTEGER array
987 * On entry, WORK is an array of dimension at least
988 * MAX( 3, 2*NGRIDS+37*NMAT+NSUBS ) with NSUBS = 7. This array
989 * is used to pack all output arrays in order to send info in
990 * one message.
991 *
992 * -- Written on April 1, 1998 by
993 * Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
994 *
995 * =====================================================================
996 *
997 * .. Parameters ..
998  INTEGER NIN, NSUBS
999  PARAMETER ( NIN = 11, nsubs = 7 )
1000 * ..
1001 * .. Local Scalars ..
1002  LOGICAL LTESTT
1003  INTEGER I, ICTXT, J
1004 * ..
1005 * .. Local Arrays ..
1006  CHARACTER*7 SNAMET
1007  CHARACTER*79 USRINFO
1008 * ..
1009 * .. External Subroutines ..
1010  EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
1011  $ blacs_gridinit, blacs_setup, dgebr2d, dgebs2d,
1012  $ icopy, igebr2d, igebs2d, sgebr2d, sgebs2d
1013 * ..
1014 * .. Intrinsic Functions ..
1015  INTRINSIC char, ichar, max, min
1016 * ..
1017 * .. Common Blocks ..
1018  CHARACTER*7 SNAMES( NSUBS )
1019  COMMON /SNAMEC/SNAMES
1020 * ..
1021 * .. Executable Statements ..
1022 *
1023 * Process 0 reads the input data, broadcasts to other processes and
1024 * writes needed information to NOUT
1025 *
1026  IF( iam.EQ.0 ) THEN
1027 *
1028 * Open file and skip data file header
1029 *
1030  OPEN( nin, file='PDBLAS2TIM.dat', status='OLD' )
1031  READ( nin, fmt = * ) summry
1032  summry = ' '
1033 *
1034 * Read in user-supplied info about machine type, compiler, etc.
1035 *
1036  READ( nin, fmt = 9999 ) usrinfo
1037 *
1038 * Read name and unit number for summary output file
1039 *
1040  READ( nin, fmt = * ) summry
1041  READ( nin, fmt = * ) nout
1042  IF( nout.NE.0 .AND. nout.NE.6 )
1043  $ OPEN( nout, file = summry, status = 'UNKNOWN' )
1044 *
1045 * Read and check the parameter values for the tests.
1046 *
1047 * Get logical computational block size
1048 *
1049  READ( nin, fmt = * ) nblog
1050  IF( nblog.LT.1 )
1051  $ nblog = 32
1052 *
1053 * Get number of grids
1054 *
1055  READ( nin, fmt = * ) ngrids
1056  IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
1057  WRITE( nout, fmt = 9998 ) 'Grids', ldpval
1058  GO TO 120
1059  ELSE IF( ngrids.GT.ldqval ) THEN
1060  WRITE( nout, fmt = 9998 ) 'Grids', ldqval
1061  GO TO 120
1062  END IF
1063 *
1064 * Get values of P and Q
1065 *
1066  READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
1067  READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
1068 *
1069 * Read ALPHA, BETA
1070 *
1071  READ( nin, fmt = * ) alpha
1072  READ( nin, fmt = * ) beta
1073 *
1074 * Read number of tests.
1075 *
1076  READ( nin, fmt = * ) nmat
1077  IF( nmat.LT.1 .OR. nmat.GT.ldval ) THEN
1078  WRITE( nout, fmt = 9998 ) 'Tests', ldval
1079  GO TO 120
1080  END IF
1081 *
1082 * Read in input data into arrays.
1083 *
1084  READ( nin, fmt = * ) ( uploval( i ), i = 1, nmat )
1085  READ( nin, fmt = * ) ( tranval( i ), i = 1, nmat )
1086  READ( nin, fmt = * ) ( diagval( i ), i = 1, nmat )
1087  READ( nin, fmt = * ) ( mval( i ), i = 1, nmat )
1088  READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
1089  READ( nin, fmt = * ) ( maval( i ), i = 1, nmat )
1090  READ( nin, fmt = * ) ( naval( i ), i = 1, nmat )
1091  READ( nin, fmt = * ) ( imbaval( i ), i = 1, nmat )
1092  READ( nin, fmt = * ) ( inbaval( i ), i = 1, nmat )
1093  READ( nin, fmt = * ) ( mbaval( i ), i = 1, nmat )
1094  READ( nin, fmt = * ) ( nbaval( i ), i = 1, nmat )
1095  READ( nin, fmt = * ) ( rscaval( i ), i = 1, nmat )
1096  READ( nin, fmt = * ) ( cscaval( i ), i = 1, nmat )
1097  READ( nin, fmt = * ) ( iaval( i ), i = 1, nmat )
1098  READ( nin, fmt = * ) ( javal( i ), i = 1, nmat )
1099  READ( nin, fmt = * ) ( mxval( i ), i = 1, nmat )
1100  READ( nin, fmt = * ) ( nxval( i ), i = 1, nmat )
1101  READ( nin, fmt = * ) ( imbxval( i ), i = 1, nmat )
1102  READ( nin, fmt = * ) ( inbxval( i ), i = 1, nmat )
1103  READ( nin, fmt = * ) ( mbxval( i ), i = 1, nmat )
1104  READ( nin, fmt = * ) ( nbxval( i ), i = 1, nmat )
1105  READ( nin, fmt = * ) ( rscxval( i ), i = 1, nmat )
1106  READ( nin, fmt = * ) ( cscxval( i ), i = 1, nmat )
1107  READ( nin, fmt = * ) ( ixval( i ), i = 1, nmat )
1108  READ( nin, fmt = * ) ( jxval( i ), i = 1, nmat )
1109  READ( nin, fmt = * ) ( incxval( i ), i = 1, nmat )
1110  READ( nin, fmt = * ) ( myval( i ), i = 1, nmat )
1111  READ( nin, fmt = * ) ( nyval( i ), i = 1, nmat )
1112  READ( nin, fmt = * ) ( imbyval( i ), i = 1, nmat )
1113  READ( nin, fmt = * ) ( inbyval( i ), i = 1, nmat )
1114  READ( nin, fmt = * ) ( mbyval( i ), i = 1, nmat )
1115  READ( nin, fmt = * ) ( nbyval( i ), i = 1, nmat )
1116  READ( nin, fmt = * ) ( rscyval( i ), i = 1, nmat )
1117  READ( nin, fmt = * ) ( cscyval( i ), i = 1, nmat )
1118  READ( nin, fmt = * ) ( iyval( i ), i = 1, nmat )
1119  READ( nin, fmt = * ) ( jyval( i ), i = 1, nmat )
1120  READ( nin, fmt = * ) ( incyval( i ), i = 1, nmat )
1121 *
1122 * Read names of subroutines and flags which indicate
1123 * whether they are to be tested.
1124 *
1125  DO 10 i = 1, nsubs
1126  ltest( i ) = .false.
1127  10 CONTINUE
1128  20 CONTINUE
1129  READ( nin, fmt = 9996, END = 50 ) SNAMET, ltestt
1130  DO 30 i = 1, nsubs
1131  IF( snamet.EQ.snames( i ) )
1132  $ GO TO 40
1133  30 CONTINUE
1134 *
1135  WRITE( nout, fmt = 9995 )snamet
1136  GO TO 120
1137 *
1138  40 CONTINUE
1139  ltest( i ) = ltestt
1140  GO TO 20
1141 *
1142  50 CONTINUE
1143 *
1144 * Close input file
1145 *
1146  CLOSE ( nin )
1147 *
1148 * For pvm only: if virtual machine not set up, allocate it and
1149 * spawn the correct number of processes.
1150 *
1151  IF( nprocs.LT.1 ) THEN
1152  nprocs = 0
1153  DO 60 i = 1, ngrids
1154  nprocs = max( nprocs, pval( i )*qval( i ) )
1155  60 CONTINUE
1156  CALL blacs_setup( iam, nprocs )
1157  END IF
1158 *
1159 * Temporarily define blacs grid to include all processes so
1160 * information can be broadcast to all processes
1161 *
1162  CALL blacs_get( -1, 0, ictxt )
1163  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1164 *
1165 * Pack information arrays and broadcast
1166 *
1167  CALL dgebs2d( ictxt, 'All', ' ', 1, 1, alpha, 1 )
1168  CALL dgebs2d( ictxt, 'All', ' ', 1, 1, beta, 1 )
1169 *
1170  work( 1 ) = ngrids
1171  work( 2 ) = nmat
1172  work( 3 ) = nblog
1173  CALL igebs2d( ictxt, 'All', ' ', 3, 1, work, 3 )
1174 *
1175  i = 1
1176  DO 70 j = 1, nmat
1177  work( i ) = ichar( diagval( j ) )
1178  work( i+1 ) = ichar( tranval( j ) )
1179  work( i+2 ) = ichar( uploval( j ) )
1180  i = i + 3
1181  70 CONTINUE
1182  CALL icopy( ngrids, pval, 1, work( i ), 1 )
1183  i = i + ngrids
1184  CALL icopy( ngrids, qval, 1, work( i ), 1 )
1185  i = i + ngrids
1186  CALL icopy( nmat, mval, 1, work( i ), 1 )
1187  i = i + nmat
1188  CALL icopy( nmat, nval, 1, work( i ), 1 )
1189  i = i + nmat
1190  CALL icopy( nmat, maval, 1, work( i ), 1 )
1191  i = i + nmat
1192  CALL icopy( nmat, naval, 1, work( i ), 1 )
1193  i = i + nmat
1194  CALL icopy( nmat, imbaval, 1, work( i ), 1 )
1195  i = i + nmat
1196  CALL icopy( nmat, inbaval, 1, work( i ), 1 )
1197  i = i + nmat
1198  CALL icopy( nmat, mbaval, 1, work( i ), 1 )
1199  i = i + nmat
1200  CALL icopy( nmat, nbaval, 1, work( i ), 1 )
1201  i = i + nmat
1202  CALL icopy( nmat, rscaval, 1, work( i ), 1 )
1203  i = i + nmat
1204  CALL icopy( nmat, cscaval, 1, work( i ), 1 )
1205  i = i + nmat
1206  CALL icopy( nmat, iaval, 1, work( i ), 1 )
1207  i = i + nmat
1208  CALL icopy( nmat, javal, 1, work( i ), 1 )
1209  i = i + nmat
1210  CALL icopy( nmat, mxval, 1, work( i ), 1 )
1211  i = i + nmat
1212  CALL icopy( nmat, nxval, 1, work( i ), 1 )
1213  i = i + nmat
1214  CALL icopy( nmat, imbxval, 1, work( i ), 1 )
1215  i = i + nmat
1216  CALL icopy( nmat, inbxval, 1, work( i ), 1 )
1217  i = i + nmat
1218  CALL icopy( nmat, mbxval, 1, work( i ), 1 )
1219  i = i + nmat
1220  CALL icopy( nmat, nbxval, 1, work( i ), 1 )
1221  i = i + nmat
1222  CALL icopy( nmat, rscxval, 1, work( i ), 1 )
1223  i = i + nmat
1224  CALL icopy( nmat, cscxval, 1, work( i ), 1 )
1225  i = i + nmat
1226  CALL icopy( nmat, ixval, 1, work( i ), 1 )
1227  i = i + nmat
1228  CALL icopy( nmat, jxval, 1, work( i ), 1 )
1229  i = i + nmat
1230  CALL icopy( nmat, incxval, 1, work( i ), 1 )
1231  i = i + nmat
1232  CALL icopy( nmat, myval, 1, work( i ), 1 )
1233  i = i + nmat
1234  CALL icopy( nmat, nyval, 1, work( i ), 1 )
1235  i = i + nmat
1236  CALL icopy( nmat, imbyval, 1, work( i ), 1 )
1237  i = i + nmat
1238  CALL icopy( nmat, inbyval, 1, work( i ), 1 )
1239  i = i + nmat
1240  CALL icopy( nmat, mbyval, 1, work( i ), 1 )
1241  i = i + nmat
1242  CALL icopy( nmat, nbyval, 1, work( i ), 1 )
1243  i = i + nmat
1244  CALL icopy( nmat, rscyval, 1, work( i ), 1 )
1245  i = i + nmat
1246  CALL icopy( nmat, cscyval, 1, work( i ), 1 )
1247  i = i + nmat
1248  CALL icopy( nmat, iyval, 1, work( i ), 1 )
1249  i = i + nmat
1250  CALL icopy( nmat, jyval, 1, work( i ), 1 )
1251  i = i + nmat
1252  CALL icopy( nmat, incyval, 1, work( i ), 1 )
1253  i = i + nmat
1254 *
1255  DO 80 j = 1, nsubs
1256  IF( ltest( j ) ) THEN
1257  work( i ) = 1
1258  ELSE
1259  work( i ) = 0
1260  END IF
1261  i = i + 1
1262  80 CONTINUE
1263  i = i - 1
1264  CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
1265 *
1266 * regurgitate input
1267 *
1268  WRITE( nout, fmt = 9999 )
1269  $ 'Level 2 PBLAS timing program.'
1270  WRITE( nout, fmt = 9999 ) usrinfo
1271  WRITE( nout, fmt = * )
1272  WRITE( nout, fmt = 9999 )
1273  $ 'Tests of the real double precision '//
1274  $ 'Level 2 PBLAS'
1275  WRITE( nout, fmt = * )
1276  WRITE( nout, fmt = 9992 ) nmat
1277  WRITE( nout, fmt = 9986 ) nblog
1278  WRITE( nout, fmt = 9991 ) ngrids
1279  WRITE( nout, fmt = 9989 )
1280  $ 'P', ( pval(i), i = 1, min(ngrids, 5) )
1281  IF( ngrids.GT.5 )
1282  $ WRITE( nout, fmt = 9990 ) ( pval(i), i = 6,
1283  $ min( 10, ngrids ) )
1284  IF( ngrids.GT.10 )
1285  $ WRITE( nout, fmt = 9990 ) ( pval(i), i = 11,
1286  $ min( 15, ngrids ) )
1287  IF( ngrids.GT.15 )
1288  $ WRITE( nout, fmt = 9990 ) ( pval(i), i = 16, ngrids )
1289  WRITE( nout, fmt = 9989 )
1290  $ 'Q', ( qval(i), i = 1, min(ngrids, 5) )
1291  IF( ngrids.GT.5 )
1292  $ WRITE( nout, fmt = 9990 ) ( qval(i), i = 6,
1293  $ min( 10, ngrids ) )
1294  IF( ngrids.GT.10 )
1295  $ WRITE( nout, fmt = 9990 ) ( qval(i), i = 11,
1296  $ min( 15, ngrids ) )
1297  IF( ngrids.GT.15 )
1298  $ WRITE( nout, fmt = 9990 ) ( qval(i), i = 16, ngrids )
1299  WRITE( nout, fmt = 9994 ) alpha
1300  WRITE( nout, fmt = 9993 ) beta
1301  IF( ltest( 1 ) ) THEN
1302  WRITE( nout, fmt = 9988 ) snames( 1 ), ' ... Yes'
1303  ELSE
1304  WRITE( nout, fmt = 9988 ) snames( 1 ), ' ... No '
1305  END IF
1306  DO 90 i = 1, nsubs
1307  IF( ltest( i ) ) THEN
1308  WRITE( nout, fmt = 9987 ) snames( i ), ' ... Yes'
1309  ELSE
1310  WRITE( nout, fmt = 9987 ) snames( i ), ' ... No '
1311  END IF
1312  90 CONTINUE
1313  WRITE( nout, fmt = * )
1314 *
1315  ELSE
1316 *
1317 * If in pvm, must participate setting up virtual machine
1318 *
1319  IF( nprocs.LT.1 )
1320  $ CALL blacs_setup( iam, nprocs )
1321 *
1322 * Temporarily define blacs grid to include all processes so
1323 * information can be broadcast to all processes
1324 *
1325  CALL blacs_get( -1, 0, ictxt )
1326  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1327 *
1328  CALL dgebr2d( ictxt, 'All', ' ', 1, 1, alpha, 1, 0, 0 )
1329  CALL dgebr2d( ictxt, 'All', ' ', 1, 1, beta, 1, 0, 0 )
1330 *
1331  CALL igebr2d( ictxt, 'All', ' ', 3, 1, work, 3, 0, 0 )
1332  ngrids = work( 1 )
1333  nmat = work( 2 )
1334  nblog = work( 3 )
1335 *
1336  i = 2*ngrids + 37*nmat + nsubs
1337  CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
1338 *
1339  i = 1
1340  DO 100 j = 1, nmat
1341  diagval( j ) = char( work( i ) )
1342  tranval( j ) = char( work( i+1 ) )
1343  uploval( j ) = char( work( i+2 ) )
1344  i = i + 3
1345  100 CONTINUE
1346  CALL icopy( ngrids, work( i ), 1, pval, 1 )
1347  i = i + ngrids
1348  CALL icopy( ngrids, work( i ), 1, qval, 1 )
1349  i = i + ngrids
1350  CALL icopy( nmat, work( i ), 1, mval, 1 )
1351  i = i + nmat
1352  CALL icopy( nmat, work( i ), 1, nval, 1 )
1353  i = i + nmat
1354  CALL icopy( nmat, work( i ), 1, maval, 1 )
1355  i = i + nmat
1356  CALL icopy( nmat, work( i ), 1, naval, 1 )
1357  i = i + nmat
1358  CALL icopy( nmat, work( i ), 1, imbaval, 1 )
1359  i = i + nmat
1360  CALL icopy( nmat, work( i ), 1, inbaval, 1 )
1361  i = i + nmat
1362  CALL icopy( nmat, work( i ), 1, mbaval, 1 )
1363  i = i + nmat
1364  CALL icopy( nmat, work( i ), 1, nbaval, 1 )
1365  i = i + nmat
1366  CALL icopy( nmat, work( i ), 1, rscaval, 1 )
1367  i = i + nmat
1368  CALL icopy( nmat, work( i ), 1, cscaval, 1 )
1369  i = i + nmat
1370  CALL icopy( nmat, work( i ), 1, iaval, 1 )
1371  i = i + nmat
1372  CALL icopy( nmat, work( i ), 1, javal, 1 )
1373  i = i + nmat
1374  CALL icopy( nmat, work( i ), 1, mxval, 1 )
1375  i = i + nmat
1376  CALL icopy( nmat, work( i ), 1, nxval, 1 )
1377  i = i + nmat
1378  CALL icopy( nmat, work( i ), 1, imbxval, 1 )
1379  i = i + nmat
1380  CALL icopy( nmat, work( i ), 1, inbxval, 1 )
1381  i = i + nmat
1382  CALL icopy( nmat, work( i ), 1, mbxval, 1 )
1383  i = i + nmat
1384  CALL icopy( nmat, work( i ), 1, nbxval, 1 )
1385  i = i + nmat
1386  CALL icopy( nmat, work( i ), 1, rscxval, 1 )
1387  i = i + nmat
1388  CALL icopy( nmat, work( i ), 1, cscxval, 1 )
1389  i = i + nmat
1390  CALL icopy( nmat, work( i ), 1, ixval, 1 )
1391  i = i + nmat
1392  CALL icopy( nmat, work( i ), 1, jxval, 1 )
1393  i = i + nmat
1394  CALL icopy( nmat, work( i ), 1, incxval, 1 )
1395  i = i + nmat
1396  CALL icopy( nmat, work( i ), 1, myval, 1 )
1397  i = i + nmat
1398  CALL icopy( nmat, work( i ), 1, nyval, 1 )
1399  i = i + nmat
1400  CALL icopy( nmat, work( i ), 1, imbyval, 1 )
1401  i = i + nmat
1402  CALL icopy( nmat, work( i ), 1, inbyval, 1 )
1403  i = i + nmat
1404  CALL icopy( nmat, work( i ), 1, mbyval, 1 )
1405  i = i + nmat
1406  CALL icopy( nmat, work( i ), 1, nbyval, 1 )
1407  i = i + nmat
1408  CALL icopy( nmat, work( i ), 1, rscyval, 1 )
1409  i = i + nmat
1410  CALL icopy( nmat, work( i ), 1, cscyval, 1 )
1411  i = i + nmat
1412  CALL icopy( nmat, work( i ), 1, iyval, 1 )
1413  i = i + nmat
1414  CALL icopy( nmat, work( i ), 1, jyval, 1 )
1415  i = i + nmat
1416  CALL icopy( nmat, work( i ), 1, incyval, 1 )
1417  i = i + nmat
1418 *
1419  DO 110 j = 1, nsubs
1420  IF( work( i ).EQ.1 ) THEN
1421  ltest( j ) = .true.
1422  ELSE
1423  ltest( j ) = .false.
1424  END IF
1425  i = i + 1
1426  110 CONTINUE
1427 *
1428  END IF
1429 *
1430  CALL blacs_gridexit( ictxt )
1431 *
1432  RETURN
1433 *
1434  120 WRITE( nout, fmt = 9997 )
1435  CLOSE( nin )
1436  IF( nout.NE.6 .AND. nout.NE.0 )
1437  $ CLOSE( nout )
1438  CALL blacs_abort( ictxt, 1 )
1439 *
1440  stop
1441 *
1442  9999 FORMAT( a )
1443  9998 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
1444  $ 'than ', i2 )
1445  9997 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
1446  9996 FORMAT( a7, l2 )
1447  9995 FORMAT( ' Subprogram name ', a7, ' not recognized',
1448  $ /' ******* TESTS ABANDONED *******' )
1449  9994 FORMAT( 2x, 'Alpha : ', g16.6 )
1450  9993 FORMAT( 2x, 'Beta : ', g16.6 )
1451  9992 FORMAT( 2x, 'Number of Tests : ', i6 )
1452  9991 FORMAT( 2x, 'Number of process grids : ', i6 )
1453  9990 FORMAT( 2x, ' : ', 5i6 )
1454  9989 FORMAT( 2x, a1, ' : ', 5i6 )
1455  9988 FORMAT( 2x, 'Routines to be tested : ', a, a8 )
1456  9987 FORMAT( 2x, ' ', a, a8 )
1457  9986 FORMAT( 2x, 'Logical block size : ', i6 )
1458 *
1459 * End of PDBLA2TIMINFO
1460 *
1461  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
pdbla2tim
program pdbla2tim
Definition: pdblas2tim.f:11
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
pdbla2timinfo
subroutine pdbla2timinfo(SUMMRY, NOUT, NMAT, DIAGVAL, TRANVAL, UPLOVAL, MVAL, NVAL, MAVAL, NAVAL, IMBAVAL, MBAVAL, INBAVAL, NBAVAL, RSCAVAL, CSCAVAL, IAVAL, JAVAL, MXVAL, NXVAL, IMBXVAL, MBXVAL, INBXVAL, NBXVAL, RSCXVAL, CSCXVAL, IXVAL, JXVAL, INCXVAL, MYVAL, NYVAL, IMBYVAL, MBYVAL, INBYVAL, NBYVAL, RSCYVAL, CSCYVAL, IYVAL, JYVAL, INCYVAL, LDVAL, NGRIDS, PVAL, LDPVAL, QVAL, LDQVAL, NBLOG, LTEST, IAM, NPROCS, ALPHA, BETA, WORK)
Definition: pdblas2tim.f:701
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
pdlagen
subroutine pdlagen(INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA, DESCA, IASEED, A, LDA)
Definition: pdblastst.f:7845
pdopbl2
double precision function pdopbl2(SUBNAM, M, N, KKL, KKU)
Definition: pblastim.f:1084
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
pvdescchk
subroutine pvdescchk(ICTXT, NOUT, MATRIX, DESCX, DTX, MX, NX, IMBX, INBX, MBX, NBX, RSRCX, CSRCX, INCX, MPX, NQX, IPREX, IMIDX, IPOSTX, IGAP, GAPMUL, INFO)
Definition: pblastst.f:388
pvdimchk
subroutine pvdimchk(ICTXT, NOUT, N, MATRIX, IX, JX, DESCX, INCX, INFO)
Definition: pblastst.f:3
min
#define min(A, B)
Definition: pcgemr.c:181