59 INTEGER block_cyclic_2d, csrc_, ctxt_, dlen_, dt_,
60 $ lld_, mb_, m_, nb_, n_, rsrc_
61 parameter( block_cyclic_2d = 1, dlen_ = 9, dt_ = 1,
62 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
63 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
64 INTEGER dblesz, totmem, memsiz, ntests
65 DOUBLE PRECISION padval, zero, one
66 parameter( dblesz = 8, totmem = 2000000,
67 $ memsiz = totmem / dblesz, ntests = 20,
68 $ padval = -9923.0d+0, zero = 0.0d+0,
75 INTEGER i, iam, iaseed, ictxt, iii, imidpad, info, ipa,
76 $ ipostpad, iprepad, ipw, ipwi, ipwr, ipz, j, k,
77 $ kfail, kpass, kskip, ktests, lda, ldz, lwork,
78 $ mycol, myrow, n, nb, ngrids, nmat, nnb, nout,
79 $ np, npcol, nprocs, nprow, nq, worksiz
81 DOUBLE PRECISION anorm, fresid, nops, qresid, tmflops, znorm
84 INTEGER desca( dlen_ ), descz( dlen_ ), ierr( 2 ),
85 $ idum( 1 ), nbval( ntests ), nval( ntests ),
86 $ pval( ntests ), qval( ntests )
87 DOUBLE PRECISION ctime( 1 ), mem( memsiz ), wtime( 1 )
90 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
91 $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
106 DATA kfail, kpass, kskip, ktests / 4*0 /
112 CALL blacs_pinfo( iam, nprocs )
114 CALL pdnepinfo( outfile, nout, nmat, nval, ntests, nnb, nbval,
115 $ ntests, ngrids, pval, ntests, qval, ntests,
116 $ thresh, mem, iam, nprocs )
117 check = ( thresh.GE.0.0e+0 )
122 WRITE( nout, fmt = * )
123 WRITE( nout, fmt = 9995 )
124 WRITE( nout, fmt = 9994 )
125 WRITE( nout, fmt = * )
138 IF( nprow.LT.1 )
THEN
140 $
WRITE( nout, fmt = 9999 )
'GRID',
'nprow', nprow
142 ELSE IF( npcol.LT.1 )
THEN
144 $
WRITE( nout, fmt = 9999 )
'GRID',
'npcol', npcol
146 ELSE IF( nprow*npcol.GT.nprocs )
THEN
148 $
WRITE( nout, fmt = 9998 )nprow*npcol, nprocs
152 IF( ierr( 1 ).GT.0 )
THEN
154 $
WRITE( nout, fmt = 9997 )
'grid'
161 CALL blacs_get( -1, 0, ictxt )
162 CALL blacs_gridinit( ictxt,
'Row-major', nprow, npcol )
163 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
168 IF( myrow.GE.nprow .OR. mycol.GE.npcol )
180 $
WRITE( nout, fmt = 9999 )
'MATRIX',
'N', n
186 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
188 IF( ierr( 1 ).GT.0 )
THEN
190 $
WRITE( nout, fmt = 9997 )
'matrix'
205 $
WRITE( nout, fmt = 9999 )
'NB',
'NB', nb
210 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
212 IF( ierr( 1 ).GT.0 )
THEN
214 $
WRITE( nout, fmt = 9997 )
'NB'
221 np =
numroc( n, nb, myrow, 0, nprow )
222 nq =
numroc( n, nb, mycol, 0, npcol )
224 iprepad =
max( nb, np )
226 ipostpad =
max( nb, nq )
227 iprepad = iprepad + 1000
228 imidpad = imidpad + 1000
229 ipostpad = ipostpad + 1000
238 CALL descinit( desca, n, n, nb, nb, 0, 0, ictxt,
239 $
max( 1, np )+imidpad, ierr( 1 ) )
243 CALL descinit( descz, n, n, nb, nb, 0, 0, ictxt,
244 $
max( 1, np )+imidpad, ierr( 2 ) )
251 CALL igsum2d( ictxt,
'All',
' ', 2, 1, ierr, 2, -1, 0 )
253 IF( ierr( 1 ).LT.0 .OR. ierr( 2 ).LT.0 )
THEN
255 $
WRITE( nout, fmt = 9997 )
'descriptor'
264 ipz = ipa + desca( lld_ )*nq + ipostpad + iprepad
265 ipwr = ipz + descz( lld_ )*nq + ipostpad + iprepad
266 ipwi = ipwr + n + ipostpad + iprepad
267 ipw = ipwi + n + ipostpad + iprepad
271 iii = 7*iii /
ilcm( nprow, npcol )
274 lwork = 3*n +
max( 2*
max( lda, ldz )+2*nq, iii )
275 lwork = lwork +
max(2*n, (8*
ilcm(nprow,npcol)+2)**2 )
282 worksiz = lwork +
max( np*desca( nb_ ),
283 $ desca( mb_ )*nq ) + ipostpad
287 worksiz = lwork + ipostpad
294 IF( ipw+worksiz.GT.memsiz )
THEN
296 $
WRITE( nout, fmt = 9996 )
'Schur reduction',
297 $ ( ipw+worksiz )*dblesz
303 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
305 IF( ierr( 1 ).GT.0 )
THEN
307 $
WRITE( nout, fmt = 9997 )
'MEMORY'
314 CALL pdlaset(
'All', n, n, zero, one, mem( ipz ), 1, 1,
319 CALL pdmatgen( ictxt,
'No transpose',
'No transpose',
320 $ desca( m_ ), desca( n_ ), desca( mb_ ),
321 $ desca( nb_ ), mem( ipa ), desca( lld_ ),
322 $ desca( rsrc_ ), desca( csrc_ ), iaseed, 0,
323 $ np, 0, nq, myrow, mycol, nprow, npcol )
325 $ zero, zero, mem( ipa ),
min( n, 3 ), 1,
331 CALL pdfillpad( ictxt, np, nq, mem( ipa-iprepad ),
332 $ desca( lld_ ), iprepad, ipostpad,
334 CALL pdfillpad( ictxt, np, nq, mem( ipz-iprepad ),
335 $ descz( lld_ ), iprepad, ipostpad,
337 CALL pdfillpad( ictxt, worksiz-ipostpad, 1,
338 $ mem( ipw-iprepad ), worksiz-ipostpad,
339 $ iprepad, ipostpad, padval )
340 anorm =
pdlanhs(
'I', n, mem( ipa ), 1, 1, desca,
342 CALL pdchekpad( ictxt,
'PDLANHS', np, nq,
343 $ mem( ipa-iprepad ), desca( lld_ ),
344 $ iprepad, ipostpad, padval )
345 CALL pdchekpad( ictxt,
'PDLANHS', worksiz-ipostpad, 1,
346 $ mem( ipw-iprepad ), worksiz-ipostpad,
347 $ iprepad, ipostpad, padval )
349 CALL pdfillpad( ictxt, n, 1, mem( ipwr-iprepad ), n,
350 $ iprepad, ipostpad, padval )
351 CALL pdfillpad( ictxt, n, 1, mem( ipwi-iprepad ), n,
352 $ iprepad, ipostpad, padval )
353 CALL pdfillpad( ictxt, lwork, 1, mem( ipw-iprepad ),
354 $ lwork, iprepad, ipostpad, padval )
359 CALL blacs_barrier( ictxt,
'All' )
364 CALL pdlahqr( .true., .true., n, 1, n, mem( ipa ), desca,
365 $ mem( ipwr ), mem( ipwi ), 1, n, mem( ipz ),
366 $ descz, mem( ipw ), lwork, idum, 0, info )
372 $
WRITE( nout, fmt = * )
'PDLAHQR INFO=', info
381 CALL pdchekpad( ictxt,
'PDLAHQR (A)', np, nq,
382 $ mem( ipa-iprepad ), desca( lld_ ),
383 $ iprepad, ipostpad, padval )
384 CALL pdchekpad( ictxt,
'PDLAHQR (Z)', np, nq,
385 $ mem( ipz-iprepad ), descz( lld_ ),
386 $ iprepad, ipostpad, padval )
387 CALL pdchekpad( ictxt,
'PDLAHQR (WR)', n, 1,
388 $ mem( ipwr-iprepad ), n, iprepad,
390 CALL pdchekpad( ictxt,
'PDLAHQR (WI)', n, 1,
391 $ mem( ipwi-iprepad ), n, iprepad,
393 CALL pdchekpad( ictxt,
'PDLAHQR (WORK)', lwork, 1,
394 $ mem( ipw-iprepad ), lwork, iprepad,
397 CALL pdfillpad( ictxt, worksiz-ipostpad, 1,
398 $ mem( ipw-iprepad ), worksiz-ipostpad,
399 $ iprepad, ipostpad, padval )
403 CALL pdnepfchk( n, mem( ipa ), 1, 1, desca, iaseed,
404 $ mem( ipz ), 1, 1, descz, anorm,
405 $ fresid, mem( ipw ) )
407 CALL pdchekpad( ictxt,
'PDNEPFCHK (A)', np, nq,
408 $ mem( ipa-iprepad ), desca( lld_ ),
409 $ iprepad, ipostpad, padval )
410 CALL pdchekpad( ictxt,
'PDNEPFCHK (Z)', np, nq,
411 $ mem( ipz-iprepad ), descz( lld_ ),
412 $ iprepad, ipostpad, padval )
413 CALL pdchekpad( ictxt,
'PDNEPFCHK (WORK)',
414 $ worksiz-ipostpad, 1,
415 $ mem( ipw-iprepad ), worksiz-ipostpad,
416 $ iprepad, ipostpad, padval )
420 CALL pdlaset(
'All', n, n, zero, one, mem( ipa ), 1,
422 CALL pdgemm(
'Transpose',
'No transpose', n, n, n,
423 $ -one, mem( ipz ), 1, 1, descz,
424 $ mem( ipz ), 1, 1, descz, one, mem( ipa ),
426 znorm =
pdlange(
'1', n, n, mem( ipa ), 1, 1, desca,
428 qresid = znorm / ( dble( n )*
pdlamch( ictxt,
'P' ) )
432 IF( ( fresid.LE.thresh ) .AND.
433 $ ( ( fresid-fresid ).EQ.0.0d+0 ) .AND.
434 $ ( qresid.LE.thresh ) .AND.
435 $ ( ( qresid-qresid ).EQ.0.0d+0 ) )
THEN
442 WRITE( nout, fmt = 9986 )fresid
443 WRITE( nout, fmt = 9985 )qresid
452 fresid = fresid - fresid
453 qresid = qresid - qresid
460 CALL slcombine( ictxt,
'All',
'>',
'W', 1, 1, wtime )
461 CALL slcombine( ictxt,
'All',
'>',
'C', 1, 1, ctime )
465 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
THEN
469 nops = 18.0d+0*dble( n )**3
476 IF( wtime( 1 ).GT.0.0d+0 )
THEN
477 tmflops = nops / ( wtime( 1 )*1.0d+6 )
481 IF( wtime( 1 ).GE.0.0d+0 )
482 $
WRITE( nout, fmt = 9993 )
'WALL', n, nb, nprow,
483 $ npcol, wtime( 1 ), tmflops, passed
487 IF( ctime( 1 ).GT.0.0d+0 )
THEN
488 tmflops = nops / ( ctime( 1 )*1.0d+6 )
493 IF( ctime( 1 ).GE.0.0d+0 )
494 $
WRITE( nout, fmt = 9993 )
'CPU ', n, nb, nprow,
495 $ npcol, ctime( 1 ), tmflops, passed
502 CALL blacs_gridexit( ictxt )
509 ktests = kpass + kfail + kskip
510 WRITE( nout, fmt = * )
511 WRITE( nout, fmt = 9992 )ktests
513 WRITE( nout, fmt = 9991 )kpass
514 WRITE( nout, fmt = 9989 )kfail
516 WRITE( nout, fmt = 9990 )kpass
518 WRITE( nout, fmt = 9988 )kskip
519 WRITE( nout, fmt = * )
520 WRITE( nout, fmt = * )
521 WRITE( nout, fmt = 9987 )
522 IF( nout.NE.6 .AND. nout.NE.0 )
528 9999
FORMAT(
'ILLEGAL ', a6,
': ', a5,
' = ', i3,
529 $
'; It should be at least 1' )
530 9998
FORMAT(
'ILLEGAL GRID: nprow*npcol = ', i4,
'. It can be at most',
532 9997
FORMAT(
'Bad ', a6,
' parameters: going on to next test case.' )
533 9996
FORMAT(
'Unable to perform ', a,
': need TOTMEM of at least',
535 9995
FORMAT(
'TIME N NB P Q NEP Time MFLOPS CHECK' )
536 9994
FORMAT(
'---- ----- --- ---- ---- -------- -------- ------' )
537 9993
FORMAT( a4, 1x, i5, 1x, i3, 1x, i4, 1x, i4, 1x, f8.2, 1x, f8.2,
539 9992
FORMAT(
'Finished ', i6,
' tests, with the following results:' )
540 9991
FORMAT( i5,
' tests completed and passed residual checks.' )
541 9990
FORMAT( i5,
' tests completed without checking.' )
542 9989
FORMAT( i5,
' tests completed and failed residual checks.' )
543 9988
FORMAT( i5,
' tests skipped because of illegal input values.' )
544 9987
FORMAT(
'END OF TESTS.' )
545 9986
FORMAT(
'||H - Q*S*Q^T|| / (||H|| * N * eps) = ', g25.7 )
546 9985
FORMAT(
'||Q^T*Q - I|| / ( N * eps ) ', g25.7 )
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 numroc(n, nb, iproc, isrcproc, nprocs)
subroutine pdlaset(uplo, m, n, alpha, beta, a, ia, ja, desca)
double precision function pdlamch(ictxt, cmach)
subroutine pdchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pdfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
subroutine pdlahqr(wantt, wantz, n, ilo, ihi, a, desca, wr, wi, iloz, ihiz, z, descz, work, lwork, iwork, ilwork, info)
double precision function pdlange(norm, m, n, a, ia, ja, desca, work)
double precision function pdlanhs(norm, n, a, ia, ja, desca, work)
subroutine pdnepfchk(n, a, ia, ja, desca, iaseed, z, iz, jz, descz, anorm, fresid, work)
subroutine pdnepinfo(summry, nout, nmat, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)