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