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 cplxsz, realsz, totmem, memsiz, ntests
68 parameter( cplxsz = 8, realsz = 4, totmem = 2000000,
69 $ memsiz = totmem / cplxsz, ntests = 20,
70 $ padval = ( -9923.0e+0, -9923.0e+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,
83 REAL anorm, fresid, thresh
84 DOUBLE PRECISION nops, tmflops
87 INTEGER desca( dlen_ ), ierr( 1 ), nbval( ntests ),
88 $ nval( ntests ), pval( ntests ), qval( ntests )
90 DOUBLE PRECISION ctime( 1 ), wtime( 1 )
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 pctrdinfo( 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( realsz*ndiag, cplxsz )
266 noffd =
iceil( realsz*noffd, cplxsz )
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( realsz*itemp, cplxsz ),
292 worksiz =
max( lwork, itemp ) + ipostpad
298 IF( ipw+worksiz.GT.memsiz )
THEN
300 $
WRITE( nout, fmt = 9996 )
'Tridiagonal reduction',
301 $ ( ipw+worksiz )*cplxsz
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 pcmatgen( 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 pcfillpad( ictxt, np, nq, mem( ipa-iprepad ),
328 $ desca( lld_ ), iprepad, ipostpad,
330 CALL pcfillpad( ictxt, ndiag, 1, mem( ipd-iprepad ),
331 $ ndiag, iprepad, ipostpad, padval )
332 CALL pcfillpad( ictxt, noffd, 1, mem( ipe-iprepad ),
333 $ noffd, iprepad, ipostpad, padval )
334 CALL pcfillpad( ictxt, nq, 1, mem( ipt-iprepad ), nq,
335 $ iprepad, ipostpad, padval )
336 CALL pcfillpad( ictxt, worksiz-ipostpad, 1,
337 $ mem( ipw-iprepad ), worksiz-ipostpad,
338 $ iprepad, ipostpad, padval )
339 anorm =
pclanhe(
'I', uplo, n, mem( ipa ), 1, 1,
340 $ desca, mem( ipw ) )
341 CALL pcchekpad( ictxt,
'PCLANHE', np, nq,
342 $ mem( ipa-iprepad ), desca( lld_ ),
343 $ iprepad, ipostpad, padval )
344 CALL pcchekpad( ictxt,
'PCLANHE', worksiz-ipostpad, 1,
345 $ mem( ipw-iprepad ), worksiz-ipostpad,
346 $ iprepad, ipostpad, padval )
347 CALL pcfillpad( ictxt, worktrd-ipostpad, 1,
348 $ mem( ipw-iprepad ), worktrd-ipostpad,
349 $ iprepad, ipostpad, padval )
353 CALL blacs_barrier( ictxt,
'All' )
358 CALL pchetrd( uplo, n, mem( ipa ), 1, 1, desca,
359 $ mem( ipd ), mem( ipe ), mem( ipt ),
360 $ mem( ipw ), lwork, info )
368 CALL pcchekpad( ictxt,
'PCHETRD', np, nq,
369 $ mem( ipa-iprepad ), desca( lld_ ),
370 $ iprepad, ipostpad, padval )
371 CALL pcchekpad( ictxt,
'PCHETRD', ndiag, 1,
372 $ mem( ipd-iprepad ), ndiag, iprepad,
374 CALL pcchekpad( ictxt,
'PCHETRD', noffd, 1,
375 $ mem( ipe-iprepad ), noffd, iprepad,
378 $ mem( ipt-iprepad ), nq, iprepad,
380 CALL pcchekpad( ictxt,
'PCHETRD', worktrd-ipostpad, 1,
381 $ mem( ipw-iprepad ), worktrd-ipostpad,
382 $ iprepad, ipostpad, padval )
383 CALL pcfillpad( ictxt, worksiz-ipostpad, 1,
384 $ mem( ipw-iprepad ), worksiz-ipostpad,
385 $ iprepad, ipostpad, padval )
389 CALL pchetdrv( uplo, n, mem( ipa ), 1, 1, desca,
390 $ mem( ipd ), mem( ipe ), mem( ipt ),
391 $ mem( ipw ), ierr( 1 ) )
392 CALL pclafchk(
'Hemm',
'No', n, n, mem( ipa ), 1, 1,
393 $ desca, iaseed, anorm, fresid,
398 CALL pcchekpad( ictxt,
'PCHETDRV', np, nq,
399 $ mem( ipa-iprepad ), desca( lld_ ),
400 $ iprepad, ipostpad, padval )
401 CALL pcchekpad( ictxt,
'PCHETDRV', ndiag, 1,
402 $ mem( ipd-iprepad ), ndiag, iprepad,
404 CALL pcchekpad( ictxt,
'PCHETDRV', noffd, 1,
405 $ mem( ipe-iprepad ), noffd, iprepad,
407 CALL pcchekpad( ictxt,
'PCHETDRV', worksiz-ipostpad,
408 $ 1, mem( ipw-iprepad ),
409 $ worksiz-ipostpad, iprepad, ipostpad,
414 IF( fresid.LE.thresh .AND. fresid-fresid.EQ.
415 $ 0.0e+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 pcttrdtester( 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 pclafchk(aform, diag, m, n, a, ia, ja, desca, iaseed, anorm, fresid, work)
subroutine pcmatgen(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 pcchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pcfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
subroutine pchetdrv(uplo, n, a, ia, ja, desca, d, e, tau, work, info)
subroutine pchetrd(uplo, n, a, ia, ja, desca, d, e, tau, work, lwork, info)
real function pclanhe(norm, uplo, n, a, ia, ja, desca, work)
subroutine pctrdinfo(summry, nout, uplo, nmat, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
subroutine pcttrdtester(iam, nprocs, check, nout, thresh, nval, nmat, mem, totmem, kpass, kfail, kskip)
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)