62 INTEGER block_cyclic_2d, csrc_, ctxt_, dlen_, dtype_,
63 $ lld_, mb_, m_, nb_, n_, rsrc_
64 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
65 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
66 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
67 INTEGER memsiz, ntests, totmem, zplxsz, dblesz
69 parameter( totmem = 2000000, zplxsz = 16, dblesz = 8,
70 $ memsiz = totmem / zplxsz, ntests = 20,
71 $ padval = ( -9923.0d+0, -9923.0d+0 ) )
77 INTEGER i, iam, iaseed, ictxt, imidpad, info, ipa, ipd,
78 $ ipe, ipostpad, iprepad, iptp, iptq, ipw, j, k,
79 $ kfail, kpass, kskip, ktests, lwork, m, maxmn,
80 $ minmn, mnp, mnq, mp, mycol, myrow, n, nb,
81 $ ndiag, ngrids, nmat, nnb, noffd, nout, npcol,
82 $ nprocs, nprow, nq, workbrd, worksiz
84 DOUBLE PRECISION anorm, fresid, nops, tmflops
87 INTEGER desca( dlen_ ), ierr( 1 ), nbval( ntests ),
88 $ mval( ntests ), nval( ntests ),
89 $ pval( ntests ), qval( ntests )
90 DOUBLE PRECISION ctime( 1 ), wtime( 1 )
91 COMPLEX*16 mem( memsiz )
94 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
95 $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
110 DATA ktests, kpass, kfail, kskip / 4*0 /
116 CALL blacs_pinfo( iam, nprocs )
118 CALL pzbrdinfo( outfile, nout, nmat, mval, ntests, nval, ntests,
119 $ nnb, nbval, ntests, ngrids, pval, ntests, qval,
120 $ ntests, thresh, mem, iam, nprocs )
121 check = ( thresh.GE.0.0e+0 )
126 WRITE( nout, fmt = * )
127 WRITE( nout, fmt = 9995 )
128 WRITE( nout, fmt = 9994 )
129 WRITE( nout, fmt = * )
142 IF( nprow.LT.1 )
THEN
144 $
WRITE( nout, fmt = 9999 )
'GRID',
'nprow', nprow
146 ELSE IF( npcol.LT.1 )
THEN
148 $
WRITE( nout, fmt = 9999 )
'GRID',
'npcol', npcol
150 ELSE IF( nprow*npcol.GT.nprocs )
THEN
152 $
WRITE( nout, fmt = 9998 ) nprow*npcol, nprocs
156 IF( ierr( 1 ).GT.0 )
THEN
158 $
WRITE( nout, fmt = 9997 )
'grid'
165 CALL blacs_get( -1, 0, ictxt )
166 CALL blacs_gridinit( ictxt,
'Row-major', nprow, npcol )
167 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
169 IF( myrow.GE.nprow .OR. mycol.GE.npcol )
184 $
WRITE( nout, fmt = 9999 )
'MATRIX',
'M', m
186 ELSE IF( n.LT.1 )
THEN
188 $
WRITE( nout, fmt = 9999 )
'MATRIX',
'N', n
194 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
196 IF( ierr( 1 ).GT.0 )
THEN
198 $
WRITE( nout, fmt = 9997 )
'matrix'
215 $
WRITE( nout, fmt = 9999 )
'NB',
'NB', nb
220 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
222 IF( ierr( 1 ).GT.0 )
THEN
224 $
WRITE( nout, fmt = 9997 )
'NB'
231 mp =
numroc( m, nb, myrow, 0, nprow )
232 nq =
numroc( n, nb, mycol, 0, npcol )
233 mnp =
numroc(
min( m, n ), nb, myrow, 0, nprow )
234 mnq =
numroc(
min( m, n ), nb, mycol, 0, npcol )
236 iprepad =
max( nb, mp )
238 ipostpad =
max( nb, nq )
247 CALL descinit( desca, m, n, nb, nb, 0, 0, ictxt,
248 $
max( 1, mp )+imidpad, ierr( 1 ) )
250 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
252 IF( ierr( 1 ).LT.0 )
THEN
254 $
WRITE( nout, fmt = 9997 )
'descriptor'
265 ndiag =
iceil( dblesz*ndiag, zplxsz )
266 noffd =
iceil( dblesz*noffd, zplxsz )
269 noffd =
numroc(
min( m, n )-1, nb, mycol, 0, npcol )
270 ndiag =
iceil( dblesz*ndiag, zplxsz )
271 noffd =
iceil( dblesz*noffd, zplxsz )
275 ipd = ipa + desca( lld_ )*nq + ipostpad + iprepad
276 ipe = ipd + ndiag + ipostpad + iprepad
277 iptq = ipe + noffd + ipostpad + iprepad
278 iptp = iptq + mnq + ipostpad + iprepad
279 ipw = iptp + mnp + ipostpad + iprepad
284 lwork = nb*( mp+nq+1 ) + nq
285 workbrd = lwork + ipostpad
291 worksiz =
max( lwork, 2*nb*( mp+nq+nb ) ) + ipostpad
297 IF( ipw+worksiz.GT.memsiz )
THEN
299 $
WRITE( nout, fmt = 9996 )
'Bidiagonal reduction',
300 $ ( ipw+worksiz )*zplxsz
306 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
308 IF( ierr( 1 ).GT.0 )
THEN
310 $
WRITE( nout, fmt = 9997 )
'MEMORY'
317 CALL pzmatgen( ictxt,
'No',
'No', desca( m_ ),
318 $ desca( n_ ), desca( mb_ ), desca( nb_ ),
319 $ mem( ipa ), desca( lld_ ), desca( rsrc_ ),
320 $ desca( csrc_ ), iaseed, 0, mp, 0, nq,
321 $ myrow, mycol, nprow, npcol )
326 CALL pzfillpad( ictxt, mp, nq, mem( ipa-iprepad ),
327 $ desca( lld_ ), iprepad, ipostpad,
329 CALL pzfillpad( ictxt, ndiag, 1, mem( ipd-iprepad ),
330 $ ndiag, iprepad, ipostpad, padval )
331 CALL pzfillpad( ictxt, noffd, 1, mem( ipe-iprepad ),
332 $ noffd, iprepad, ipostpad, padval )
333 CALL pzfillpad( ictxt, mnq, 1, mem( iptq-iprepad ),
334 $ mnq, iprepad, ipostpad, padval )
335 CALL pzfillpad( ictxt, mnp, 1, mem( iptp-iprepad ),
336 $ mnp, iprepad, ipostpad, padval )
337 CALL pzfillpad( ictxt, worksiz-ipostpad, 1,
338 $ mem( ipw-iprepad ), worksiz-ipostpad,
339 $ iprepad, ipostpad, padval )
340 anorm =
pzlange(
'I', m, n, mem( ipa ), 1, 1, desca,
342 CALL pzchekpad( ictxt,
'PZLANGE', mp, nq,
343 $ mem( ipa-iprepad ), desca( lld_ ),
344 $ iprepad, ipostpad, padval )
345 CALL pzchekpad( ictxt,
'PZLANGE', worksiz-ipostpad,
346 $ 1, mem( ipw-iprepad ),
347 $ worksiz-ipostpad, iprepad, ipostpad,
349 CALL pzfillpad( ictxt, workbrd-ipostpad, 1,
350 $ mem( ipw-iprepad ), workbrd-ipostpad,
351 $ iprepad, ipostpad, padval )
355 CALL blacs_barrier( ictxt,
'All' )
360 CALL pzgebrd( m, n, mem( ipa ), 1, 1, desca, mem( ipd ),
361 $ mem( ipe ), mem( iptq ), mem( iptp ),
362 $ mem( ipw ), lwork, info )
370 CALL pzchekpad( ictxt,
'PZGEBRD', mp, nq,
371 $ mem( ipa-iprepad ), desca( lld_ ),
372 $ iprepad, ipostpad, padval )
373 CALL pzchekpad( ictxt,
'PZGEBRD', ndiag, 1,
374 $ mem( ipd-iprepad ), ndiag, iprepad,
376 CALL pzchekpad( ictxt,
'PZGEBRD', noffd, 1,
377 $ mem( ipe-iprepad ), noffd, iprepad,
379 CALL pzchekpad( ictxt,
'PZGEBRD', mnq, 1,
380 $ mem( iptq-iprepad ), mnq, iprepad,
382 CALL pzchekpad( ictxt,
'PZGEBRD', mnp, 1,
383 $ mem( iptp-iprepad ), mnp, iprepad,
385 CALL pzchekpad( ictxt,
'PZGEBRD', workbrd-ipostpad,
386 $ 1, mem( ipw-iprepad ),
387 $ workbrd-ipostpad, iprepad,
389 CALL pzfillpad( ictxt, worksiz-ipostpad, 1,
390 $ mem( ipw-iprepad ), worksiz-ipostpad,
391 $ iprepad, ipostpad, padval )
395 CALL pzgebdrv( m, n, mem( ipa ), 1, 1, desca,
396 $ mem( ipd ), mem( ipe ), mem( iptq ),
397 $ mem( iptp ), mem( ipw ), ierr( 1 ) )
398 CALL pzlafchk(
'No',
'No', m, n, mem( ipa ), 1, 1,
399 $ desca, iaseed, anorm, fresid,
404 CALL pzchekpad( ictxt,
'PZGEBDRV', mp, nq,
405 $ mem( ipa-iprepad ), desca( lld_ ),
406 $ iprepad, ipostpad, padval )
407 CALL pzchekpad( ictxt,
'PZGEBDRV', ndiag, 1,
408 $ mem( ipd-iprepad ), ndiag, iprepad,
410 CALL pzchekpad( ictxt,
'PZGEBDRV', noffd, 1,
411 $ mem( ipe-iprepad ), noffd, iprepad,
413 CALL pzchekpad( ictxt,
'PZGEBDRV', worksiz-ipostpad,
414 $ 1, mem( ipw-iprepad ),
415 $ worksiz-ipostpad, iprepad,
420 IF( fresid.LE.thresh .AND. fresid-fresid.EQ.0.0d+0
421 $ .AND. ierr( 1 ).EQ.0 )
THEN
425 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
426 $
WRITE( nout, fmt = 9986 ) fresid
432 IF( myrow.EQ.0 .AND. mycol.EQ.0 .AND. ierr( 1 ).NE.0 )
433 $
WRITE( nout, fmt = * )
434 $
'D or E copies incorrect ...'
440 fresid = fresid - fresid
447 CALL slcombine( ictxt,
'All',
'>',
'W', 1, 1, wtime )
448 CALL slcombine( ictxt,
'All',
'>',
'C', 1, 1, ctime )
452 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
THEN
458 nops = 16.0d+0 * dble( minmn ) * dble( minmn ) *
459 $ ( dble( maxmn ) - dble( minmn ) / 3.0d+0 )
464 IF( wtime( 1 ).GT.0.0d+0 )
THEN
465 tmflops = nops / wtime( 1 )
469 IF( wtime( 1 ).GE.0.0d+0 )
470 $
WRITE( nout, fmt = 9993 )
'WALL', m, n, nb, nprow,
471 $ npcol, wtime( 1 ), tmflops, fresid, passed
475 IF( ctime( 1 ).GT.0.0d+0 )
THEN
476 tmflops = nops / ctime( 1 )
480 IF( ctime( 1 ).GE.0.0d+0 )
481 $
WRITE( nout, fmt = 9993 )
'CPU ', m, n, nb, nprow,
482 $ npcol, ctime( 1 ), tmflops, fresid, passed
487 CALL blacs_gridexit( ictxt )
493 ktests = kpass + kfail + kskip
494 WRITE( nout, fmt = * )
495 WRITE( nout, fmt = 9992 ) ktests
497 WRITE( nout, fmt = 9991 ) kpass
498 WRITE( nout, fmt = 9989 ) kfail
500 WRITE( nout, fmt = 9990 ) kpass
502 WRITE( nout, fmt = 9988 ) kskip
503 WRITE( nout, fmt = * )
504 WRITE( nout, fmt = * )
505 WRITE( nout, fmt = 9987 )
506 IF( nout.NE.6 .AND. nout.NE.0 )
CLOSE ( nout )
511 9999
FORMAT(
'ILLEGAL ', a6,
': ', a5,
' = ', i3,
512 $
'; It should be at least 1' )
513 9998
FORMAT(
'ILLEGAL GRID: nprow*npcol = ', i4,
'. It can be at most',
515 9997
FORMAT(
'Bad ', a6,
' parameters: going on to next test case.' )
516 9996
FORMAT(
'Unable to perform ', a,
': need TOTMEM of at least',
518 9995
FORMAT(
'TIME M N NB P Q BRD Time ',
519 $
' MFLOPS Residual CHECK' )
520 9994
FORMAT(
'---- ------ ------ --- ----- ----- --------- ',
521 $
'----------- -------- ------' )
522 9993
FORMAT( a4, 1x, i6, 1x, i6, 1x, i3, 1x, i5, 1x, i5, 1x, f9.2, 1x,
523 $ f11.2, 1x, f8.2, 1x, a6 )
524 9992
FORMAT(
'Finished', i4,
' tests, with the following results:' )
525 9991
FORMAT( i5,
' tests completed and passed residual checks.' )
526 9990
FORMAT( i5,
' tests completed without checking.' )
527 9989
FORMAT( i5,
' tests completed and failed residual checks.' )
528 9988
FORMAT( i5,
' tests skipped because of illegal input values.' )
529 9987
FORMAT(
'END OF TESTS.' )
530 9986
FORMAT(
'||A - Q*B*P|| / (||A|| * N * eps) = ', g25.7 )
subroutine pzlafchk(aform, diag, m, n, a, ia, ja, desca, iaseed, anorm, fresid, work)
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 iceil(inum, idenom)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
subroutine pzbrdinfo(summry, nout, nmat, mval, ldmval, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
subroutine pzchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pzfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
subroutine pzgebdrv(m, n, a, ia, ja, desca, d, e, tauq, taup, work, info)
subroutine pzgebrd(m, n, a, ia, ja, desca, d, e, tauq, taup, work, lwork, info)
double precision function pzlange(norm, m, n, a, ia, ja, desca, work)
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)