1 SUBROUTINE psdbinfo( SUMMRY, NOUT, TRANS, NMAT, NVAL, LDNVAL, NBW,
2 $ BWLVAL, BWUVAL, LDBWVAL, NNB, NBVAL, LDNBVAL,
3 $ NNR, NRVAL, LDNRVAL, NNBR, NBRVAL, LDNBRVAL,
4 $ NGRIDS, PVAL, LDPVAL, QVAL, LDQVAL, THRESH,
18 $ LDBWVAL, LDNBRVAL, LDNBVAL, LDNRVAL, LDNVAL,
19 $ ldpval, ldqval, ngrids, nmat, nnb, nnbr, nbw,
24 INTEGER NBRVAL( LDNBRVAL ), NBVAL( LDNBVAL ),
25 $ nrval( ldnrval ), nval( ldnval ),
26 $ bwlval( ldbwval),bwuval( ldbwval),
27 $ pval( ldpval ), qval(ldqval), work( * )
151 PARAMETER ( NIN = 11 )
159 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
160 $ blacs_gridinit, blacs_setup,
icopy, igebr2d,
161 $ igebs2d, sgebr2d, sgebs2d
166 EXTERNAL LSAME, PSLAMCH
180 OPEN( nin, file =
'BLU.dat', status =
'OLD' )
181 READ( nin, fmt = * ) summry
186 READ( nin, fmt = 9999 ) usrinfo
190 READ( nin, fmt = * ) summry
191 READ( nin, fmt = * ) nout
192 IF( nout.NE.0 .AND. nout.NE.6 )
193 $
OPEN( nout, file = summry, status =
'UNKNOWN' )
199 READ( nin, fmt = * ) trans
204 READ( nin, fmt = * ) nmat
205 IF( nmat.LT.1 .OR. nmat.GT.ldnval )
THEN
206 WRITE( nout, fmt = 9994 )
'N', ldnval
209 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
213 READ( nin, fmt = * ) nbw
214 IF( nbw.LT.1 .OR. nbw.GT.ldbwval )
THEN
215 WRITE( nout, fmt = 9994 )
'BW', ldbwval
218 READ( nin, fmt = * ) ( bwlval( i ), i = 1, nbw )
219 READ( nin, fmt = * ) ( bwuval( i ), i = 1, nbw )
223 READ( nin, fmt = * ) nnb
224 IF( nnb.LT.1 .OR. nnb.GT.ldnbval )
THEN
225 WRITE( nout, fmt = 9994 )
'NB', ldnbval
228 READ( nin, fmt = * ) ( nbval( i ), i = 1, nnb )
232 READ( nin, fmt = * ) nnr
233 IF( nnr.LT.1 .OR. nnr.GT.ldnrval )
THEN
234 WRITE( nout, fmt = 9994 )
'NRHS', ldnrval
237 READ( nin, fmt = * ) ( nrval( i ), i = 1, nnr )
241 READ( nin, fmt = * ) nnbr
242 IF( nnbr.LT.1 .OR. nnbr.GT.ldnbrval )
THEN
243 WRITE( nout, fmt = 9994 )
'NBRHS', ldnbrval
246 READ( nin, fmt = * ) ( nbrval( i ), i = 1, nnbr )
250 READ( nin, fmt = * ) ngrids
251 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval )
THEN
252 WRITE( nout, fmt = 9994 )
'Grids', ldpval
254 ELSE IF( ngrids.GT.ldqval )
THEN
255 WRITE( nout, fmt = 9994 )
'Grids', ldqval
260 DO 8738 i = 1, ngrids
266 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
270 READ( nin, fmt = * ) thresh
279 IF( nprocs.LT.1 )
THEN
282 nprocs =
max( nprocs, pval( i )*qval( i ) )
284 CALL blacs_setup( iam, nprocs )
290 CALL blacs_get( -1, 0, ictxt )
291 CALL blacs_gridinit( ictxt,
'Row-major', 1, nprocs )
295 eps = pslamch( ictxt,
'eps' )
299 CALL sgebs2d( ictxt,
'All',
' ', 1, 1, thresh, 1 )
313 IF( lsame( trans,
'N' ) )
THEN
321 CALL igebs2d( ictxt,
'All',
' ', 1, 1, i-1, 1 )
323 CALL igebs2d( ictxt,
'All',
' ', i-1, 1, work, i-1 )
326 CALL icopy( nmat, nval, 1, work( i ), 1 )
328 CALL icopy( nbw, bwlval, 1, work( i ), 1 )
330 CALL icopy( nbw, bwuval, 1, work( i ), 1 )
332 CALL icopy( nnb, nbval, 1, work( i ), 1 )
334 CALL icopy( nnr, nrval, 1, work( i ), 1 )
336 CALL icopy( nnbr, nbrval, 1, work( i ), 1 )
338 CALL icopy( ngrids, pval, 1, work( i ), 1 )
340 CALL icopy( ngrids, qval, 1, work( i ), 1 )
342 CALL igebs2d( ictxt,
'All',
' ', i-1, 1, work, i-1 )
346 WRITE( nout, fmt = 9999 )
347 $
'SCALAPACK banded linear systems.'
348 WRITE( nout, fmt = 9999 ) usrinfo
349 WRITE( nout, fmt = * )
350 WRITE( nout, fmt = 9999 )
351 $
'Tests of the parallel '//
352 $
'real single precision band matrix solve '
353 WRITE( nout, fmt = 9999 )
354 $
'The following scaled residual '//
355 $
'checks will be computed:'
356 WRITE( nout, fmt = 9999 )
357 $
' Solve residual = ||Ax - b|| / '//
358 $
'(||x|| * ||A|| * eps * N)'
359 WRITE( nout, fmt = 9999 )
360 $
' Factorization residual = ||A - LU|| /'//
361 $
' (||A|| * eps * N)'
362 WRITE( nout, fmt = 9999 )
363 $
'The matrix A is randomly '//
364 $
'generated for each test.'
365 WRITE( nout, fmt = * )
366 WRITE( nout, fmt = 9999 )
367 $
'An explanation of the input/output '//
368 $
'parameters follows:'
369 WRITE( nout, fmt = 9999 )
370 $
'TIME : Indicates whether WALL or '//
371 $
'CPU time was used.'
373 WRITE( nout, fmt = 9999 )
374 $
'N : The number of rows and columns '//
376 WRITE( nout, fmt = 9999 )
377 $
'bwl, bwu : The number of diagonals '//
379 WRITE( nout, fmt = 9999 )
380 $
'NB : The size of the column panels the'//
381 $
' matrix A is split into. [-1 for default]'
382 WRITE( nout, fmt = 9999 )
383 $
'NRHS : The total number of RHS to solve'//
385 WRITE( nout, fmt = 9999 )
386 $
'NBRHS : The number of RHS to be put on '//
387 $
'a column of processes before going'
388 WRITE( nout, fmt = 9999 )
389 $
' on to the next column of processes.'
390 WRITE( nout, fmt = 9999 )
391 $
'P : The number of process rows.'
392 WRITE( nout, fmt = 9999 )
393 $
'Q : The number of process columns.'
394 WRITE( nout, fmt = 9999 )
395 $
'THRESH : If a residual value is less than'//
396 $
' THRESH, CHECK is flagged as PASSED'
397 WRITE( nout, fmt = 9999 )
398 $
'Fact time: Time in seconds to factor the'//
400 WRITE( nout, fmt = 9999 )
401 $
'Sol Time: Time in seconds to solve the'//
403 WRITE( nout, fmt = 9999 )
404 $
'MFLOPS : Rate of execution for factor '//
405 $
'and solve using sequential operation count.'
406 WRITE( nout, fmt = 9999 )
407 $
'MFLOP2 : Rough estimate of speed '//
408 $
'using actual op count (accurate big P,N).'
409 WRITE( nout, fmt = * )
410 WRITE( nout, fmt = 9999 )
411 $
'The following parameter values will be used:'
412 WRITE( nout, fmt = 9996 )
413 $
'N ', ( nval(i), i = 1,
min(nmat, 10) )
415 $
WRITE( nout, fmt = 9997 ) ( nval(i), i = 11, nmat )
416 WRITE( nout, fmt = 9996 )
417 $
'bwl ', ( bwlval(i), i = 1,
min(nbw, 10) )
419 $
WRITE( nout, fmt = 9997 ) ( bwlval(i), i = 11, nbw )
420 WRITE( nout, fmt = 9996 )
421 $
'bwu ', ( bwuval(i), i = 1,
min(nbw, 10) )
423 $
WRITE( nout, fmt = 9997 ) ( bwuval(i), i = 11, nbw )
424 WRITE( nout, fmt = 9996 )
425 $
'NB ', ( nbval(i), i = 1,
min(nnb, 10) )
427 $
WRITE( nout, fmt = 9997 ) ( nbval(i), i = 11, nnb )
428 WRITE( nout, fmt = 9996 )
429 $
'NRHS ', ( nrval(i), i = 1,
min(nnr, 10) )
431 $
WRITE( nout, fmt = 9997 ) ( nrval(i), i = 11, nnr )
432 WRITE( nout, fmt = 9996 )
433 $
'NBRHS', ( nbrval(i), i = 1,
min(nnbr, 10) )
435 $
WRITE( nout, fmt = 9997 ) ( nbrval(i), i = 11, nnbr )
436 WRITE( nout, fmt = 9996 )
437 $
'P ', ( pval(i), i = 1,
min(ngrids, 10) )
439 $
WRITE( nout, fmt = 9997) ( pval(i), i = 11, ngrids )
440 WRITE( nout, fmt = 9996 )
441 $
'Q ', ( qval(i), i = 1,
min(ngrids, 10) )
443 $
WRITE( nout, fmt = 9997 ) ( qval(i), i = 11, ngrids )
444 WRITE( nout, fmt = * )
445 WRITE( nout, fmt = 9995 ) eps
446 WRITE( nout, fmt = 9998 ) thresh
453 $
CALL blacs_setup( iam, nprocs )
458 CALL blacs_get( -1, 0, ictxt )
459 CALL blacs_gridinit( ictxt,
'Row-major', 1, nprocs )
463 eps = pslamch( ictxt,
'eps' )
465 CALL sgebr2d( ictxt,
'All',
' ', 1, 1, thresh, 1, 0, 0 )
466 CALL igebr2d( ictxt,
'All',
' ', 1, 1, i, 1, 0, 0 )
467 CALL igebr2d( ictxt,
'All',
' ', i, 1, work, i, 0, 0 )
481 IF( work( i ) .EQ. 1 )
THEN
488 i = nmat + nbw + nnb + nnr + nnbr + 2*ngrids
491 CALL igebr2d( ictxt,
'All',
' ', 1, i, work, 1, 0, 0 )
493 CALL icopy( nmat, work( i ), 1, nval, 1 )
495 CALL icopy( nbw, work( i ), 1, bwlval, 1 )
497 CALL icopy( nbw, work( i ), 1, bwuval, 1 )
499 CALL icopy( nnb, work( i ), 1, nbval, 1 )
501 CALL icopy( nnr, work( i ), 1, nrval, 1 )
503 CALL icopy( nnbr, work( i ), 1, nbrval, 1 )
505 CALL icopy( ngrids, work( i ), 1, pval, 1 )
507 CALL icopy( ngrids, work( i ), 1, qval, 1 )
511 CALL blacs_gridexit( ictxt )
515 20
WRITE( nout, fmt = 9993 )
517 IF( nout.NE.6 .AND. nout.NE.0 )
520 CALL blacs_abort( ictxt, 1 )
524 9998
FORMAT(
'Routines pass computational tests if scaled residual ',
525 $
'is less than ', g12.5 )
526 9997
FORMAT(
' ', 10i6 )
527 9996
FORMAT( 2x, a5,
': ', 10i6 )
528 9995
FORMAT(
'Relative machine precision (eps) is taken to be ',
530 9994
FORMAT(
' Number of values of ',5a,
' is less than 1 or greater ',
532 9993
FORMAT(
' Illegal input in file ',40a,
'. Aborting run.' )