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