64 INTEGER block_cyclic_2d, csrc_, ctxt_, dlen_, dt_,
65 $ lld_, mb_, m_, nb_, n_, rsrc_
66 parameter( block_cyclic_2d = 1, dlen_ = 9, dt_ = 1,
67 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
68 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
69 INTEGER zplxsz, totmem, memsiz, ntests
70 parameter( zplxsz = 16, totmem = 200000000,
71 $ memsiz = totmem / zplxsz, ntests = 20 )
72 COMPLEX*16 padval, zero, one
73 parameter( padval = ( -9923.0d+0, -9923.0d+0 ),
74 $ zero = ( 0.0d+0, 0.0d+0 ),
75 $ one = ( 1.0d+0, 0.0d+0 ) )
81 INTEGER i, iam, iaseed, ictxt, iii, imidpad, info, ipa,
82 $ ipostpad, iprepad, ipw, ipwr, ipz, j, k, kfail,
83 $ kpass, kskip, ktests, lda, ldwork, ldz, lwork,
84 $ mycol, myrow, n, nb, ngrids, nmat, nnb, nout,
85 $ np, npcol, nprocs, nprow, nq, worksiz
87 DOUBLE PRECISION anorm, fresid, nops, qresid, tmflops, znorm
90 INTEGER desca( dlen_ ), descz( dlen_ ), idum( 1 ),
91 $ ierr( 2 ), nbval( ntests ), nval( ntests ),
92 $ pval( ntests ), qval( ntests )
93 DOUBLE PRECISION ctime( 2 ), wtime( 2 )
94 COMPLEX*16 mem( memsiz )
97 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
98 $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
113 DATA kfail, kpass, kskip, ktests / 4*0 /
119 CALL blacs_pinfo( iam, nprocs )
121 CALL pznepinfo( outfile, nout, nmat, nval, ntests, nnb, nbval,
122 $ ntests, ngrids, pval, ntests, qval, ntests,
123 $ thresh, mem, iam, nprocs )
124 check = ( thresh.GE.0.0e+0 )
129 WRITE( nout, fmt = * )
130 WRITE( nout, fmt = 9995 )
131 WRITE( nout, fmt = 9994 )
132 WRITE( nout, fmt = * )
145 IF( nprow.LT.1 )
THEN
147 $
WRITE( nout, fmt = 9999 )
'GRID',
'nprow', nprow
149 ELSE IF( npcol.LT.1 )
THEN
151 $
WRITE( nout, fmt = 9999 )
'GRID',
'npcol', npcol
153 ELSE IF( nprow*npcol.GT.nprocs )
THEN
155 $
WRITE( nout, fmt = 9998 )nprow*npcol, nprocs
159 IF( ierr( 1 ).GT.0 )
THEN
161 $
WRITE( nout, fmt = 9997 )
'grid'
168 CALL blacs_get( -1, 0, ictxt )
169 CALL blacs_gridinit( ictxt,
'Row-major', nprow, npcol )
170 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
175 IF( myrow.GE.nprow .OR. mycol.GE.npcol )
187 $
WRITE( nout, fmt = 9999 )
'MATRIX',
'N', n
193 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
195 IF( ierr( 1 ).GT.0 )
THEN
197 $
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 )
234 iprepad = iprepad + 1000
235 imidpad = imidpad + 1000
236 ipostpad = ipostpad + 1000
245 CALL descinit( desca, n, n, nb, nb, 0, 0, ictxt,
246 $
max( 1, np )+imidpad, ierr( 1 ) )
250 CALL descinit( descz, n, n, nb, nb, 0, 0, ictxt,
251 $
max( 1, np )+imidpad, ierr( 2 ) )
255 ldwork = descz( lld_ )
259 CALL igsum2d( ictxt,
'All',
' ', 2, 1, ierr, 2, -1, 0 )
261 IF( ierr( 1 ).LT.0 .OR. ierr( 2 ).LT.0 )
THEN
263 $
WRITE( nout, fmt = 9997 )
'descriptor'
272 ipz = ipa + desca( lld_ )*nq + ipostpad + iprepad
273 ipwr = ipz + descz( lld_ )*nq + ipostpad + iprepad
274 ipw = ipwr + descz( lld_ )*nq + ipostpad + iprepad
278 iii = 7*iii /
ilcm( nprow, npcol )
281 lwork = 3*n +
max( 2*
max( lda, ldz )+2*nq, iii )
282 lwork = lwork +
max( 2*n, ( 8*
ilcm( nprow, npcol )+2 )**
290 worksiz = lwork +
max( np*desca( nb_ ),
291 $ desca( mb_ )*nq ) + ipostpad
295 worksiz = lwork + ipostpad
302 IF( ipw+worksiz.GT.memsiz )
THEN
304 $
WRITE( nout, fmt = 9996 )
'Schur reduction',
305 $ ( ipw+worksiz )*zplxsz
311 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
313 IF( ierr( 1 ).GT.0 )
THEN
315 $
WRITE( nout, fmt = 9997 )
'MEMORY'
322 CALL pzlaset(
'All', n, n, zero, one, mem( ipz ), 1, 1,
327 CALL pzmatgen( ictxt,
'No transpose',
'No transpose',
328 $ desca( m_ ), desca( n_ ), desca( mb_ ),
329 $ desca( nb_ ), mem( ipa ), desca( lld_ ),
330 $ desca( rsrc_ ), desca( csrc_ ), iaseed, 0,
331 $ np, 0, nq, myrow, mycol, nprow, npcol )
333 $ zero, zero, mem( ipa ),
min( n, 3 ), 1,
339 CALL pzfillpad( ictxt, np, nq, mem( ipa-iprepad ),
340 $ desca( lld_ ), iprepad, ipostpad,
342 CALL pzfillpad( ictxt, np, nq, mem( ipz-iprepad ),
343 $ descz( lld_ ), iprepad, ipostpad,
345 CALL pzfillpad( ictxt, worksiz-ipostpad, 1,
346 $ mem( ipw-iprepad ), worksiz-ipostpad,
347 $ iprepad, ipostpad, padval )
348 anorm =
pzlanhs(
'I', n, mem( ipa ), 1, 1, desca,
350 CALL pzchekpad( ictxt,
'PZLANHS', np, nq,
351 $ mem( ipa-iprepad ), desca( lld_ ),
352 $ iprepad, ipostpad, padval )
353 CALL pzchekpad( ictxt,
'PZLANHS', worksiz-ipostpad, 1,
354 $ mem( ipw-iprepad ), worksiz-ipostpad,
355 $ iprepad, ipostpad, padval )
357 CALL pzfillpad( ictxt, n, 1, mem( ipwr-iprepad ), n,
358 $ iprepad, ipostpad, padval )
359 CALL pzfillpad( ictxt, lwork, 1, mem( ipw-iprepad ),
360 $ lwork, iprepad, ipostpad, padval )
365 CALL blacs_barrier( ictxt,
'All' )
370 CALL pzlahqr( .true., .true., n, 1, n, mem( ipa ), desca,
371 $ mem( ipwr ), 1, n, mem( ipz ), descz,
372 $ mem( ipw ), lwork, idum, 0, info )
378 $
WRITE( nout, fmt = * )
'PZLAHQR INFO=', info
387 CALL pzchekpad( ictxt,
'PZLAHQR (A)', np, nq,
388 $ mem( ipa-iprepad ), desca( lld_ ),
389 $ iprepad, ipostpad, padval )
390 CALL pzchekpad( ictxt,
'PZLAHQR (Z)', np, nq,
391 $ mem( ipz-iprepad ), descz( lld_ ),
392 $ iprepad, ipostpad, padval )
393 CALL pzchekpad( ictxt,
'PZLAHQR (WR)', n, 1,
394 $ mem( ipwr-iprepad ), n, iprepad,
396 CALL pzchekpad( ictxt,
'PZLAHQR (WORK)', lwork, 1,
397 $ mem( ipw-iprepad ), lwork, iprepad,
400 CALL pzfillpad( ictxt, worksiz-ipostpad, 1,
401 $ mem( ipw-iprepad ), worksiz-ipostpad,
402 $ iprepad, ipostpad, padval )
406 CALL pznepfchk( n, mem( ipa ), 1, 1, desca, iaseed,
407 $ mem( ipz ), 1, 1, descz, anorm,
408 $ fresid, mem( ipw ) )
410 CALL pzchekpad( ictxt,
'PZNEPFCHK (A)', np, nq,
411 $ mem( ipa-iprepad ), desca( lld_ ),
412 $ iprepad, ipostpad, padval )
413 CALL pzchekpad( ictxt,
'PZNEPFCHK (Z)', np, nq,
414 $ mem( ipz-iprepad ), descz( lld_ ),
415 $ iprepad, ipostpad, padval )
416 CALL pzchekpad( ictxt,
'PZNEPFCHK (WORK)',
417 $ worksiz-ipostpad, 1,
418 $ mem( ipw-iprepad ), worksiz-ipostpad,
419 $ iprepad, ipostpad, padval )
423 CALL pzlaset(
'All', n, n, zero, one, mem( ipa ), 1,
425 CALL pzgemm(
'Cong Tran',
'No transpose', n, n, n,
426 $ -one, mem( ipz ), 1, 1, descz,
427 $ mem( ipz ), 1, 1, descz, one, mem( ipa ),
429 znorm =
pzlange(
'1', n, n, mem( ipa ), 1, 1, desca,
431 qresid = znorm / ( dble( n )*
pdlamch( ictxt,
'P' ) )
435 IF( ( fresid.LE.thresh ) .AND.
436 $ ( ( fresid-fresid ).EQ.0.0d+0 ) .AND.
437 $ ( qresid.LE.thresh ) .AND.
438 $ ( ( qresid-qresid ).EQ.0.0d+0 ) )
THEN
445 WRITE( nout, fmt = 9986 )fresid
446 WRITE( nout, fmt = 9985 )qresid
455 fresid = fresid - fresid
456 qresid = qresid - qresid
463 CALL slcombine( ictxt,
'All',
'>',
'W', 1, 1, wtime )
464 CALL slcombine( ictxt,
'All',
'>',
'C', 1, 1, ctime )
468 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
THEN
472 nops = 18.0d+0*dble( n )**3
479 IF( wtime( 1 ).GT.0.0d+0 )
THEN
480 tmflops = nops / ( wtime( 1 )*1.0d+6 )
484 IF( wtime( 1 ).GE.0.0d+0 )
485 $
WRITE( nout, fmt = 9993 )
'WALL', n, nb, nprow,
486 $ npcol, wtime( 1 ), tmflops, passed
490 IF( ctime( 1 ).GT.0.0d+0 )
THEN
491 tmflops = nops / ( ctime( 1 )*1.0d+6 )
496 IF( ctime( 1 ).GE.0.0d+0 )
497 $
WRITE( nout, fmt = 9993 )
'CPU ', n, nb, nprow,
498 $ npcol, ctime( 1 ), tmflops, passed
505 CALL blacs_gridexit( ictxt )
512 ktests = kpass + kfail + kskip
513 WRITE( nout, fmt = * )
514 WRITE( nout, fmt = 9992 )ktests
516 WRITE( nout, fmt = 9991 )kpass
517 WRITE( nout, fmt = 9989 )kfail
519 WRITE( nout, fmt = 9990 )kpass
521 WRITE( nout, fmt = 9988 )kskip
522 WRITE( nout, fmt = * )
523 WRITE( nout, fmt = * )
524 WRITE( nout, fmt = 9987 )
525 IF( nout.NE.6 .AND. nout.NE.0 )
531 9999
FORMAT(
'ILLEGAL ', a6,
': ', a5,
' = ', i3,
532 $
'; It should be at least 1' )
533 9998
FORMAT(
'ILLEGAL GRID: nprow*npcol = ', i4,
'. It can be at most',
535 9997
FORMAT(
'Bad ', a6,
' parameters: going on to next test case.' )
536 9996
FORMAT(
'Unable to perform ', a,
': need TOTMEM of at least',
538 9995
FORMAT(
'TIME N NB P Q NEP Time MFLOPS CHECK' )
539 9994
FORMAT(
'---- ----- --- ---- ---- -------- -------- ------' )
540 9993
FORMAT( a4, 1x, i5, 1x, i3, 1x, i4, 1x, i4, 1x, f8.2, 1x, f8.2,
542 9992
FORMAT(
'Finished ', i6,
' tests, with the following results:' )
543 9991
FORMAT( i5,
' tests completed and passed residual checks.' )
544 9990
FORMAT( i5,
' tests completed without checking.' )
545 9989
FORMAT( i5,
' tests completed and failed residual checks.' )
546 9988
FORMAT( i5,
' tests skipped because of illegal input values.' )
547 9987
FORMAT(
'END OF TESTS.' )
548 9986
FORMAT(
'||H - Q*S*Q^T|| / (||H|| * N * eps) = ', g25.7 )
549 9985
FORMAT(
'||Q^T*Q - I|| / ( N * eps ) ', g25.7 )
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 ilcm(m, n)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
double precision function pdlamch(ictxt, cmach)
subroutine pzlaset(uplo, m, n, alpha, beta, a, ia, ja, desca)
subroutine pzchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pzfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
subroutine pzlahqr(wantt, wantz, n, ilo, ihi, a, desca, w, iloz, ihiz, z, descz, work, lwork, iwork, ilwork, info)
double precision function pzlange(norm, m, n, a, ia, ja, desca, work)
double precision function pzlanhs(norm, n, a, ia, ja, desca, work)
subroutine pznepfchk(n, a, ia, ja, desca, iaseed, z, iz, jz, descz, anorm, fresid, work)
subroutine pznepinfo(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)