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 cplxsz, memsiz, ntests, totmem, realsz
69 parameter( cplxsz = 8, totmem = 2000000, realsz = 8,
70 $ memsiz = totmem / cplxsz, ntests = 20,
71 $ padval = ( -9923.0e+0, -9923.0e+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
83 REAL anorm, fresid, thresh
84 DOUBLE PRECISION 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 )
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 pcbrdinfo( 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( realsz*ndiag, cplxsz )
266 noffd =
iceil( realsz*noffd, cplxsz )
269 noffd =
numroc(
min( m, n )-1, nb, mycol, 0, npcol )
270 ndiag =
iceil( realsz*ndiag, cplxsz )
271 noffd =
iceil( realsz*noffd, cplxsz )
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 )*cplxsz
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 pcmatgen( 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 pcfillpad( ictxt, mp, nq, mem( ipa-iprepad ),
327 $ desca( lld_ ), iprepad, ipostpad,
329 CALL pcfillpad( ictxt, ndiag, 1, mem( ipd-iprepad ),
330 $ ndiag, iprepad, ipostpad, padval )
331 CALL pcfillpad( ictxt, noffd, 1, mem( ipe-iprepad ),
332 $ noffd, iprepad, ipostpad, padval )
333 CALL pcfillpad( ictxt, mnq, 1, mem( iptq-iprepad ),
334 $ mnq, iprepad, ipostpad, padval )
335 CALL pcfillpad( ictxt, mnp, 1, mem( iptp-iprepad ),
336 $ mnp, iprepad, ipostpad, padval )
337 CALL pcfillpad( ictxt, worksiz-ipostpad, 1,
338 $ mem( ipw-iprepad ), worksiz-ipostpad,
339 $ iprepad, ipostpad, padval )
340 anorm =
pclange(
'I', m, n, mem( ipa ), 1, 1, desca,
342 CALL pcchekpad( ictxt,
'PCLANGE', mp, nq,
343 $ mem( ipa-iprepad ), desca( lld_ ),
344 $ iprepad, ipostpad, padval )
345 CALL pcchekpad( ictxt,
'PCLANGE', worksiz-ipostpad,
346 $ 1, mem( ipw-iprepad ),
347 $ worksiz-ipostpad, iprepad, ipostpad,
349 CALL pcfillpad( ictxt, workbrd-ipostpad, 1,
350 $ mem( ipw-iprepad ), workbrd-ipostpad,
351 $ iprepad, ipostpad, padval )
355 CALL blacs_barrier( ictxt,
'All' )
360 CALL pcgebrd( m, n, mem( ipa ), 1, 1, desca, mem( ipd ),
361 $ mem( ipe ), mem( iptq ), mem( iptp ),
362 $ mem( ipw ), lwork, info )
370 CALL pcchekpad( ictxt,
'PCGEBRD', mp, nq,
371 $ mem( ipa-iprepad ), desca( lld_ ),
372 $ iprepad, ipostpad, padval )
373 CALL pcchekpad( ictxt,
'PCGEBRD', ndiag, 1,
374 $ mem( ipd-iprepad ), ndiag, iprepad,
376 CALL pcchekpad( ictxt,
'PCGEBRD', noffd, 1,
377 $ mem( ipe-iprepad ), noffd, iprepad,
379 CALL pcchekpad( ictxt,
'PCGEBRD', mnq, 1,
380 $ mem( iptq-iprepad ), mnq, iprepad,
382 CALL pcchekpad( ictxt,
'PCGEBRD', mnp, 1,
383 $ mem( iptp-iprepad ), mnp, iprepad,
385 CALL pcchekpad( ictxt,
'PCGEBRD', workbrd-ipostpad,
386 $ 1, mem( ipw-iprepad ),
387 $ workbrd-ipostpad, iprepad,
389 CALL pcfillpad( ictxt, worksiz-ipostpad, 1,
390 $ mem( ipw-iprepad ), worksiz-ipostpad,
391 $ iprepad, ipostpad, padval )
395 CALL pcgebdrv( m, n, mem( ipa ), 1, 1, desca,
396 $ mem( ipd ), mem( ipe ), mem( iptq ),
397 $ mem( iptp ), mem( ipw ), ierr( 1 ) )
398 CALL pclafchk(
'No',
'No', m, n, mem( ipa ), 1, 1,
399 $ desca, iaseed, anorm, fresid,
404 CALL pcchekpad( ictxt,
'PCGEBDRV', mp, nq,
405 $ mem( ipa-iprepad ), desca( lld_ ),
406 $ iprepad, ipostpad, padval )
407 CALL pcchekpad( ictxt,
'PCGEBDRV', ndiag, 1,
408 $ mem( ipd-iprepad ), ndiag, iprepad,
410 CALL pcchekpad( ictxt,
'PCGEBDRV', noffd, 1,
411 $ mem( ipe-iprepad ), noffd, iprepad,
413 CALL pcchekpad( ictxt,
'PCGEBDRV', worksiz-ipostpad,
414 $ 1, mem( ipw-iprepad ),
415 $ worksiz-ipostpad, iprepad,
420 IF( fresid.LE.thresh .AND. fresid-fresid.EQ.0.0e+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 pclafchk(aform, diag, m, n, a, ia, ja, desca, iaseed, anorm, fresid, work)
subroutine pcmatgen(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 pcbrdinfo(summry, nout, nmat, mval, ldmval, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
subroutine pcchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pcfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
subroutine pcgebdrv(m, n, a, ia, ja, desca, d, e, tauq, taup, work, info)
subroutine pcgebrd(m, n, a, ia, ja, desca, d, e, tauq, taup, work, lwork, info)
real function pclange(norm, m, n, a, ia, ja, desca, work)
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)