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 )
subroutine pzlafchk(aform, diag, m, n, a, ia, ja, desca, iaseed, anorm, fresid, work)
subroutine pzmatgen(ictxt, aform, diag, m, n, mb, nb, a, lda, iarow, iacol, iseed, iroff, irnum, icoff, icnum, myrow, mycol, nprow, npcol)
subroutine descinit(desc, m, n, mb, nb, irsrc, icsrc, ictxt, lld, info)
integer function iceil(inum, idenom)
integer function ilcm(m, n)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
subroutine pzchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pzfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
subroutine pzhetdrv(uplo, n, a, ia, ja, desca, d, e, tau, work, info)
subroutine pzhetrd(uplo, n, a, ia, ja, desca, d, e, tau, work, lwork, info)
double precision function pzlanhe(norm, uplo, n, a, ia, ja, desca, work)
subroutine pztrdinfo(summry, nout, uplo, nmat, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
subroutine pzttrdtester(iam, nprocs, check, nout, thresh, nval, nmat, mem, totmem, kpass, kfail, kskip)
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)