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