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 dblesz, totmem, memsiz, ntests
66 DOUBLE PRECISION padval
67 parameter( dblesz = 8, totmem = 2000000,
68 $ memsiz = totmem / dblesz, ntests = 20,
69 $ padval = -9923.0d+0 )
76 INTEGER i, iam, iaseed, ictxt, imidpad, info, ipa, ipd,
77 $ ipe, ipostpad, iprepad, ipt, ipw, itemp, j, k,
78 $ kfail, kpass, kskip, ktests, lcm, lwork, mycol,
79 $ myrow, n, nb, ndiag, ngrids, nmat, nnb, noffd,
80 $ nout, np, npcol, nprocs, nprow, nq, worksiz,
83 DOUBLE PRECISION anorm, fresid, nops, tmflops
86 INTEGER desca( dlen_ ), ierr( 1 ), nbval( ntests ),
87 $ nval( ntests ), pval( ntests ), qval( ntests )
88 DOUBLE PRECISION ctime( 1 ), mem( memsiz ), wtime( 1 )
91 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
92 $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
108 DATA ktests, kpass, kfail, kskip / 4*0 /
112 IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
116 CALL blacs_pinfo( iam, nprocs )
118 CALL pdtrdinfo( outfile, nout, uplo, nmat, nval, ntests, nnb,
119 $ nbval, ntests, ngrids, pval, ntests, qval, ntests,
120 $ thresh, mem, iam, nprocs )
121 check = ( thresh.GE.0.0e+0 )
126 WRITE( nout, fmt = * )
127 WRITE( nout, fmt = 9995 )
128 WRITE( nout, fmt = 9994 )
129 WRITE( nout, fmt = * )
142 IF( nprow.LT.1 )
THEN
144 $
WRITE( nout, fmt = 9999 )
'GRID',
'nprow', nprow
146 ELSE IF( npcol.LT.1 )
THEN
148 $
WRITE( nout, fmt = 9999 )
'GRID',
'npcol', npcol
150 ELSE IF( nprow*npcol.GT.nprocs )
THEN
152 $
WRITE( nout, fmt = 9998 )nprow*npcol, nprocs
156 IF( ierr( 1 ).GT.0 )
THEN
158 $
WRITE( nout, fmt = 9997 )
'grid'
165 CALL blacs_get( -1, 0, ictxt )
166 CALL blacs_gridinit( ictxt,
'Row-major', nprow, npcol )
167 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
171 IF( myrow.GE.nprow .OR. mycol.GE.npcol )
183 $
WRITE( nout, fmt = 9999 )
'MATRIX',
'N', n
189 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
191 IF( ierr( 1 ).GT.0 )
THEN
193 $
WRITE( nout, fmt = 9997 )
'matrix'
210 $
WRITE( nout, fmt = 9999 )
'NB',
'NB', nb
215 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
217 IF( ierr( 1 ).GT.0 )
THEN
219 $
WRITE( nout, fmt = 9997 )
'NB'
226 np =
numroc( n, nb, myrow, 0, nprow )
227 nq =
numroc( n, nb, mycol, 0, npcol )
229 iprepad =
max( nb, np )
231 ipostpad =
max( nb, nq )
240 CALL descinit( desca, n, n, nb, nb, 0, 0, ictxt,
241 $
max( 1, np )+imidpad, ierr( 1 ) )
245 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
247 IF( ierr( 1 ).LT.0 )
THEN
249 $
WRITE( nout, fmt = 9997 )
'descriptor'
258 IF(
lsame( uplo,
'U' ) )
THEN
261 noffd =
numroc( n-1, nb, mycol, 0, npcol )
265 ipd = ipa + desca( lld_ )*nq + ipostpad + iprepad
266 ipe = ipd + ndiag + ipostpad + iprepad
267 ipt = ipe + noffd + ipostpad + iprepad
268 ipw = ipt + nq + ipostpad + iprepad
273 lwork =
max( nb*( np+1 ), 3*nb )
274 worktrd = lwork + ipostpad
281 IF( nprow.NE.npcol )
THEN
282 lcm =
ilcm( nprow, npcol )
283 itemp = nb*
iceil(
iceil( np, nb ), lcm / nprow ) +
286 itemp =
max( itemp, 2*( nb+np )*nb )
287 worksiz =
max( lwork, itemp ) + ipostpad
293 IF( ipw+worksiz.GT.memsiz )
THEN
295 $
WRITE( nout, fmt = 9996 )
'Tridiagonal reduction',
296 $ ( ipw+worksiz )*dblesz
302 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
304 IF( ierr( 1 ).GT.0 )
THEN
306 $
WRITE( nout, fmt = 9997 )
'MEMORY'
313 CALL pdmatgen( ictxt,
'Symm',
'N', desca( m_ ),
314 $ desca( n_ ), desca( mb_ ), desca( nb_ ),
315 $ mem( ipa ), desca( lld_ ), desca( rsrc_ ),
316 $ desca( csrc_ ), iaseed, 0, np, 0, nq,
317 $ myrow, mycol, nprow, npcol )
322 CALL pdfillpad( ictxt, np, nq, mem( ipa-iprepad ),
323 $ desca( lld_ ), iprepad, ipostpad,
325 CALL pdfillpad( ictxt, ndiag, 1, mem( ipd-iprepad ),
326 $ ndiag, iprepad, ipostpad, padval )
327 CALL pdfillpad( ictxt, noffd, 1, mem( ipe-iprepad ),
328 $ noffd, iprepad, ipostpad, padval )
329 CALL pdfillpad( ictxt, nq, 1, mem( ipt-iprepad ), nq,
330 $ iprepad, ipostpad, padval )
331 CALL pdfillpad( ictxt, worksiz-ipostpad, 1,
332 $ mem( ipw-iprepad ), worksiz-ipostpad,
333 $ iprepad, ipostpad, padval )
334 anorm =
pdlansy(
'I', uplo, n, mem( ipa ), 1, 1,
335 $ desca, mem( ipw ) )
336 CALL pdchekpad( ictxt,
'PDLANSY', np, nq,
337 $ mem( ipa-iprepad ), desca( lld_ ),
338 $ iprepad, ipostpad, padval )
339 CALL pdchekpad( ictxt,
'PDLANSY', worksiz-ipostpad, 1,
340 $ mem( ipw-iprepad ), worksiz-ipostpad,
341 $ iprepad, ipostpad, padval )
342 CALL pdfillpad( ictxt, worktrd-ipostpad, 1,
343 $ mem( ipw-iprepad ), worktrd-ipostpad,
344 $ iprepad, ipostpad, padval )
348 CALL blacs_barrier( ictxt,
'All' )
353 CALL pdsytrd( uplo, n, mem( ipa ), 1, 1, desca,
354 $ mem( ipd ), mem( ipe ), mem( ipt ),
355 $ mem( ipw ), lwork, info )
363 CALL pdchekpad( ictxt,
'PDSYTRD', np, nq,
364 $ mem( ipa-iprepad ), desca( lld_ ),
365 $ iprepad, ipostpad, padval )
366 CALL pdchekpad( ictxt,
'PDSYTRD', ndiag, 1,
367 $ mem( ipd-iprepad ), ndiag, iprepad,
369 CALL pdchekpad( ictxt,
'PDSYTRD', noffd, 1,
370 $ mem( ipe-iprepad ), noffd, iprepad,
373 $ mem( ipt-iprepad ), nq, iprepad,
375 CALL pdchekpad( ictxt,
'PDSYTRD', worktrd-ipostpad, 1,
376 $ mem( ipw-iprepad ), worktrd-ipostpad,
377 $ iprepad, ipostpad, padval )
378 CALL pdfillpad( ictxt, worksiz-ipostpad, 1,
379 $ mem( ipw-iprepad ), worksiz-ipostpad,
380 $ iprepad, ipostpad, padval )
384 CALL pdsytdrv( uplo, n, mem( ipa ), 1, 1, desca,
385 $ mem( ipd ), mem( ipe ), mem( ipt ),
386 $ mem( ipw ), ierr( 1 ) )
387 CALL pdlafchk(
'Symm',
'No', n, n, mem( ipa ), 1, 1,
388 $ desca, iaseed, anorm, fresid,
393 CALL pdchekpad( ictxt,
'PDSYTDRV', np, nq,
394 $ mem( ipa-iprepad ), desca( lld_ ),
395 $ iprepad, ipostpad, padval )
396 CALL pdchekpad( ictxt,
'PDSYTDRV', ndiag, 1,
397 $ mem( ipd-iprepad ), ndiag, iprepad,
399 CALL pdchekpad( ictxt,
'PDSYTDRV', noffd, 1,
400 $ mem( ipe-iprepad ), noffd, iprepad,
402 CALL pdchekpad( ictxt,
'PDSYTDRV', worksiz-ipostpad,
403 $ 1, mem( ipw-iprepad ),
404 $ worksiz-ipostpad, iprepad, ipostpad,
409 IF( fresid.LE.thresh .AND. fresid-fresid.EQ.
410 $ 0.0d+0 .AND. ierr( 1 ).EQ.0 )
THEN
414 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
415 $
WRITE( nout, fmt = 9986 )fresid
420 IF( myrow.EQ.0 .AND. mycol.EQ.0 .AND. ierr( 1 ).NE.0 )
421 $
WRITE( nout, fmt = * )
'D or E copies incorrect ...'
427 fresid = fresid - fresid
433 CALL slcombine( ictxt,
'All',
'>',
'W', 1, 1, wtime )
434 CALL slcombine( ictxt,
'All',
'>',
'C', 1, 1, ctime )
438 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
THEN
444 nops = ( 4.0d+0 / 3.0d+0 )*nops**3
449 IF( wtime( 1 ).GT.0.0d+0 )
THEN
450 tmflops = nops / wtime( 1 )
454 IF( wtime( 1 ).GE.0.0d+0 )
455 $
WRITE( nout, fmt = 9993 )
'WALL', uplo, n, nb,
456 $ nprow, npcol, wtime( 1 ), tmflops, fresid, passed
460 IF( ctime( 1 ).GT.0.0d+0 )
THEN
461 tmflops = nops / ctime( 1 )
465 IF( ctime( 1 ).GE.0.0d+0 )
466 $
WRITE( nout, fmt = 9993 )
'CPU ', uplo, n, nb,
467 $ nprow, npcol, ctime( 1 ), tmflops, fresid, passed
472 CALL blacs_gridexit( ictxt )
475 CALL pdttrdtester( iam, nprocs, check, nout, thresh, nval, nmat,
476 $ mem, totmem, kpass, kfail, kskip )
481 ktests = kpass + kfail + kskip
482 WRITE( nout, fmt = * )
483 WRITE( nout, fmt = 9992 )ktests
485 WRITE( nout, fmt = 9991 )kpass
486 WRITE( nout, fmt = 9989 )kfail
488 WRITE( nout, fmt = 9990 )kpass
490 WRITE( nout, fmt = 9988 )kskip
491 WRITE( nout, fmt = * )
492 WRITE( nout, fmt = * )
493 WRITE( nout, fmt = 9987 )
494 IF( nout.NE.6 .AND. nout.NE.0 )
500 9999
FORMAT(
'ILLEGAL ', a6,
': ', a5,
' = ', i3,
501 $
'; It should be at least 1' )
502 9998
FORMAT(
'ILLEGAL GRID: nprow*npcol = ', i4,
'. It can be at most',
504 9997
FORMAT(
'Bad ', a6,
' parameters: going on to next test case.' )
505 9996
FORMAT(
'Unable to perform ', a,
': need TOTMEM of at least',
507 9995
FORMAT(
'TIME UPLO N NB P Q TRD Time ',
508 $
' MFLOPS Residual CHECK' )
509 9994
FORMAT(
'---- ---- ------ --- ----- ----- --------- ',
510 $
'----------- -------- ------' )
511 9993
FORMAT( a4, 1x, a4, 1x, i6, 1x, i3, 1x, i5, 1x, i5, 1x, f9.2, 1x,
512 $ f11.2, 1x, f8.2, 1x, a6 )
513 9992
FORMAT(
'Finished', i4,
' tests, with the following results:' )
514 9991
FORMAT( i5,
' tests completed and passed residual checks.' )
515 9990
FORMAT( i5,
' tests completed without checking.' )
516 9989
FORMAT( i5,
' tests completed and failed residual checks.' )
517 9988
FORMAT( i5,
' tests skipped because of illegal input values.' )
518 9987
FORMAT(
'END OF TESTS.' )
519 9986
FORMAT(
'||A - Q*T*Q''|| / (||A|| * N * eps) = ', g25.7 )