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, memsiz, ntests, totmem
67 DOUBLE PRECISION padval
68 parameter( dblesz = 8, totmem = 2000000,
69 $ memsiz = totmem / dblesz, ntests = 20,
70 $ padval = -9923.0d+0 )
76 INTEGER i, iam, iaseed, ictxt, ihi, ihip, ihlp, ihlq,
77 $ ilcol, ilo, ilrow, info, inlq, imidpad, ipa,
78 $ ipt, ipw, ipostpad, iprepad, itemp, j, k,
79 $ kfail, kpass, kskip, ktests, lcm, lcmq, loff,
80 $ lwork, mycol, myrow, n, nb, ngrids, nmat, nnb,
81 $ nprocs, nout, np, npcol, nprow, nq, workhrd,
84 DOUBLE PRECISION anorm, fresid, nops, tmflops
87 INTEGER desca( dlen_ ), ierr( 1 ), nbval( ntests ),
88 $ nval( ntests ), nvhi( ntests ), nvlo( ntests ),
89 $ pval( ntests ), qval( ntests )
90 DOUBLE PRECISION ctime( 1 ), mem( memsiz ), wtime( 1 )
93 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
94 $ blacs_gridexit, blacs_gridinit, blacs_gridinfo,
109 DATA ktests, kpass, kfail, kskip / 4*0 /
115 CALL blacs_pinfo( iam, nprocs )
117 CALL pdhrdinfo( outfile, nout, nmat, nval, nvlo, nvhi, ntests,
118 $ nnb, nbval, ntests, ngrids, pval, ntests, qval,
119 $ ntests, thresh, mem, iam, nprocs )
120 check = ( thresh.GE.0.0e+0 )
125 WRITE( nout, fmt = * )
126 WRITE( nout, fmt = 9995 )
127 WRITE( nout, fmt = 9994 )
128 WRITE( nout, fmt = * )
141 IF( nprow.LT.1 )
THEN
143 $
WRITE( nout, fmt = 9999 )
'GRID',
'nprow', nprow
145 ELSE IF( npcol.LT.1 )
THEN
147 $
WRITE( nout, fmt = 9999 )
'GRID',
'npcol', npcol
149 ELSE IF( nprow*npcol.GT.nprocs )
THEN
151 $
WRITE( nout, fmt = 9998 )nprow*npcol, nprocs
155 IF( ierr( 1 ).GT.0 )
THEN
157 $
WRITE( nout, fmt = 9997 )
'grid'
164 CALL blacs_get( -1, 0, ictxt )
165 CALL blacs_gridinit( ictxt,
'Row-major', nprow, npcol )
166 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
170 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'
208 $
WRITE( nout, fmt = 9999 )
'NB',
'NB', nb
213 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
215 IF( ierr( 1 ).GT.0 )
THEN
217 $
WRITE( nout, fmt = 9997 )
'NB'
222 np =
numroc( n, nb, myrow, 0, nprow )
223 nq =
numroc( n, nb, mycol, 0, npcol )
225 iprepad =
max( nb, np )
227 ipostpad =
max( nb, nq )
236 CALL descinit( desca, n, n, nb, nb, 0, 0, ictxt,
237 $
max( 1, np ) + imidpad, info )
241 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
243 IF( ierr( 1 ).LT.0 )
THEN
245 $
WRITE( nout, fmt = 9997 )
'descriptor'
254 ipt = ipa + desca( lld_ )*nq + ipostpad + iprepad
255 ipw = ipt + nq + ipostpad + iprepad
260 ihip =
numroc( ihi, nb, myrow, desca( rsrc_ ), nprow )
261 loff = mod( ilo-1, nb )
262 ilrow =
indxg2p( ilo, nb, myrow, desca( rsrc_ ), nprow )
263 ilcol =
indxg2p( ilo, nb, mycol, desca( csrc_ ), npcol )
264 ihlp =
numroc( ihi-ilo+loff+1, nb, myrow, ilrow, nprow )
265 inlq =
numroc( n-ilo+loff+1, nb, mycol, ilcol, npcol )
266 lwork = nb*( nb +
max( ihip+1, ihlp+inlq ) )
267 workhrd = lwork + ipostpad
273 lcm =
ilcm( nprow, npcol )
275 ihlq =
numroc( ihi-ilo+loff+1, nb, mycol, ilcol,
277 itemp = nb*
max( ihlp+inlq, ihlq+
max( ihip,
279 $ npcol ), nb, 0, 0, lcmq ) ) )
280 worksiz =
max( nb*nb + nb*ihlp + itemp, nb * np ) +
287 IF( ipw+worksiz.GT.memsiz )
THEN
289 $
WRITE( nout, fmt = 9996 )
'Hessenberg reduction',
290 $ ( ipw+worksiz )*dblesz
296 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
298 IF( ierr( 1 ).GT.0 )
THEN
300 $
WRITE( nout, fmt = 9997 )
'MEMORY'
307 CALL pdmatgen( ictxt,
'No',
'No', desca( m_ ),
308 $ desca( n_ ), desca( mb_ ), desca( nb_ ),
309 $ mem( ipa ), desca( lld_ ), desca( rsrc_ ),
311 $ iaseed, 0, np, 0, nq, myrow, mycol,
317 CALL pdfillpad( ictxt, np, nq, mem( ipa-iprepad ),
318 $ desca( lld_ ), iprepad, ipostpad,
320 CALL pdfillpad( ictxt, nq, 1, mem( ipt-iprepad ),
321 $ nq, iprepad, ipostpad, padval )
322 CALL pdfillpad( ictxt, worksiz-ipostpad, 1,
323 $ mem( ipw-iprepad ), worksiz-ipostpad,
324 $ iprepad, ipostpad, padval )
325 anorm =
pdlange(
'I', n, n, mem( ipa ), 1, 1, desca,
327 CALL pdchekpad( ictxt,
'PDLANGE', np, nq,
328 $ mem( ipa-iprepad ), desca( lld_ ),
329 $ iprepad, ipostpad, padval )
331 $ worksiz-ipostpad, 1,
332 $ mem( ipw-iprepad ), worksiz-ipostpad,
333 $ iprepad, ipostpad, padval )
334 CALL pdfillpad( ictxt, workhrd-ipostpad, 1,
335 $ mem( ipw-iprepad ), workhrd-ipostpad,
336 $ iprepad, ipostpad, padval )
340 CALL blacs_barrier( ictxt,
'All' )
345 CALL pdgehrd( n, ilo, ihi, mem( ipa ), 1, 1, desca,
346 $ mem( ipt ), mem( ipw ), lwork, info )
353 CALL pdchekpad( ictxt,
'PDGEHRD', np, nq,
354 $ mem( ipa-iprepad ), desca( lld_ ),
355 $ iprepad, ipostpad, padval )
357 $ mem( ipt-iprepad ), nq, iprepad,
359 CALL pdchekpad( ictxt,
'PDGEHRD', workhrd-ipostpad,
360 $ 1, mem( ipw-iprepad ),
361 $ workhrd-ipostpad, iprepad,
363 CALL pdfillpad( ictxt, worksiz-ipostpad, 1,
364 $ mem( ipw-iprepad ), worksiz-ipostpad,
365 $ iprepad, ipostpad, padval )
369 CALL pdgehdrv( n, ilo, ihi, mem( ipa ), 1, 1, desca,
370 $ mem( ipt ), mem( ipw ) )
371 CALL pdlafchk(
'No',
'No', n, n, mem( ipa ), 1, 1,
372 $ desca, iaseed, anorm, fresid,
377 CALL pdchekpad( ictxt,
'PDGEHDRV', np, nq,
378 $ mem( ipa-iprepad ), desca( lld_ ),
379 $ iprepad, ipostpad, padval )
380 CALL pdchekpad( ictxt,
'PDGEHDRV', nq, 1,
381 $ mem( ipt-iprepad ), nq, iprepad,
384 $ worksiz-ipostpad, 1,
385 $ mem( ipw-iprepad ), worksiz-ipostpad,
386 $ iprepad, ipostpad, padval )
390 IF( fresid.LE.thresh .AND. fresid-fresid.EQ.0.0d+0 )
395 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
396 $
WRITE( nout, fmt = 9986 ) fresid
405 fresid = fresid - fresid
411 CALL slcombine( ictxt,
'All',
'>',
'W', 1, 1, wtime )
412 CALL slcombine( ictxt,
'All',
'>',
'C', 1, 1, ctime )
416 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
THEN
422 nops = dble( ihi-ilo )
424 $ ( 2.0d0*dble( ihi ) + (4.0d0/3.0d0)*nops )
429 IF( wtime( 1 ).GT.0.0d+0 )
THEN
430 tmflops = nops / wtime( 1 )
434 IF( wtime( 1 ).GE.0.0d+0 )
435 $
WRITE( nout, fmt = 9993 )
'WALL', n, ilo, ihi, nb,
436 $ nprow, npcol, wtime( 1 ), tmflops, fresid,
441 IF( ctime( 1 ).GT.0.0d+0 )
THEN
442 tmflops = nops / ctime( 1 )
446 IF( ctime( 1 ).GE.0.0d+0 )
447 $
WRITE( nout, fmt = 9993 )
'CPU ', n, ilo, ihi, nb,
448 $ nprow, npcol, ctime( 1 ), tmflops, fresid,
454 CALL blacs_gridexit( ictxt )
460 ktests = kpass + kfail + kskip
461 WRITE( nout, fmt = * )
462 WRITE( nout, fmt = 9992 ) ktests
464 WRITE( nout, fmt = 9991 ) kpass
465 WRITE( nout, fmt = 9989 ) kfail
467 WRITE( nout, fmt = 9990 ) kpass
469 WRITE( nout, fmt = 9988 ) kskip
470 WRITE( nout, fmt = * )
471 WRITE( nout, fmt = * )
472 WRITE( nout, fmt = 9987 )
473 IF( nout.NE.6 .AND. nout.NE.0 )
479 9999
FORMAT(
'ILLEGAL ', a6,
': ', a5,
' = ', i3,
480 $
'; It should be at least 1' )
481 9998
FORMAT(
'ILLEGAL GRID: nprow*npcol = ', i4,
'. It can be at most',
483 9997
FORMAT(
'Bad ', a6,
' parameters: going on to next test case.' )
484 9996
FORMAT(
'Unable to perform ', a,
': need TOTMEM of at least',
486 9995
FORMAT(
'TIME N ILO IHI NB P Q HRD Time ',
487 $
' MFLOPS Residual CHECK' )
488 9994
FORMAT(
'---- ------ ------ ------ --- ----- ----- --------- ',
489 $
'----------- -------- ------' )
490 9993
FORMAT( a4, 1x, i6, 1x, i6, 1x, i6, 1x, i3, 1x, i5, 1x, i5, 1x,
491 $ f9.2, 1x, f11.2, 1x, f8.2, 1x, a6 )
492 9992
FORMAT(
'Finished', i4,
' tests, with the following results:' )
493 9991
FORMAT( i5,
' tests completed and passed residual checks.' )
494 9990
FORMAT( i5,
' tests completed without checking.' )
495 9989
FORMAT( i5,
' tests completed and failed residual checks.' )
496 9988
FORMAT( i5,
' tests skipped because of illegal input values.' )
497 9987
FORMAT(
'END OF TESTS.' )
498 9986
FORMAT(
'||A - Q*H*Q''|| / (||A|| * N * eps) = ', g25.7 )
subroutine pdlafchk(aform, diag, m, n, a, ia, ja, desca, iaseed, anorm, fresid, work)
subroutine pdmatgen(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 ilcm(m, n)
integer function indxg2p(indxglob, nb, iproc, isrcproc, nprocs)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
subroutine pdchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pdfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
subroutine pdgehdrv(n, ilo, ihi, a, ia, ja, desca, tau, work)
subroutine pdgehrd(n, ilo, ihi, a, ia, ja, desca, tau, work, lwork, info)
subroutine pdhrdinfo(summry, nout, nmat, nval, nvlo, nvhi, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
double precision function pdlange(norm, m, n, a, ia, ja, desca, work)
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)