60 INTEGER block_cyclic_2d, csrc_, ctxt_, dlen_, dtype_,
61 $ lld_, mb_, m_, nb_, n_, rsrc_
62 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
63 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
64 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
65 INTEGER realsz, totmem, memsiz, ntests
67 parameter( realsz = 4, totmem = 2000000,
68 $ memsiz = totmem / realsz, ntests = 20,
69 $ padval = -9923.0e+0 )
76 INTEGER i, iam, , ictxt, imidpad, info, ipa, ipd,
82 REAL anorm, fresid, thresh
83 DOUBLE PRECISION nops, tmflops
86 INTEGER desca( dlen_ ), ierr( 1 ), ( ntests ),
87 $ nval( ntests ), pval( ntests ), qval( ntests )
89 DOUBLE PRECISION ( 1 ), wtime( 1 )
92 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
109 DATA ktests, kpass, kfail
113 IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
117 CALL blacs_pinfo( iam, nprocs )
119 CALL pstrdinfo( outfile, nout, uplo, nmat, nval, ntests, nnb,
120 $ nbval, ntests, ngrids, pval, ntests, qval, ntests,
121 $ thresh, mem, iam, nprocs )
122 check = ( thresh.GE.0.0e+0 )
127 WRITE( nout, fmt = * )
128 WRITE( nout, fmt = 9995 )
129 WRITE( nout, fmt = 9994 )
130 WRITE( nout, fmt = * )
143 IF( nprow.LT.1 )
THEN
145 $
WRITE( nout, fmt = 9999 )
'GRID',
'nprow', nprow
147 ELSE IF( npcol.LT.1 )
THEN
149 $
WRITE( nout, fmt = 9999 )
'GRID',
'npcol', npcol
151 ELSE IF( nprow*npcol.GT.nprocs )
THEN
153 $
WRITE( nout, fmt = 9998 )nprow*npcol, nprocs
157 IF( ierr( 1 ).GT.0 )
THEN
159 $
WRITE( nout, fmt = 9997 )
'grid'
166 CALL blacs_get( -1, 0, ictxt )
172 IF( myrow.GE.nprow .OR. mycol.GE.npcol )
184 $
WRITE( nout, fmt = 9999 )
'MATRIX',
'N', n
190 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
192 IF( ierr( 1 ).GT.0 )
THEN
194 $
WRITE( nout, fmt = 9997 )
'matrix'
211 $
WRITE( nout, fmt = 9999 )
'NB',
'NB', nb
216 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
218 IF( ierr( 1 ).GT.0 )
THEN
220 $
WRITE( nout, fmt = 9997 )
'NB'
227 np =
numroc( n, nb, myrow, 0, nprow )
228 nq =
numroc( n, nb, mycol, 0, npcol )
230 iprepad =
max( nb, np )
232 ipostpad =
max( nb, nq )
241 CALL descinit( desca, n, n, nb, nb, 0, 0, ictxt,
242 $
max( 1, np )+imidpad, ierr( 1 ) )
246 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
248 IF( ierr( 1 ).LT.0 )
THEN
250 $
WRITE( nout, fmt = 9997 )
'descriptor'
259 IF(
lsame( uplo,
'U' ) )
THEN
262 noffd =
numroc( n-1, nb, mycol, 0, npcol )
266 ipd = ipa + desca( lld_ )*nq + ipostpad + iprepad
267 ipe = ipd + ndiag + ipostpad + iprepad
268 ipt = ipe + noffd + ipostpad + iprepad
269 ipw = ipt + nq + ipostpad + iprepad
274 lwork =
max( nb*( np+1 ), 3*nb )
275 worktrd = lwork + ipostpad
282 IF( nprow.NE.npcol )
THEN
283 lcm =
ilcm( nprow, npcol )
284 itemp = nb*
iceil(
iceil( np, nb ), lcm / nprow ) +
287 itemp =
max( itemp, 2*( nb+np )*nb )
288 worksiz =
max( lwork, itemp ) + ipostpad
294 IF( ipw+worksiz.GT.memsiz )
THEN
296 $
WRITE( nout, fmt = 9996 )
'Tridiagonal reduction',
297 $ ( ipw+worksiz )*realsz
303 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
305 IF( ierr( 1 ).GT.0 )
THEN
307 $
WRITE( nout, fmt = 9997 )
'MEMORY'
314 CALL psmatgen( ictxt,
'Symm',
'N', desca( m_ ),
315 $ desca( n_ ), desca( mb_ ), desca( nb_ ),
316 $ mem( ipa ), desca( lld_ ), desca( rsrc_ ),
317 $ desca( csrc_ ), iaseed
318 $ myrow, mycol, nprow, npcol )
323 CALL psfillpad( ictxt, np, nq, mem( ipa-iprepad ),
324 $ desca( lld_ ), iprepad, ipostpad,
326 CALL psfillpad( ictxt, ndiag, 1, mem( ipd-iprepad ),
327 $ ndiag, iprepad, ipostpad, padval )
328 CALL psfillpad( ictxt, noffd, 1, mem( ipe-iprepad ),
329 $ noffd, iprepad, ipostpad, padval )
330 CALL psfillpad( ictxt, nq, 1, mem( ipt-iprepad ), nq,
332 CALL psfillpad( ictxt, worksiz-ipostpad, 1,
333 $ mem( ipw-iprepad ), worksiz-ipostpad,
334 $ iprepad, ipostpad, padval )
335 anorm =
pslansy(
'I', uplo, n, mem( ipa ), 1, 1,
336 $ desca, mem( ipw ) )
337 CALL pschekpad( ictxt,
'PSLANSY', np, nq,
338 $ mem( ipa-iprepad ), desca( lld_ ),
339 $ iprepad, ipostpad, padval )
340 CALL pschekpad( ictxt,
'PSLANSY', worksiz-ipostpad, 1,
341 $ mem( ipw-iprepad ), worksiz-ipostpad,
342 $ iprepad, ipostpad, padval )
343 CALL psfillpad( ictxt, worktrd-ipostpad, 1,
344 $ mem( ipw-iprepad ), worktrd-ipostpad,
345 $ iprepad, ipostpad, padval )
349 CALL blacs_barrier( ictxt,
'All' )
354 CALL pssytrd( uplo, n, mem( ipa ), 1, 1, desca,
355 $ mem( ipd ), mem( ipe ), mem( ipt ),
356 $ mem( ipw ), lwork, info )
364 CALL pschekpad( ictxt,
'PSSYTRD', np, nq,
365 $ mem( ipa-iprepad ), desca( lld_ ),
366 $ iprepad, ipostpad, padval )
367 CALL pschekpad( ictxt,
'PSSYTRD', ndiag, 1,
368 $ mem( ipd-iprepad ), ndiag, iprepad,
370 CALL pschekpad( ictxt,
'PSSYTRD', noffd, 1,
371 $ mem( ipe-iprepad ), noffd, iprepad,
374 $ mem( ipt-iprepad ), nq, iprepad,
376 CALL pschekpad( ictxt,
'PSSYTRD', worktrd-ipostpad, 1,
377 $ mem( ipw-iprepad ), worktrd-ipostpad,
378 $ iprepad, ipostpad, padval )
379 CALL psfillpad( ictxt, worksiz-ipostpad, 1,
380 $ mem( ipw-iprepad ), worksiz-ipostpad,
381 $ iprepad, ipostpad, padval )
385 CALL pssytdrv( uplo, n, mem( ipa ), 1, 1, desca,
386 $ mem( ipd ), mem( ipe ), mem( ipt ),
387 $ mem( ipw ), ierr( 1 ) )
388 CALL pslafchk(
'Symm',
'No', n, n, mem( ipa ), 1, 1,
389 $ desca, iaseed, anorm, fresid,
395 $ mem( ipa-iprepad ), desca( lld_ ),
396 $ iprepad, ipostpad, padval )
397 CALL pschekpad( ictxt,
'PSSYTDRV', ndiag, 1,
398 $ mem( ipd-iprepad ), ndiag, iprepad
400 CALL pschekpad( ictxt,
'PSSYTDRV', noffd, 1,
401 $ mem( ipe-iprepad ), noffd, iprepad,
403 CALL pschekpad( ictxt,
'PSSYTDRV', worksiz-ipostpad,
404 $ 1, mem( ipw-iprepad ),
405 $ worksiz-ipostpad, iprepad, ipostpad,
410 IF( fresid.LE.thresh .AND. fresid-fresid.EQ.
411 $ 0.0e+0 .AND. ierr( 1 ).EQ.0 )
THEN
415 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
416 $
WRITE( nout, fmt = 9986 )fresid
421 IF( myrow.EQ.0 .AND. mycol.EQ.0 .AND. ierr( 1 ).NE.0 )
422 $
WRITE( nout, fmt = * )
'D or E copies incorrect ...'
428 fresid = fresid - fresid
434 CALL slcombine( ictxt,
'All', '>
', 'w
', 1, 1, WTIME )
435 CALL SLCOMBINE( ICTXT, 'all
', '>
', 'c
', 1, 1, CTIME )
439.EQ..AND..EQ.
IF( MYROW0 MYCOL0 ) THEN
445 NOPS = ( 4.0D+0 / 3.0D+0 )*NOPS**3
450.GT.
IF( WTIME( 1 )0.0D+0 ) THEN
451 TMFLOPS = NOPS / WTIME( 1 )
455.GE.
IF( WTIME( 1 )0.0D+0 )
456 $ WRITE( NOUT, FMT = 9993 )'wall
', UPLO, N, NB,
457 $ NPROW, NPCOL, WTIME( 1 ), TMFLOPS, FRESID, PASSED
461.GT.
IF( CTIME( 1 )0.0D+0 ) THEN
462 TMFLOPS = NOPS / CTIME( 1 )
466.GE.
IF( CTIME( 1 )0.0D+0 )
467 $ WRITE( NOUT, FMT = 9993 )'cpu
', UPLO, N, NB,
468 $ NPROW, NPCOL, CTIME( 1 ), TMFLOPS, FRESID, PASSED
473 CALL BLACS_GRIDEXIT( ICTXT )
476 CALL PSTTRDTESTER( IAM, NPROCS, CHECK, NOUT, THRESH, NVAL, NMAT,
477 $ MEM, TOTMEM, KPASS, KFAIL, KSKIP )
482 KTESTS = KPASS + KFAIL + KSKIP
483 WRITE( NOUT, FMT = * )
484 WRITE( NOUT, FMT = 9992 )KTESTS
486 WRITE( NOUT, FMT = 9991 )KPASS
487 WRITE( NOUT, FMT = 9989 )KFAIL
489 WRITE( NOUT, FMT = 9990 )KPASS
491 WRITE( NOUT, FMT = 9988 )KSKIP
492 WRITE( NOUT, FMT = * )
493 WRITE( NOUT, FMT = * )
494 WRITE( NOUT, FMT = 9987 )
495.NE..AND..NE.
IF( NOUT6 NOUT0 )
501 9999 FORMAT( 'illegal
', A6, ':
', A5, ' =
', I3,
502 $ '; it should be at least 1
' )
503 9998 FORMAT( 'illegal grid: nprow*npcol
', I4, '. it can be at most
',
505 9997 FORMAT( 'bad
', A6, ' parameters: going on to next test case.
' )
506 9996 FORMAT( 'unable to perform
', A, ': need totmem of at least
',
508 9995 FORMAT( 'time uplo n nb
',
509 $ ' mflops residual
' )
510 9994 FORMAT( '---- ---- ------ --- ----- ----- ---------
',
511 $ '----------- -------- ------
' )
512 9993 FORMAT( A4, 1X, A4, 1X, I6, 1X, I3, 1X, I5, 1X, I5, 1X, F9.2, 1X,
513 $ F11.2, 1X, F8.2, 1X, A6 )
514 9992 FORMAT( 'finished
', I4, ' tests, with
the following results:
' )
515 9991 FORMAT( I5, ' tests completed and passed residual checks.
' )
516 9990 FORMAT( I5, ' tests completed without checking
' )
517 9989 FORMAT( I5, ' tests completed and failed residual checks.
' )
518 9988 FORMAT( I5, ' tests skipped because of illegal input values.
' )
519 9987 FORMAT( 'END OF TESTS.
' )
520 9986 FORMAT( '||A - Q*T*Q
''|| / (||A|| * N * eps) =
', G25.7 )
subroutine pslafchk(aform, diag, m, n, a, ia, ja, desca, iaseed, anorm, fresid, work)
subroutine psmatgen(ictxt, aform, diag, m, n, mb, nb, a, lda, iarow, iacol, iseed, iroff, irnum, icoff, icnum, myrow, mycol, nprow, npcol)
end diagonal values have been computed in the(sparse) matrix id.SOL
logical function lsame(ca, cb)
LSAME
integer function iceil(inum, idenom)
integer function ilcm(m, n)
subroutine blacs_gridinit(cntxt, c, nprow, npcol)
subroutine descinit(desc, m, n, mb, nb, irsrc, icsrc, ictxt, lld, info)
subroutine blacs_gridexit(cntxt)
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
subroutine pschekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine psfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
real function pslansy(norm, uplo, n, a, ia, ja, desca, work)
subroutine pssytdrv(uplo, n, a, ia, ja, desca, d, e, tau, work, info)
subroutine pssytrd(uplo, n, a, ia, ja, desca, d, e, tau, work, lwork, info)
subroutine pstrdinfo(summry, nout, uplo, nmat, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
subroutine psttrdtester(iam, nprocs, check, nout, thresh, nval, nmat, mem, totmem, kpass, kfail, kskip)
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)