61 INTEGER block_cyclic_2d, csrc_, ctxt_, dlen_, dtype_,
62 $ lld_, mb_, m_, nb_, n_, rsrc_
63 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
64 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
65 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
66 INTEGER dblesz, totmem, zplxsz, memsiz, ntests
68 parameter( dblesz = 8, totmem = 2000000, zplxsz = 16,
69 $ memsiz = totmem / zplxsz, ntests = 20,
70 $ padval = ( -9923.0d+0, -9923.0d+0 ) )
77 INTEGER i, iam, iaseed, ictxt, imidpad, info, ipa, ipd,
78 $ ipe, ipostpad, iprepad, ipt, ipw, itemp, j, k,
79 $ kfail, kpass, kskip, ktests, lcm, lwork, mycol,
80 $ myrow, n, nb, ndiag, ngrids, nmat, nnb, noffd,
81 $ nout, np, npcol, nprocs, nprow, nq, worksiz,
84 DOUBLE PRECISION anorm, fresid, nops, tmflops
87 INTEGER desca( dlen_ ), ierr( 1 ), nbval( ntests ),
88 $ nval( ntests ), pval( ntests ), qval( ntests )
89 DOUBLE PRECISION ctime( 1 ), wtime( 1 )
90 COMPLEX*16 mem( memsiz )
93 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
94 $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
110 DATA ktests, kpass, kfail, kskip / 4*0 /
114 IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
118 CALL blacs_pinfo( iam, nprocs )
120 CALL pztrdinfo( outfile, nout, uplo, nmat, nval, ntests, nnb,
121 $ nbval, ntests, ngrids, pval, ntests, qval, ntests,
122 $ thresh, mem, iam, nprocs )
123 check = ( thresh.GE.0.0e+0 )
128 WRITE( nout, fmt = * )
129 WRITE( nout, fmt = 9995 )
130 WRITE( nout, fmt = 9994 )
131 WRITE( nout, fmt = * )
144 IF( nprow.LT.1 )
THEN
146 $
WRITE( nout, fmt = 9999 )
'GRID',
'nprow', nprow
148 ELSE IF( npcol.LT.1 )
THEN
150 $
WRITE( nout, fmt = 9999 )
'GRID',
'npcol', npcol
152 ELSE IF( nprow*npcol.GT.nprocs )
THEN
154 $
WRITE( nout, fmt = 9998 )nprow*npcol, nprocs
158 IF( ierr( 1 ).GT.0 )
THEN
160 $
WRITE( nout, fmt = 9997 )
'grid'
167 CALL blacs_get( -1, 0, ictxt )
168 CALL blacs_gridinit( ictxt,
'Row-major', nprow, npcol )
169 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
173 IF( myrow.GE.nprow .OR. mycol.GE.npcol )
185 $
WRITE( nout, fmt = 9999 )
'MATRIX',
'N', n
191 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
193 IF( ierr( 1 ).GT.0 )
THEN
195 $
WRITE( nout, fmt = 9997 )
'matrix'
212 $
WRITE( nout, fmt = 9999 )
'NB',
'NB', nb
217 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
219 IF( ierr( 1 ).GT.0 )
THEN
221 $
WRITE( nout, fmt = 9997 )
'NB'
228 np =
numroc( n, nb, myrow, 0, nprow )
229 nq =
numroc( n, nb, mycol, 0, npcol )
231 iprepad =
max( nb, np )
233 ipostpad =
max( nb, nq )
242 CALL descinit( desca, n, n, nb, nb, 0, 0, ictxt,
243 $
max( 1, np )+imidpad, ierr( 1 ) )
247 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
249 IF( ierr( 1 ).LT.0 )
THEN
251 $
WRITE( nout, fmt = 9997 )
'descriptor'
260 IF(
lsame( uplo,
'U' ) )
THEN
263 noffd =
numroc( n-1, nb, mycol, 0, npcol )
265 ndiag =
iceil( dblesz*ndiag, zplxsz )
266 noffd =
iceil( dblesz*noffd, zplxsz )
269 ipd = ipa + desca( lld_ )*nq + ipostpad + iprepad
270 ipe = ipd + ndiag + ipostpad + iprepad
271 ipt = ipe + noffd + ipostpad + iprepad
272 ipw = ipt + nq + ipostpad + iprepad
277 lwork =
max( nb*( np+1 ), 3*nb )
278 worktrd = lwork + ipostpad
285 IF( nprow.NE.npcol )
THEN
286 lcm =
ilcm( nprow, npcol )
287 itemp = nb*
iceil(
iceil( np, nb ), lcm / nprow ) +
290 itemp =
max(
iceil( dblesz*itemp, zplxsz ),
292 worksiz =
max( lwork, itemp ) + ipostpad
298 IF( ipw+worksiz.GT.memsiz )
THEN
300 $
WRITE( nout, fmt = 9996 )
'Tridiagonal reduction',
301 $ ( ipw+worksiz )*zplxsz
307 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
309 IF( ierr( 1 ).GT.0 )
THEN
311 $
WRITE( nout, fmt = 9997 )
'MEMORY'
318 CALL pzmatgen( ictxt,
'Hemm',
'N', desca( m_ ),
319 $ desca( n_ ), desca( mb_ ), desca( nb_ ),
320 $ mem( ipa ), desca( lld_ ), desca( rsrc_ ),
321 $ desca( csrc_ ), iaseed, 0, np, 0, nq,
322 $ myrow, mycol, nprow, npcol )
327 CALL pzfillpad( ictxt, np, nq, mem( ipa-iprepad ),
328 $ desca( lld_ ), iprepad, ipostpad,
330 CALL pzfillpad( ictxt, ndiag, 1, mem( ipd-iprepad ),
331 $ ndiag, iprepad, ipostpad, padval )
332 CALL pzfillpad( ictxt, noffd, 1, mem( ipe-iprepad ),
333 $ noffd, iprepad, ipostpad, padval )
334 CALL pzfillpad( ictxt, nq, 1, mem( ipt-iprepad ), nq,
335 $ iprepad, ipostpad, padval )
336 CALL pzfillpad( ictxt, worksiz-ipostpad, 1,
337 $ mem( ipw-iprepad ), worksiz-ipostpad,
338 $ iprepad, ipostpad, padval )
339 anorm =
pzlanhe(
'I', uplo, n, mem( ipa ), 1, 1,
340 $ desca, mem( ipw ) )
341 CALL pzchekpad( ictxt,
'PZLANHE', np, nq,
342 $ mem( ipa-iprepad ), desca( lld_ ),
343 $ iprepad, ipostpad, padval )
344 CALL pzchekpad( ictxt,
'PZLANHE', worksiz-ipostpad, 1,
345 $ mem( ipw-iprepad ), worksiz-ipostpad,
346 $ iprepad, ipostpad, padval )
347 CALL pzfillpad( ictxt, worktrd-ipostpad, 1,
348 $ mem( ipw-iprepad ), worktrd-ipostpad,
349 $ iprepad, ipostpad, padval )
353 CALL blacs_barrier( ictxt,
'All' )
358 CALL pzhetrd( uplo, n, mem( ipa ), 1, 1, desca,
359 $ mem( ipd ), mem( ipe ), mem( ipt ),
360 $ mem( ipw ), lwork, info )
368 CALL pzchekpad( ictxt,
'PZHETRD', np, nq,
369 $ mem( ipa-iprepad ), desca( lld_ ),
370 $ iprepad, ipostpad, padval )
371 CALL pzchekpad( ictxt,
'PZHETRD', ndiag, 1,
372 $ mem( ipd-iprepad ), ndiag, iprepad,
374 CALL pzchekpad( ictxt,
'PZHETRD', noffd, 1,
375 $ mem( ipe-iprepad ), noffd, iprepad,
378 $ mem( ipt-iprepad ), nq, iprepad,
380 CALL pzchekpad( ictxt,
'PZHETRD', worktrd-ipostpad, 1,
381 $ mem( ipw-iprepad ), worktrd-ipostpad,
382 $ iprepad, ipostpad, padval )
383 CALL pzfillpad( ictxt, worksiz-ipostpad, 1,
384 $ mem( ipw-iprepad ), worksiz-ipostpad,
385 $ iprepad, ipostpad, padval )
389 CALL pzhetdrv( uplo, n, mem( ipa ), 1, 1, desca,
390 $ mem( ipd ), mem( ipe ), mem( ipt ),
391 $ mem( ipw ), ierr( 1 ) )
392 CALL pzlafchk(
'Hemm',
'No', n, n, mem( ipa ), 1, 1,
393 $ desca, iaseed, anorm, fresid,
398 CALL pzchekpad( ictxt,
'PZHETDRV', np, nq,
399 $ mem( ipa-iprepad ), desca( lld_ ),
400 $ iprepad, ipostpad, padval )
401 CALL pzchekpad( ictxt,
'PZHETDRV', ndiag, 1,
402 $ mem( ipd-iprepad ), ndiag, iprepad,
404 CALL pzchekpad( ictxt,
'PZHETDRV', noffd, 1,
405 $ mem( ipe-iprepad ), noffd, iprepad,
407 CALL pzchekpad( ictxt,
'PZHETDRV', worksiz-ipostpad,
408 $ 1, mem( ipw-iprepad ),
409 $ worksiz-ipostpad, iprepad, ipostpad,
414 IF( fresid.LE.thresh .AND. fresid-fresid.EQ.
415 $ 0.0d+0 .AND. ierr( 1 ).EQ.0 )
THEN
419 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
420 $
WRITE( nout, fmt = 9986 )fresid
425 IF( myrow.EQ.0 .AND. mycol.EQ.0 .AND. ierr( 1 ).NE.0 )
426 $
WRITE( nout, fmt = * )
'D or E copies incorrect ...'
432 fresid = fresid - fresid
438 CALL slcombine( ictxt,
'All',
'>',
'W', 1, 1, wtime )
439 CALL slcombine( ictxt,
'All',
'>',
'C', 1, 1, ctime )
443 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
THEN
449 nops = ( 4.0d+0 / 3.0d+0 )*nops**3
454 IF( wtime( 1 ).GT.0.0d+0 )
THEN
455 tmflops = nops / wtime( 1 )
459 IF( wtime( 1 ).GE.0.0d+0 )
460 $
WRITE( nout, fmt = 9993 )
'WALL', uplo, n, nb,
461 $ nprow, npcol, wtime( 1 ), tmflops, fresid, passed
465 IF( ctime( 1 ).GT.0.0d+0 )
THEN
466 tmflops = nops / ctime( 1 )
470 IF( ctime( 1 ).GE.0.0d+0 )
471 $
WRITE( nout, fmt = 9993 )
'CPU ', uplo, n, nb,
472 $ nprow, npcol, ctime( 1 ), tmflops, fresid, passed
477 CALL blacs_gridexit( ictxt )
480 CALL pzttrdtester( iam, nprocs, check, nout, thresh, nval, nmat,
481 $ mem, totmem, kpass, kfail, kskip )
486 ktests = kpass + kfail + kskip
487 WRITE( nout, fmt = * )
488 WRITE( nout, fmt = 9992 )ktests
490 WRITE( nout, fmt = 9991 )kpass
491 WRITE( nout, fmt = 9989 )kfail
493 WRITE( nout, fmt = 9990 )kpass
495 WRITE( nout, fmt = 9988 )kskip
496 WRITE( nout, fmt = * )
497 WRITE( nout, fmt = * )
498 WRITE( nout, fmt = 9987 )
499 IF( nout.NE.6 .AND. nout.NE.0 )
505 9999
FORMAT(
'ILLEGAL ', a6,
': ', a5,
' = ', i3,
506 $
'; It should be at least 1' )
507 9998
FORMAT(
'ILLEGAL GRID: nprow*npcol = ', i4,
'. It can be at most',
509 9997
FORMAT(
'Bad ', a6,
' parameters: going on to next test case.' )
510 9996
FORMAT(
'Unable to perform ', a,
': need TOTMEM of at least',
512 9995
FORMAT(
'TIME UPLO N NB P Q TRD Time ',
513 $
' MFLOPS Residual CHECK' )
514 9994
FORMAT(
'---- ---- ------ --- ----- ----- --------- ',
515 $
'----------- -------- ------' )
516 9993
FORMAT( a4, 1x, a4, 1x, i6, 1x, i3, 1x, i5, 1x, i5, 1x, f9.2, 1x,
517 $ f11.2, 1x, f8.2, 1x, a6 )
518 9992
FORMAT(
'Finished', i4,
' tests, with the following results:' )
519 9991
FORMAT( i5,
' tests completed and passed residual checks.' )
520 9990
FORMAT( i5,
' tests completed without checking.' )
521 9989
FORMAT( i5,
' tests completed and failed residual checks.' )
522 9988
FORMAT( i5,
' tests skipped because of illegal input values.' )
523 9987
FORMAT(
'END OF TESTS.' )
524 9986
FORMAT(
'||A - Q*T*Q''|| / (||A|| * N * eps) = ', g25.7 )