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 )