SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
All Classes Files Functions Variables Typedefs Macros
psblas1tim.f
Go to the documentation of this file.
1 BLOCK DATA
2 INTEGER NSUBS
3 parameter(nsubs = 8)
4 CHARACTER*7 SNAMES( NSUBS )
5 COMMON /snamec/snames
6 DATA snames/'PSSWAP ', 'PSSCAL ', 'PSCOPY ',
7 $ 'PSAXPY ', 'PSDOT ', 'PSNRM2 ',
8 $ 'PSASUM ', 'PSAMAX '/
9 END BLOCK DATA
10
11 PROGRAM psbla1tim
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* PSBLA1TIM is the main timing program for the Level 1 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 40 lines:
25* 'Level 1 PBLAS, Timing input file'
26* 'Intel iPSC/860 hypercube, gamma model.'
27* 'PSBLAS1TIM.SUMM' output file name (if any)
28* 6 device out
29* 1 number of process grids (ordered pairs of P & Q)
30* 2 2 1 4 2 3 8 values of P
31* 2 2 4 1 3 2 1 values of Q
32* 1.0E0 value of ALPHA
33* 2 number of tests problems
34* 3 4 values of N
35* 6 10 values of M_X
36* 6 10 values of N_X
37* 2 5 values of IMB_X
38* 2 5 values of INB_X
39* 2 5 values of MB_X
40* 2 5 values of NB_X
41* 0 1 values of RSRC_X
42* 0 0 values of CSRC_X
43* 1 1 values of IX
44* 1 1 values of JX
45* 1 1 values of INCX
46* 6 10 values of M_Y
47* 6 10 values of N_Y
48* 2 5 values of IMB_Y
49* 2 5 values of INB_Y
50* 2 5 values of MB_Y
51* 2 5 values of NB_Y
52* 0 1 values of RSRC_Y
53* 0 0 values of CSRC_Y
54* 1 1 values of IY
55* 1 1 values of JY
56* 6 1 values of INCY
57* PSSWAP T put F for no test in the same column
58* PSSCAL T put F for no test in the same column
59* PSCOPY T put F for no test in the same column
60* PSAXPY T put F for no test in the same column
61* PSDOT T put F for no test in the same column
62* PSNRM2 T put F for no test in the same column
63* PSASUM T put F for no test in the same column
64* PSAMAX T put F for no test in the same column
65*
66* Internal Parameters
67* ===================
68*
69* TOTMEM INTEGER
70* TOTMEM is a machine-specific parameter indicating the maxi-
71* mum amount of available memory per process in bytes. The
72* user should customize TOTMEM to his platform. Remember to
73* leave room in memory for the operating system, the BLACS
74* buffer, etc. For example, on a system with 8 MB of memory
75* per process (e.g., one processor on an Intel iPSC/860), the
76* parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS,
77* code, BLACS buffer, etc). However, for PVM, we usually set
78* TOTMEM = 2000000. Some experimenting with the maximum value
79* of TOTMEM may be required. By default, TOTMEM is 2000000.
80*
81* REALSZ INTEGER
82* REALSZ indicates the length in bytes on the given platform
83* for a single precision real. By default, REALSZ is set to
84* four.
85*
86* MEM REAL array
87* MEM is an array of dimension TOTMEM / REALSZ.
88* All arrays used by SCALAPACK routines are allocated from this
89* array MEM and referenced by pointers. The integer IPA, for
90* example, is a pointer to the starting element of MEM for the
91* matrix A.
92*
93* -- Written on April 1, 1998 by
94* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
95*
96* =====================================================================
97*
98* .. Parameters ..
99 INTEGER maxtests, maxgrids, realsz, totmem, memsiz,
100 $ nsubs
101 parameter( maxtests = 20, maxgrids = 20, realsz = 4,
102 $ totmem = 2000000, nsubs = 8,
103 $ memsiz = totmem / realsz )
104 INTEGER block_cyclic_2d_inb, csrc_, ctxt_, dlen_,
105 $ dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
106 $ rsrc_
107 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
108 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
109 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
110 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
111* ..
112* .. Local Scalars ..
113 INTEGER csrcx, csrcy, i, iam, ictxt, imbx, imby, imidx,
114 $ imidy, inbx, inby, incx, incy, ipostx, iposty,
115 $ iprex, iprey, ipx, ipy, ix, ixseed, iy, iyseed,
116 $ j, jx, jy, k, mbx, mby, memreqd, mpx, mpy, mx,
117 $ my, mycol, myrow, n, nbx, nby, ngrids, nout,
118 $ npcol, nprocs, nprow, nqx, nqy, ntests, nx, ny,
119 $ pisclr, rsrcx, rsrcy
120 REAL alpha, psclr, pusclr
121 DOUBLE PRECISION adds, cflops, mults, nops, wflops
122* ..
123* .. Local Arrays ..
124 CHARACTER*80 outfile
125 LOGICAL ltest( nsubs ), ycheck( nsubs )
126 INTEGER cscxval( maxtests ), cscyval( maxtests ),
127 $ descx( dlen_ ), descy( dlen_ ), ierr( 2 ),
128 $ imbxval( maxtests ), imbyval( maxtests ),
129 $ inbxval( maxtests ), inbyval( maxtests ),
130 $ incxval( maxtests ), incyval( maxtests ),
131 $ ixval( maxtests ), iyval( maxtests ),
132 $ jxval( maxtests ), jyval( maxtests ),
133 $ mbxval( maxtests ), mbyval( maxtests ),
134 $ mxval( maxtests ), myval( maxtests ),
135 $ nbxval( maxtests ), nbyval( maxtests ),
136 $ nval( maxtests ), nxval( maxtests ),
137 $ nyval( maxtests ), pval( maxtests ),
138 $ qval( maxtests ), rscxval( maxtests ),
139 $ rscyval( maxtests )
140 REAL mem( memsiz )
141 DOUBLE PRECISION ctime( 1 ), wtime( 1 )
142* ..
143* .. External Subroutines ..
144 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
145 $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
146 $ blacs_pinfo, igsum2d, pb_boot, pb_combine,
147 $ pb_timer, psamax, psasum, psaxpy,
148 $ psbla1timinfo, pscopy, psdot, pslagen, psnrm2,
149 $ psscal, psswap, pvdescchk, pvdimchk
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC dble
153* ..
154* .. Common Blocks ..
155 CHARACTER*7 snames( nsubs )
156 LOGICAL abrtflg
157 INTEGER info, nblog
158 COMMON /snamec/snames
159 COMMON /infoc/info, nblog
160 COMMON /pberrorc/nout, abrtflg
161* ..
162* .. Data Statements ..
163 DATA ycheck/.true., .false., .true., .true., .true.,
164 $ .false., .false., .false./
165* ..
166* .. Executable Statements ..
167*
168* Initialization
169*
170* Set flag so that the PBLAS error handler won't abort on errors, so
171* that the tester will detect unsupported operations.
172*
173 abrtflg = .false.
174*
175* Seeds for random matrix generations.
176*
177 ixseed = 100
178 iyseed = 200
179*
180* Get starting information
181*
182 CALL blacs_pinfo( iam, nprocs )
183 CALL psbla1timinfo( outfile, nout, ntests, nval, mxval, nxval,
184 $ imbxval, mbxval, inbxval, nbxval, rscxval,
185 $ cscxval, ixval, jxval, incxval, myval,
186 $ nyval, imbyval, mbyval, inbyval, nbyval,
187 $ rscyval, cscyval, iyval, jyval, incyval,
188 $ maxtests, ngrids, pval, maxgrids, qval,
189 $ maxgrids, ltest, iam, nprocs, alpha, mem )
190*
191 IF( iam.EQ.0 )
192 $ WRITE( nout, fmt = 9986 )
193*
194* Loop over different process grids
195*
196 DO 60 i = 1, ngrids
197*
198 nprow = pval( i )
199 npcol = qval( i )
200*
201* Make sure grid information is correct
202*
203 ierr( 1 ) = 0
204 IF( nprow.LT.1 ) THEN
205 IF( iam.EQ.0 )
206 $ WRITE( nout, fmt = 9999 ) 'GRID SIZE', 'NPROW', nprow
207 ierr( 1 ) = 1
208 ELSE IF( npcol.LT.1 ) THEN
209 IF( iam.EQ.0 )
210 $ WRITE( nout, fmt = 9999 ) 'GRID SIZE', 'NPCOL', npcol
211 ierr( 1 ) = 1
212 ELSE IF( nprow*npcol.GT.nprocs ) THEN
213 IF( iam.EQ.0 )
214 $ WRITE( nout, fmt = 9998 ) nprow*npcol, nprocs
215 ierr( 1 ) = 1
216 END IF
217*
218 IF( ierr( 1 ).GT.0 ) THEN
219 IF( iam.EQ.0 )
220 $ WRITE( nout, fmt = 9997 ) 'GRID'
221 GO TO 60
222 END IF
223*
224* Define process grid
225*
226 CALL blacs_get( -1, 0, ictxt )
227 CALL blacs_gridinit( ictxt, 'Row-major', nprow, npcol )
228 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
229*
230* Go to bottom of process grid loop if this case doesn't use my
231* process
232*
233 IF( myrow.GE.nprow .OR. mycol.GE.npcol )
234 $ GO TO 60
235*
236* Loop over number of tests
237*
238 DO 50 j = 1, ntests
239*
240* Get the test parameters
241*
242 n = nval( j )
243 mx = mxval( j )
244 nx = nxval( j )
245 imbx = imbxval( j )
246 mbx = mbxval( j )
247 inbx = inbxval( j )
248 nbx = nbxval( j )
249 rsrcx = rscxval( j )
250 csrcx = cscxval( j )
251 ix = ixval( j )
252 jx = jxval( j )
253 incx = incxval( j )
254 my = myval( j )
255 ny = nyval( j )
256 imby = imbyval( j )
257 mby = mbyval( j )
258 inby = inbyval( j )
259 nby = nbyval( j )
260 rsrcy = rscyval( j )
261 csrcy = cscyval( j )
262 iy = iyval( j )
263 jy = jyval( j )
264 incy = incyval( j )
265*
266 IF( iam.EQ.0 ) THEN
267 WRITE( nout, fmt = * )
268 WRITE( nout, fmt = 9996 ) j, nprow, npcol
269 WRITE( nout, fmt = * )
270*
271 WRITE( nout, fmt = 9995 )
272 WRITE( nout, fmt = 9994 )
273 WRITE( nout, fmt = 9995 )
274 WRITE( nout, fmt = 9993 ) n, ix, jx, mx, nx, imbx, inbx,
275 $ mbx, nbx, rsrcx, csrcx, incx
276*
277 WRITE( nout, fmt = 9995 )
278 WRITE( nout, fmt = 9992 )
279 WRITE( nout, fmt = 9995 )
280 WRITE( nout, fmt = 9993 ) n, iy, jy, my, ny, imby, inby,
281 $ mby, nby, rsrcy, csrcy, incy
282 WRITE( nout, fmt = 9995 )
283 WRITE( nout, fmt = 9983 )
284 END IF
285*
286* Check the validity of the input and initialize DESC_
287*
288 CALL pvdescchk( ictxt, nout, 'X', descx,
289 $ block_cyclic_2d_inb, mx, nx, imbx, inbx,
290 $ mbx, nbx, rsrcx, csrcx, incx, mpx, nqx,
291 $ iprex, imidx, ipostx, 0, 0, ierr( 1 ) )
292 CALL pvdescchk( ictxt, nout, 'Y', descy,
293 $ block_cyclic_2d_inb, my, ny, imby, inby,
294 $ mby, nby, rsrcy, csrcy, incy, mpy, nqy,
295 $ iprey, imidy, iposty, 0, 0, ierr( 2 ) )
296*
297 IF( ierr( 1 ).GT.0 .OR. ierr( 2 ).GT.0 )
298 $ GO TO 40
299*
300* Assign pointers into MEM for matrices corresponding to
301* vectors X and Y. Ex: IPX starts at position MEM( 1 ).
302*
303 ipx = 1
304 ipy = ipx + descx( lld_ ) * nqx
305*
306* Check if sufficient memory.
307*
308 memreqd = ipy + descy( lld_ ) * nqy - 1
309 ierr( 1 ) = 0
310 IF( memreqd.GT.memsiz ) THEN
311 IF( iam.EQ.0 )
312 $ WRITE( nout, fmt = 9990 ) memreqd*realsz
313 ierr( 1 ) = 1
314 END IF
315*
316* Check all processes for an error
317*
318 CALL igsum2d( ictxt, 'All', ' ', 1, 1, ierr, 1, -1, 0 )
319*
320 IF( ierr( 1 ).GT.0 ) THEN
321 IF( iam.EQ.0 )
322 $ WRITE( nout, fmt = 9991 )
323 GO TO 40
324 END IF
325*
326* Loop over all PBLAS 1 routines
327*
328 DO 30 k = 1, nsubs
329*
330* Continue only if this sub has to be tested.
331*
332 IF( .NOT.ltest( k ) )
333 $ GO TO 30
334*
335* Check the validity of the operand sizes
336*
337 CALL pvdimchk( ictxt, nout, n, 'X', ix, jx, descx, incx,
338 $ ierr( 1 ) )
339 CALL pvdimchk( ictxt, nout, n, 'Y', iy, jy, descy, incy,
340 $ ierr( 2 ) )
341*
342 IF( ierr( 1 ).NE.0 .OR. ierr( 2 ).NE.0 )
343 $ GO TO 30
344*
345* Generate distributed matrices X and Y
346*
347 CALL pslagen( .false., 'None', 'No diag', 0, mx, nx, 1,
348 $ 1, descx, ixseed, mem( ipx ),
349 $ descx( lld_ ) )
350 IF( ycheck( k ) )
351 $ CALL pslagen( .false., 'None', 'No diag', 0, my, ny,
352 $ 1, 1, descy, iyseed, mem( ipy ),
353 $ descy( lld_ ) )
354*
355 info = 0
356 CALL pb_boot()
357 CALL blacs_barrier( ictxt, 'All' )
358*
359* Call the PBLAS routine
360*
361 IF( k.EQ.1 ) THEN
362*
363* Test PSSWAP
364*
365 adds = 0.0d+0
366 mults = 0.0d+0
367 CALL pb_timer( 1 )
368 CALL psswap( n, mem( ipx ), ix, jx, descx, incx,
369 $ mem( ipy ), iy, jy, descy, incy )
370 CALL pb_timer( 1 )
371*
372 ELSE IF( k.EQ.2 ) THEN
373*
374* Test PSSCAL
375*
376 adds = 0.0d+0
377 mults = dble( n )
378 CALL pb_timer( 1 )
379 CALL psscal( n, alpha, mem( ipx ), ix, jx, descx,
380 $ incx )
381 CALL pb_timer( 1 )
382*
383 ELSE IF( k.EQ.3 ) THEN
384*
385* Test PSCOPY
386*
387 adds = 0.0d+0
388 mults = 0.0d+0
389 CALL pb_timer( 1 )
390 CALL pscopy( n, mem( ipx ), ix, jx, descx, incx,
391 $ mem( ipy ), iy, jy, descy, incy )
392 CALL pb_timer( 1 )
393*
394 ELSE IF( k.EQ.4 ) THEN
395*
396* Test PSAXPY
397*
398 adds = dble( n )
399 mults = dble( n )
400 CALL pb_timer( 1 )
401 CALL psaxpy( n, alpha, mem( ipx ), ix, jx, descx,
402 $ incx, mem( ipy ), iy, jy, descy, incy )
403 CALL pb_timer( 1 )
404*
405 ELSE IF( k.EQ.5 ) THEN
406*
407* Test PSDOT
408*
409 adds = dble( n-1 )
410 mults = dble( n )
411 CALL pb_timer( 1 )
412 CALL psdot( n, psclr, mem( ipx ), ix, jx, descx, incx,
413 $ mem( ipy ), iy, jy, descy, incy )
414 CALL pb_timer( 1 )
415*
416 ELSE IF( k.EQ.6 ) THEN
417*
418* Test PSNRM2
419*
420 adds = dble( n-1 )
421 mults = dble( n )
422 CALL pb_timer( 1 )
423 CALL psnrm2( n, pusclr, mem( ipx ), ix, jx, descx,
424 $ incx )
425 CALL pb_timer( 1 )
426*
427 ELSE IF( k.EQ.7 ) THEN
428*
429* Test PSASUM
430*
431 adds = dble( n - 1 )
432 mults = 0.0d+0
433 CALL pb_timer( 1 )
434 CALL psasum( n, pusclr, mem( ipx ), ix, jx, descx,
435 $ incx )
436 CALL pb_timer( 1 )
437*
438 ELSE IF( k.EQ.8 ) THEN
439*
440 adds = 0.0d+0
441 mults = 0.0d+0
442 CALL pb_timer( 1 )
443 CALL psamax( n, psclr, pisclr, mem( ipx ), ix, jx,
444 $ descx, incx )
445 CALL pb_timer( 1 )
446*
447 END IF
448*
449* Check if the operation has been performed.
450*
451 IF( info.NE.0 ) THEN
452 IF( iam.EQ.0 )
453 $ WRITE( nout, fmt = 9985 ) info
454 GO TO 30
455 END IF
456*
457 CALL pb_combine( ictxt, 'All', '>', 'W', 1, 1, wtime )
458 CALL pb_combine( ictxt, 'All', '>', 'C', 1, 1, ctime )
459*
460* Only node 0 prints timing test result
461*
462 IF( iam.EQ.0 ) THEN
463*
464* Calculate total flops
465*
466 nops = adds + mults
467*
468* Print WALL time if machine supports it
469*
470 IF( wtime( 1 ).GT.0.0d+0 ) THEN
471 wflops = nops / ( wtime( 1 ) * 1.0d+6 )
472 ELSE
473 wflops = 0.0d+0
474 END IF
475*
476* Print CPU time if machine supports it
477*
478 IF( ctime( 1 ).GT.0.0d+0 ) THEN
479 cflops = nops / ( ctime( 1 ) * 1.0d+6 )
480 ELSE
481 cflops = 0.0d+0
482 END IF
483*
484 WRITE( nout, fmt = 9984 ) snames( k ), wtime( 1 ),
485 $ wflops, ctime( 1 ), cflops
486*
487 END IF
488*
489 30 CONTINUE
490*
491 40 IF( iam.EQ.0 ) THEN
492 WRITE( nout, fmt = 9995 )
493 WRITE( nout, fmt = * )
494 WRITE( nout, fmt = 9988 ) j
495 END IF
496*
497 50 CONTINUE
498*
499 IF( iam.EQ.0 ) THEN
500 WRITE( nout, fmt = * )
501 WRITE( nout, fmt = 9987 )
502 WRITE( nout, fmt = * )
503 END IF
504*
505 CALL blacs_gridexit( ictxt )
506*
507 60 CONTINUE
508*
509 CALL blacs_exit( 0 )
510*
511 9999 FORMAT( 'ILLEGAL ', a, ': ', a, ' = ', i10,
512 $ ' should be at least 1' )
513 9998 FORMAT( 'ILLEGAL GRID: NPROW*NPCOL = ', i4,
514 $ '. It can be at most', i4 )
515 9997 FORMAT( 'Bad ', a, ' parameters: going on to next test case.' )
516 9996 FORMAT( 2x, 'Test number ', i2 , ' started on a ', i4, ' x ',
517 $ i4, ' process grid.' )
518 9995 FORMAT( 2x, '---------------------------------------------------',
519 $ '--------------------------' )
520 9994 FORMAT( 2x, ' N IX JX MX NX IMBX INBX',
521 $ ' MBX NBX RSRCX CSRCX INCX' )
522 9993 FORMAT( 2x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i5,1x,i5,1x,i5,1x,i5,1x,
523 $ i5,1x,i5,1x,i6 )
524 9992 FORMAT( 2x, ' N IY JY MY NY IMBY INBY',
525 $ ' MBY NBY RSRCY CSRCY INCY' )
526 9991 FORMAT( 'Not enough memory for this test: going on to',
527 $ ' next test case.' )
528 9990 FORMAT( 'Not enough memory. Need: ', i12 )
529 9988 FORMAT( 2x, 'Test number ', i2, ' completed.' )
530 9987 FORMAT( 2x, 'End of Tests.' )
531 9986 FORMAT( 2x, 'Tests started.' )
532 9985 FORMAT( 2x, ' ***** Operation not supported, error code: ',
533 $ i5, ' *****' )
534 9984 FORMAT( 2x, '| ', a, 2x, f13.3, 2x, f13.3, 2x, f13.3, 2x, f13.3 )
535 9983 FORMAT( 2x, ' WALL time (s) WALL Mflops ',
536 $ ' CPU time (s) CPU Mflops' )
537*
538 stop
539*
540* End of PSBLA1TIM
541*
542 END
543 SUBROUTINE psbla1timinfo( SUMMRY, NOUT, NMAT, NVAL, MXVAL, NXVAL,
544 $ IMBXVAL, MBXVAL, INBXVAL, NBXVAL,
545 $ RSCXVAL, CSCXVAL, IXVAL, JXVAL,
546 $ INCXVAL, MYVAL, NYVAL, IMBYVAL, MBYVAL,
547 $ INBYVAL, NBYVAL, RSCYVAL, CSCYVAL,
548 $ IYVAL, JYVAL, INCYVAL, LDVAL, NGRIDS,
549 $ PVAL, LDPVAL, QVAL, LDQVAL, LTEST, IAM,
550 $ NPROCS, ALPHA, WORK )
551*
552* -- PBLAS test routine (version 2.0) --
553* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
554* and University of California, Berkeley.
555* April 1, 1998
556*
557* .. Scalar Arguments ..
558 INTEGER IAM, LDPVAL, LDQVAL, LDVAL, NGRIDS, NMAT, NOUT,
559 $ NPROCS
560 REAL ALPHA
561* ..
562* .. Array Arguments ..
563 CHARACTER*( * ) SUMMRY
564 LOGICAL LTEST( * )
565 INTEGER CSCXVAL( LDVAL ), CSCYVAL( LDVAL ),
566 $ IMBXVAL( LDVAL ), IMBYVAL( LDVAL ),
567 $ inbxval( ldval ), inbyval( ldval ),
568 $ incxval( ldval ), incyval( ldval ),
569 $ ixval( ldval ), iyval( ldval ), jxval( ldval ),
570 $ jyval( ldval ), mbxval( ldval ),
571 $ mbyval( ldval ), mxval( ldval ),
572 $ myval( ldval ), nbxval( ldval ),
573 $ nbyval( ldval ), nval( ldval ), nxval( ldval ),
574 $ nyval( ldval ), pval( ldpval ), qval( ldqval ),
575 $ rscxval( ldval ), rscyval( ldval ), work( * )
576* ..
577*
578* Purpose
579* =======
580*
581* PSBLA1TIMINFO get the needed startup information for timing various
582* Level 1 PBLAS routines, and transmits it to all processes.
583*
584* Notes
585* =====
586*
587* For packing the information we assumed that the length in bytes of an
588* integer is equal to the length in bytes of a real single precision.
589*
590* Arguments
591* =========
592*
593* SUMMRY (global output) CHARACTER*(*)
594* On exit, SUMMRY is the name of output (summary) file (if
595* any). SUMMRY is only defined for process 0.
596*
597* NOUT (global output) INTEGER
598* On exit, NOUT specifies the unit number for the output file.
599* When NOUT is 6, output to screen, when NOUT is 0, output to
600* stderr. NOUT is only defined for process 0.
601*
602* NMAT (global output) INTEGER
603* On exit, NMAT specifies the number of different test cases.
604*
605* NVAL (global output) INTEGER array
606* On entry, NVAL is an array of dimension LDVAL. On exit, this
607* array contains the values of N to run the code with.
608*
609* MXVAL (global output) INTEGER array
610* On entry, MXVAL is an array of dimension LDVAL. On exit, this
611* array contains the values of DESCX( M_ ) to run the code
612* with.
613*
614* NXVAL (global output) INTEGER array
615* On entry, NXVAL is an array of dimension LDVAL. On exit, this
616* array contains the values of DESCX( N_ ) to run the code
617* with.
618*
619* IMBXVAL (global output) INTEGER array
620* On entry, IMBXVAL is an array of dimension LDVAL. On exit,
621* this array contains the values of DESCX( IMB_ ) to run the
622* code with.
623*
624* MBXVAL (global output) INTEGER array
625* On entry, MBXVAL is an array of dimension LDVAL. On exit,
626* this array contains the values of DESCX( MB_ ) to run the
627* code with.
628*
629* INBXVAL (global output) INTEGER array
630* On entry, INBXVAL is an array of dimension LDVAL. On exit,
631* this array contains the values of DESCX( INB_ ) to run the
632* code with.
633*
634* NBXVAL (global output) INTEGER array
635* On entry, NBXVAL is an array of dimension LDVAL. On exit,
636* this array contains the values of DESCX( NB_ ) to run the
637* code with.
638*
639* RSCXVAL (global output) INTEGER array
640* On entry, RSCXVAL is an array of dimension LDVAL. On exit,
641* this array contains the values of DESCX( RSRC_ ) to run the
642* code with.
643*
644* CSCXVAL (global output) INTEGER array
645* On entry, CSCXVAL is an array of dimension LDVAL. On exit,
646* this array contains the values of DESCX( CSRC_ ) to run the
647* code with.
648*
649* IXVAL (global output) INTEGER array
650* On entry, IXVAL is an array of dimension LDVAL. On exit, this
651* array contains the values of IX to run the code with.
652*
653* JXVAL (global output) INTEGER array
654* On entry, JXVAL is an array of dimension LDVAL. On exit, this
655* array contains the values of JX to run the code with.
656*
657* INCXVAL (global output) INTEGER array
658* On entry, INCXVAL is an array of dimension LDVAL. On exit,
659* this array contains the values of INCX to run the code with.
660*
661* MYVAL (global output) INTEGER array
662* On entry, MYVAL is an array of dimension LDVAL. On exit, this
663* array contains the values of DESCY( M_ ) to run the code
664* with.
665*
666* NYVAL (global output) INTEGER array
667* On entry, NYVAL is an array of dimension LDVAL. On exit, this
668* array contains the values of DESCY( N_ ) to run the code
669* with.
670*
671* IMBYVAL (global output) INTEGER array
672* On entry, IMBYVAL is an array of dimension LDVAL. On exit,
673* this array contains the values of DESCY( IMB_ ) to run the
674* code with.
675*
676* MBYVAL (global output) INTEGER array
677* On entry, MBYVAL is an array of dimension LDVAL. On exit,
678* this array contains the values of DESCY( MB_ ) to run the
679* code with.
680*
681* INBYVAL (global output) INTEGER array
682* On entry, INBYVAL is an array of dimension LDVAL. On exit,
683* this array contains the values of DESCY( INB_ ) to run the
684* code with.
685*
686* NBYVAL (global output) INTEGER array
687* On entry, NBYVAL is an array of dimension LDVAL. On exit,
688* this array contains the values of DESCY( NB_ ) to run the
689* code with.
690*
691* RSCYVAL (global output) INTEGER array
692* On entry, RSCYVAL is an array of dimension LDVAL. On exit,
693* this array contains the values of DESCY( RSRC_ ) to run the
694* code with.
695*
696* CSCYVAL (global output) INTEGER array
697* On entry, CSCYVAL is an array of dimension LDVAL. On exit,
698* this array contains the values of DESCY( CSRC_ ) to run the
699* code with.
700*
701* IYVAL (global output) INTEGER array
702* On entry, IYVAL is an array of dimension LDVAL. On exit, this
703* array contains the values of IY to run the code with.
704*
705* JYVAL (global output) INTEGER array
706* On entry, JYVAL is an array of dimension LDVAL. On exit, this
707* array contains the values of JY to run the code with.
708*
709* INCYVAL (global output) INTEGER array
710* On entry, INCYVAL is an array of dimension LDVAL. On exit,
711* this array contains the values of INCY to run the code with.
712*
713* LDVAL (global input) INTEGER
714* On entry, LDVAL specifies the maximum number of different va-
715* lues that can be used for DESCX(:), IX, JX, INCX, DESCY(:),
716* IY, JY and INCY. This is also the maximum number of test
717* cases.
718*
719* NGRIDS (global output) INTEGER
720* On exit, NGRIDS specifies the number of different values that
721* can be used for P and Q.
722*
723* PVAL (global output) INTEGER array
724* On entry, PVAL is an array of dimension LDPVAL. On exit, this
725* array contains the values of P to run the code with.
726*
727* LDPVAL (global input) INTEGER
728* On entry, LDPVAL specifies the maximum number of different
729* values that can be used for P.
730*
731* QVAL (global output) INTEGER array
732* On entry, QVAL is an array of dimension LDQVAL. On exit, this
733* array contains the values of Q to run the code with.
734*
735* LDQVAL (global input) INTEGER
736* On entry, LDQVAL specifies the maximum number of different
737* values that can be used for Q.
738*
739* LTEST (global output) LOGICAL array
740* On entry, LTEST is an array of dimension at least eight. On
741* exit, if LTEST( i ) is .TRUE., the i-th Level 1 PBLAS routine
742* will be tested. See the input file for the ordering of the
743* routines.
744*
745* IAM (local input) INTEGER
746* On entry, IAM specifies the number of the process executing
747* this routine.
748*
749* NPROCS (global input) INTEGER
750* On entry, NPROCS specifies the total number of processes.
751*
752* ALPHA (global output) REAL
753* On exit, ALPHA specifies the value of alpha to be used in all
754* the test cases.
755*
756* WORK (local workspace) INTEGER array
757* On entry, WORK is an array of dimension at least
758* MAX( 2, 2*NGRIDS+23*NMAT+NSUBS ) with NSUBS = 8. This array
759* is used to pack all output arrays in order to send info in
760* one message.
761*
762* -- Written on April 1, 1998 by
763* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
764*
765* =====================================================================
766*
767* .. Parameters ..
768 INTEGER NIN, NSUBS
769 PARAMETER ( NIN = 11, nsubs = 8 )
770* ..
771* .. Local Scalars ..
772 LOGICAL LTESTT
773 INTEGER I, ICTXT, J
774* ..
775* .. Local Arrays ..
776 CHARACTER*7 SNAMET
777 CHARACTER*79 USRINFO
778* ..
779* .. External Subroutines ..
780 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
781 $ blacs_gridinit, blacs_setup, icopy, igebr2d,
782 $ igebs2d, sgebr2d, sgebs2d
783* ..
784* .. Intrinsic Functions ..
785 INTRINSIC max, min
786* ..
787* .. Common Blocks ..
788 CHARACTER*7 SNAMES( NSUBS )
789 COMMON /SNAMEC/SNAMES
790* ..
791* .. Executable Statements ..
792*
793*
794* Process 0 reads the input data, broadcasts to other processes and
795* writes needed information to NOUT
796*
797 IF( iam.EQ.0 ) THEN
798*
799* Open file and skip data file header
800*
801 OPEN( nin, file='PSBLAS1TIM.dat', status='OLD' )
802 READ( nin, fmt = * ) summry
803 summry = ' '
804*
805* Read in user-supplied info about machine type, compiler, etc.
806*
807 READ( nin, fmt = 9999 ) usrinfo
808*
809* Read name and unit number for summary output file
810*
811 READ( nin, fmt = * ) summry
812 READ( nin, fmt = * ) nout
813 IF( nout.NE.0 .AND. nout.NE.6 )
814 $ OPEN( nout, file = summry, status = 'UNKNOWN' )
815*
816* Read and check the parameter values for the tests.
817*
818* Get number of grids
819*
820 READ( nin, fmt = * ) ngrids
821 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
822 WRITE( nout, fmt = 9998 ) 'Grids', ldpval
823 GO TO 100
824 ELSE IF( ngrids.GT.ldqval ) THEN
825 WRITE( nout, fmt = 9998 ) 'Grids', ldqval
826 GO TO 100
827 END IF
828*
829* Get values of P and Q
830*
831 READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
832 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
833*
834* Read ALPHA
835*
836 READ( nin, fmt = * ) alpha
837*
838* Read number of tests.
839*
840 READ( nin, fmt = * ) nmat
841 IF( nmat.LT.1 .OR. nmat.GT.ldval ) THEN
842 WRITE( nout, fmt = 9998 ) 'Tests', ldval
843 GO TO 100
844 END IF
845*
846* Read in input data into arrays.
847*
848 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
849 READ( nin, fmt = * ) ( mxval( i ), i = 1, nmat )
850 READ( nin, fmt = * ) ( nxval( i ), i = 1, nmat )
851 READ( nin, fmt = * ) ( imbxval( i ), i = 1, nmat )
852 READ( nin, fmt = * ) ( inbxval( i ), i = 1, nmat )
853 READ( nin, fmt = * ) ( mbxval( i ), i = 1, nmat )
854 READ( nin, fmt = * ) ( nbxval( i ), i = 1, nmat )
855 READ( nin, fmt = * ) ( rscxval( i ), i = 1, nmat )
856 READ( nin, fmt = * ) ( cscxval( i ), i = 1, nmat )
857 READ( nin, fmt = * ) ( ixval( i ), i = 1, nmat )
858 READ( nin, fmt = * ) ( jxval( i ), i = 1, nmat )
859 READ( nin, fmt = * ) ( incxval( i ), i = 1, nmat )
860 READ( nin, fmt = * ) ( myval( i ), i = 1, nmat )
861 READ( nin, fmt = * ) ( nyval( i ), i = 1, nmat )
862 READ( nin, fmt = * ) ( imbyval( i ), i = 1, nmat )
863 READ( nin, fmt = * ) ( inbyval( i ), i = 1, nmat )
864 READ( nin, fmt = * ) ( mbyval( i ), i = 1, nmat )
865 READ( nin, fmt = * ) ( nbyval( i ), i = 1, nmat )
866 READ( nin, fmt = * ) ( rscyval( i ), i = 1, nmat )
867 READ( nin, fmt = * ) ( cscyval( i ), i = 1, nmat )
868 READ( nin, fmt = * ) ( iyval( i ), i = 1, nmat )
869 READ( nin, fmt = * ) ( jyval( i ), i = 1, nmat )
870 READ( nin, fmt = * ) ( incyval( i ), i = 1, nmat )
871*
872* Read names of subroutines and flags which indicate
873* whether they are to be tested.
874*
875 DO 10 i = 1, nsubs
876 ltest( i ) = .false.
877 10 CONTINUE
878 20 CONTINUE
879 READ( nin, fmt = 9996, END = 50 ) SNAMET, ltestt
880 DO 30 i = 1, nsubs
881 IF( snamet.EQ.snames( i ) )
882 $ GO TO 40
883 30 CONTINUE
884*
885 WRITE( nout, fmt = 9995 )snamet
886 GO TO 100
887*
888 40 CONTINUE
889 ltest( i ) = ltestt
890 GO TO 20
891*
892 50 CONTINUE
893*
894* Close input file
895*
896 CLOSE ( nin )
897*
898* For pvm only: if virtual machine not set up, allocate it and
899* spawn the correct number of processes.
900*
901 IF( nprocs.LT.1 ) THEN
902 nprocs = 0
903 DO 60 i = 1, ngrids
904 nprocs = max( nprocs, pval( i )*qval( i ) )
905 60 CONTINUE
906 CALL blacs_setup( iam, nprocs )
907 END IF
908*
909* Temporarily define blacs grid to include all processes so
910* information can be broadcast to all processes
911*
912 CALL blacs_get( -1, 0, ictxt )
913 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
914*
915* Pack information arrays and broadcast
916*
917 CALL sgebs2d( ictxt, 'All', ' ', 1, 1, alpha, 1 )
918*
919 work( 1 ) = ngrids
920 work( 2 ) = nmat
921 CALL igebs2d( ictxt, 'All', ' ', 2, 1, work, 2 )
922*
923 i = 1
924 CALL icopy( ngrids, pval, 1, work( i ), 1 )
925 i = i + ngrids
926 CALL icopy( ngrids, qval, 1, work( i ), 1 )
927 i = i + ngrids
928 CALL icopy( nmat, nval, 1, work( i ), 1 )
929 i = i + nmat
930 CALL icopy( nmat, mxval, 1, work( i ), 1 )
931 i = i + nmat
932 CALL icopy( nmat, nxval, 1, work( i ), 1 )
933 i = i + nmat
934 CALL icopy( nmat, imbxval, 1, work( i ), 1 )
935 i = i + nmat
936 CALL icopy( nmat, inbxval, 1, work( i ), 1 )
937 i = i + nmat
938 CALL icopy( nmat, mbxval, 1, work( i ), 1 )
939 i = i + nmat
940 CALL icopy( nmat, nbxval, 1, work( i ), 1 )
941 i = i + nmat
942 CALL icopy( nmat, rscxval, 1, work( i ), 1 )
943 i = i + nmat
944 CALL icopy( nmat, cscxval, 1, work( i ), 1 )
945 i = i + nmat
946 CALL icopy( nmat, ixval, 1, work( i ), 1 )
947 i = i + nmat
948 CALL icopy( nmat, jxval, 1, work( i ), 1 )
949 i = i + nmat
950 CALL icopy( nmat, incxval, 1, work( i ), 1 )
951 i = i + nmat
952 CALL icopy( nmat, myval, 1, work( i ), 1 )
953 i = i + nmat
954 CALL icopy( nmat, nyval, 1, work( i ), 1 )
955 i = i + nmat
956 CALL icopy( nmat, imbyval, 1, work( i ), 1 )
957 i = i + nmat
958 CALL icopy( nmat, inbyval, 1, work( i ), 1 )
959 i = i + nmat
960 CALL icopy( nmat, mbyval, 1, work( i ), 1 )
961 i = i + nmat
962 CALL icopy( nmat, nbyval, 1, work( i ), 1 )
963 i = i + nmat
964 CALL icopy( nmat, rscyval, 1, work( i ), 1 )
965 i = i + nmat
966 CALL icopy( nmat, cscyval, 1, work( i ), 1 )
967 i = i + nmat
968 CALL icopy( nmat, iyval, 1, work( i ), 1 )
969 i = i + nmat
970 CALL icopy( nmat, jyval, 1, work( i ), 1 )
971 i = i + nmat
972 CALL icopy( nmat, incyval, 1, work( i ), 1 )
973 i = i + nmat
974*
975 DO 70 j = 1, nsubs
976 IF( ltest( j ) ) THEN
977 work( i ) = 1
978 ELSE
979 work( i ) = 0
980 END IF
981 i = i + 1
982 70 CONTINUE
983 i = i - 1
984 CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
985*
986* regurgitate input
987*
988 WRITE( nout, fmt = 9999 )
989 $ 'Level 1 PBLAS timing program.'
990 WRITE( nout, fmt = 9999 ) usrinfo
991 WRITE( nout, fmt = * )
992 WRITE( nout, fmt = 9999 )
993 $ 'Timing of the real single precision '//
994 $ 'Level 1 PBLAS'
995 WRITE( nout, fmt = * )
996 WRITE( nout, fmt = 9999 )
997 $ 'The following parameter values will be used:'
998 WRITE( nout, fmt = * )
999 WRITE( nout, fmt = 9993 ) nmat
1000 WRITE( nout, fmt = 9992 ) ngrids
1001 WRITE( nout, fmt = 9990 )
1002 $ 'P', ( pval(i), i = 1, min(ngrids, 5) )
1003 IF( ngrids.GT.5 )
1004 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 6,
1005 $ min( 10, ngrids ) )
1006 IF( ngrids.GT.10 )
1007 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 11,
1008 $ min( 15, ngrids ) )
1009 IF( ngrids.GT.15 )
1010 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 16, ngrids )
1011 WRITE( nout, fmt = 9990 )
1012 $ 'Q', ( qval(i), i = 1, min(ngrids, 5) )
1013 IF( ngrids.GT.5 )
1014 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 6,
1015 $ min( 10, ngrids ) )
1016 IF( ngrids.GT.10 )
1017 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 11,
1018 $ min( 15, ngrids ) )
1019 IF( ngrids.GT.15 )
1020 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 16, ngrids )
1021 WRITE( nout, fmt = 9994 ) alpha
1022 IF( ltest( 1 ) ) THEN
1023 WRITE( nout, fmt = 9989 ) snames( 1 ), ' ... Yes'
1024 ELSE
1025 WRITE( nout, fmt = 9989 ) snames( 1 ), ' ... No '
1026 END IF
1027 DO 80 i = 2, nsubs
1028 IF( ltest( i ) ) THEN
1029 WRITE( nout, fmt = 9988 ) snames( i ), ' ... Yes'
1030 ELSE
1031 WRITE( nout, fmt = 9988 ) snames( i ), ' ... No '
1032 END IF
1033 80 CONTINUE
1034 WRITE( nout, fmt = * )
1035*
1036 ELSE
1037*
1038* If in pvm, must participate setting up virtual machine
1039*
1040 IF( nprocs.LT.1 )
1041 $ CALL blacs_setup( iam, nprocs )
1042*
1043* Temporarily define blacs grid to include all processes so
1044* information can be broadcast to all processes
1045*
1046 CALL blacs_get( -1, 0, ictxt )
1047 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1048*
1049 CALL sgebr2d( ictxt, 'All', ' ', 1, 1, alpha, 1, 0, 0 )
1050*
1051 CALL igebr2d( ictxt, 'All', ' ', 2, 1, work, 2, 0, 0 )
1052 ngrids = work( 1 )
1053 nmat = work( 2 )
1054*
1055 i = 2*ngrids + 23*nmat + nsubs
1056 CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
1057*
1058 i = 1
1059 CALL icopy( ngrids, work( i ), 1, pval, 1 )
1060 i = i + ngrids
1061 CALL icopy( ngrids, work( i ), 1, qval, 1 )
1062 i = i + ngrids
1063 CALL icopy( nmat, work( i ), 1, nval, 1 )
1064 i = i + nmat
1065 CALL icopy( nmat, work( i ), 1, mxval, 1 )
1066 i = i + nmat
1067 CALL icopy( nmat, work( i ), 1, nxval, 1 )
1068 i = i + nmat
1069 CALL icopy( nmat, work( i ), 1, imbxval, 1 )
1070 i = i + nmat
1071 CALL icopy( nmat, work( i ), 1, inbxval, 1 )
1072 i = i + nmat
1073 CALL icopy( nmat, work( i ), 1, mbxval, 1 )
1074 i = i + nmat
1075 CALL icopy( nmat, work( i ), 1, nbxval, 1 )
1076 i = i + nmat
1077 CALL icopy( nmat, work( i ), 1, rscxval, 1 )
1078 i = i + nmat
1079 CALL icopy( nmat, work( i ), 1, cscxval, 1 )
1080 i = i + nmat
1081 CALL icopy( nmat, work( i ), 1, ixval, 1 )
1082 i = i + nmat
1083 CALL icopy( nmat, work( i ), 1, jxval, 1 )
1084 i = i + nmat
1085 CALL icopy( nmat, work( i ), 1, incxval, 1 )
1086 i = i + nmat
1087 CALL icopy( nmat, work( i ), 1, myval, 1 )
1088 i = i + nmat
1089 CALL icopy( nmat, work( i ), 1, nyval, 1 )
1090 i = i + nmat
1091 CALL icopy( nmat, work( i ), 1, imbyval, 1 )
1092 i = i + nmat
1093 CALL icopy( nmat, work( i ), 1, inbyval, 1 )
1094 i = i + nmat
1095 CALL icopy( nmat, work( i ), 1, mbyval, 1 )
1096 i = i + nmat
1097 CALL icopy( nmat, work( i ), 1, nbyval, 1 )
1098 i = i + nmat
1099 CALL icopy( nmat, work( i ), 1, rscyval, 1 )
1100 i = i + nmat
1101 CALL icopy( nmat, work( i ), 1, cscyval, 1 )
1102 i = i + nmat
1103 CALL icopy( nmat, work( i ), 1, iyval, 1 )
1104 i = i + nmat
1105 CALL icopy( nmat, work( i ), 1, jyval, 1 )
1106 i = i + nmat
1107 CALL icopy( nmat, work( i ), 1, incyval, 1 )
1108 i = i + nmat
1109*
1110 DO 90 j = 1, nsubs
1111 IF( work( i ).EQ.1 ) THEN
1112 ltest( j ) = .true.
1113 ELSE
1114 ltest( j ) = .false.
1115 END IF
1116 i = i + 1
1117 90 CONTINUE
1118*
1119 END IF
1120*
1121 CALL blacs_gridexit( ictxt )
1122*
1123 RETURN
1124*
1125 100 WRITE( nout, fmt = 9997 )
1126 CLOSE( nin )
1127 IF( nout.NE.6 .AND. nout.NE.0 )
1128 $ CLOSE( nout )
1129 CALL blacs_abort( ictxt, 1 )
1130*
1131 stop
1132*
1133 9999 FORMAT( a )
1134 9998 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
1135 $ 'than ', i2 )
1136 9997 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
1137 9996 FORMAT( a7, l2 )
1138 9995 FORMAT( ' Subprogram name ', a7, ' not recognized',
1139 $ /' ******* TESTS ABANDONED *******' )
1140 9994 FORMAT( 2x, 'Alpha : ', g16.6 )
1141 9993 FORMAT( 2x, 'Number of Tests : ', i6 )
1142 9992 FORMAT( 2x, 'Number of process grids : ', i6 )
1143 9991 FORMAT( 2x, ' : ', 5i6 )
1144 9990 FORMAT( 2x, a1, ' : ', 5i6 )
1145 9989 FORMAT( 2x, 'Routines to be tested : ', a, a8 )
1146 9988 FORMAT( 2x, ' ', a, a8 )
1147*
1148* End of PSBLA1TIMINFO
1149*
1150 END
subroutine pb_combine(ictxt, scope, op, tmtype, n, ibeg, times)
Definition pblastim.f:3211
subroutine pb_boot()
Definition pblastim.f:2927
subroutine pb_timer(i)
Definition pblastim.f:2976
subroutine pvdimchk(ictxt, nout, n, matrix, ix, jx, descx, incx, info)
Definition pblastst.f:3
subroutine icopy(n, sx, incx, sy, incy)
Definition pblastst.f:1525
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
#define max(A, B)
Definition pcgemr.c:180
#define min(A, B)
Definition pcgemr.c:181
subroutine psbla1timinfo(summry, nout, nmat, nval, 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, ltest, iam, nprocs, alpha, work)
Definition psblas1tim.f:551
program psbla1tim
Definition psblas1tim.f:11
subroutine pslagen(inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
Definition psblastst.f:7846