61 INTEGER block_cyclic_2d, csrc_, ctxt_, dlen_, dtype_,
62 $ lld_, mb_, m_, nb_, n_, rsrc_
63 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
64 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
65 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
66 INTEGER dblesz, memsiz, ntests, totmem
67 DOUBLE PRECISION padval
68 parameter( dblesz = 8, totmem = 2000000,
69 $ memsiz = totmem / dblesz, ntests = 20,
70 $ padval = -9923.0d+0 )
76 INTEGER i, iam, iaseed, ictxt, imidpad, info, ipa, ipd,
77 $ ipe, ipostpad, iprepad, iptp, iptq, ipw, j, k,
78 $ kfail, kpass, kskip, ktests, lwork, m, maxmn,
79 $ minmn, mnp, mnq, mp, mycol, myrow, n, nb,
80 $ ndiag, ngrids, nmat, nnb, noffd, nout, npcol,
81 $ nprocs, nprow, nq, workbrd, worksiz
83 DOUBLE PRECISION anorm, fresid, nops, tmflops
86 INTEGER desca( dlen_ ), ierr( 1 ), nbval( ntests ),
87 $ mval( ntests ), nval( ntests ),
88 $ pval( ntests ), qval( ntests )
89 DOUBLE PRECISION ctime( 1 ), mem( memsiz ), wtime( 1 )
92 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
93 $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
108 DATA ktests, kpass, kfail, kskip / 4*0 /
114 CALL blacs_pinfo( iam, nprocs )
116 CALL pdbrdinfo( outfile, nout, nmat, mval, ntests, nval, ntests,
117 $ nnb, nbval, ntests, ngrids, pval, ntests, qval,
118 $ ntests, thresh, mem, iam, nprocs )
119 check = ( thresh.GE.0.0e+0 )
124 WRITE( nout, fmt = * )
125 WRITE( nout, fmt = 9995 )
126 WRITE( nout, fmt = 9994 )
127 WRITE( nout, fmt = * )
140 IF( nprow.LT.1 )
THEN
142 $
WRITE( nout, fmt = 9999 )
'GRID',
'nprow', nprow
144 ELSE IF( npcol.LT.1 )
THEN
146 $
WRITE( nout, fmt = 9999 )
'GRID',
'npcol', npcol
148 ELSE IF( nprow*npcol.GT.nprocs )
THEN
150 $
WRITE( nout, fmt = 9998 ) nprow*npcol, nprocs
154 IF( ierr( 1 ).GT.0 )
THEN
156 $
WRITE( nout, fmt = 9997 )
'grid'
163 CALL blacs_get( -1, 0, ictxt )
164 CALL blacs_gridinit( ictxt,
'Row-major', nprow, npcol )
165 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
167 IF( myrow.GE.nprow .OR. mycol.GE.npcol )
182 $
WRITE( nout, fmt = 9999 )
'MATRIX',
'M', m
184 ELSE IF( n.LT.1 )
THEN
186 $
WRITE( nout, fmt = 9999 )
'MATRIX',
'N', n
192 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
194 IF( ierr( 1 ).GT.0 )
THEN
196 $
WRITE( nout, fmt = 9997 )
'matrix'
213 $
WRITE( nout, fmt = 9999 )
'NB',
'NB', nb
218 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
220 IF( ierr( 1 ).GT.0 )
THEN
222 $
WRITE( nout, fmt = 9997 )
'NB'
229 mp =
numroc( m, nb, myrow, 0, nprow )
230 nq =
numroc( n, nb, mycol, 0, npcol )
231 mnp =
numroc(
min( m, n ), nb, myrow, 0, nprow )
232 mnq =
numroc(
min( m, n ), nb, mycol, 0, npcol )
234 iprepad =
max( nb, mp )
236 ipostpad =
max( nb, nq )
245 CALL descinit( desca, m, n, nb, nb, 0, 0, ictxt,
246 $
max( 1, mp )+imidpad, ierr( 1 ) )
248 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
250 IF( ierr( 1 ).LT.0 )
THEN
252 $
WRITE( nout, fmt = 9997 )
'descriptor'
265 noffd =
numroc(
min( m, n )-1, nb, mycol, 0, npcol )
269 ipd = ipa + desca( lld_ )*nq + ipostpad + iprepad
270 ipe = ipd + ndiag + ipostpad + iprepad
271 iptq = ipe + noffd + ipostpad + iprepad
272 iptp = iptq + mnq + ipostpad + iprepad
273 ipw = iptp + mnp + ipostpad + iprepad
278 lwork = nb*( mp+nq+1 ) + nq
279 workbrd = lwork + ipostpad
285 worksiz =
max( lwork, 2*nb*( mp+nq+nb ) ) + ipostpad
291 IF( ipw+worksiz.GT.memsiz )
THEN
293 $
WRITE( nout, fmt = 9996 )
'Bidiagonal reduction',
294 $ ( ipw+worksiz )*dblesz
300 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
302 IF( ierr( 1 ).GT.0 )
THEN
304 $
WRITE( nout, fmt = 9997 )
'MEMORY'
311 CALL pdmatgen( ictxt,
'No',
'No', desca( m_ ),
312 $ desca( n_ ), desca( mb_ ), desca( nb_ ),
313 $ mem( ipa ), desca( lld_ ), desca( rsrc_ ),
314 $ desca( csrc_ ), iaseed, 0, mp, 0, nq,
315 $ myrow, mycol, nprow, npcol )
320 CALL pdfillpad( ictxt, mp, nq, mem( ipa-iprepad ),
321 $ desca( lld_ ), iprepad, ipostpad,
323 CALL pdfillpad( ictxt, ndiag, 1, mem( ipd-iprepad ),
324 $ ndiag, iprepad, ipostpad, padval )
325 CALL pdfillpad( ictxt, noffd, 1, mem( ipe-iprepad ),
326 $ noffd, iprepad, ipostpad, padval )
327 CALL pdfillpad( ictxt, mnq, 1, mem( iptq-iprepad ),
328 $ mnq, iprepad, ipostpad, padval )
329 CALL pdfillpad( ictxt, mnp, 1, mem( iptp-iprepad ),
330 $ mnp, iprepad, ipostpad, padval )
331 CALL pdfillpad( ictxt, worksiz-ipostpad, 1,
332 $ mem( ipw-iprepad ), worksiz-ipostpad,
333 $ iprepad, ipostpad, padval )
334 anorm =
pdlange(
'I', m, n, mem( ipa ), 1, 1, desca,
336 CALL pdchekpad( ictxt,
'PDLANGE', mp, nq,
337 $ mem( ipa-iprepad ), desca( lld_ ),
338 $ iprepad, ipostpad, padval )
339 CALL pdchekpad( ictxt,
'PDLANGE', worksiz-ipostpad,
340 $ 1, mem( ipw-iprepad ),
341 $ worksiz-ipostpad, iprepad, ipostpad,
343 CALL pdfillpad( ictxt, workbrd-ipostpad, 1,
344 $ mem( ipw-iprepad ), workbrd-ipostpad,
345 $ iprepad, ipostpad, padval )
349 CALL blacs_barrier( ictxt,
'All' )
354 CALL pdgebrd( m, n, mem( ipa ), 1, 1, desca, mem( ipd ),
355 $ mem( ipe ), mem( iptq ), mem( iptp ),
356 $ mem( ipw ), lwork, info )
364 CALL pdchekpad( ictxt,
'PDGEBRD', mp, nq,
365 $ mem( ipa-iprepad ), desca( lld_ ),
366 $ iprepad, ipostpad, padval )
367 CALL pdchekpad( ictxt,
'PDGEBRD', ndiag, 1,
368 $ mem( ipd-iprepad ), ndiag, iprepad,
370 CALL pdchekpad( ictxt,
'PDGEBRD', noffd, 1,
371 $ mem( ipe-iprepad ), noffd, iprepad,
373 CALL pdchekpad( ictxt,
'PDGEBRD', mnq, 1,
374 $ mem( iptq-iprepad ), mnq, iprepad,
376 CALL pdchekpad( ictxt,
'PDGEBRD', mnp, 1,
377 $ mem( iptp-iprepad ), mnp, iprepad,
379 CALL pdchekpad( ictxt,
'PDGEBRD', workbrd-ipostpad,
380 $ 1, mem( ipw-iprepad ),
381 $ workbrd-ipostpad, iprepad,
383 CALL pdfillpad( ictxt, worksiz-ipostpad, 1,
384 $ mem( ipw-iprepad ), worksiz-ipostpad,
385 $ iprepad, ipostpad, padval )
389 CALL pdgebdrv( m, n, mem( ipa ), 1, 1, desca,
390 $ mem( ipd ), mem( ipe ), mem( iptq ),
391 $ mem( iptp ), mem( ipw ), ierr( 1 ) )
392 CALL pdlafchk(
'No',
'No', m, n, mem( ipa ), 1, 1,
393 $ desca, iaseed, anorm, fresid,
398 CALL pdchekpad( ictxt,
'PDGEBDRV', mp, nq,
399 $ mem( ipa-iprepad ), desca( lld_ ),
400 $ iprepad, ipostpad, padval )
401 CALL pdchekpad( ictxt,
'PDGEBDRV', ndiag, 1,
402 $ mem( ipd-iprepad ), ndiag, iprepad,
404 CALL pdchekpad( ictxt,
'PDGEBDRV', noffd, 1,
405 $ mem( ipe-iprepad ), noffd, iprepad,
407 CALL pdchekpad( ictxt,
'PDGEBDRV', worksiz-ipostpad,
408 $ 1, mem( ipw-iprepad ),
409 $ worksiz-ipostpad, iprepad,
414 IF( fresid.LE.thresh .AND. fresid-fresid.EQ.0.0d+0
415 $ .AND. ierr( 1 ).EQ.0 )
THEN
419 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
420 $
WRITE( nout, fmt = 9986 ) fresid
426 IF( myrow.EQ.0 .AND. mycol.EQ.0 .AND. ierr( 1 ).NE.0 )
427 $
WRITE( nout, fmt = * )
428 $
'D or E copies incorrect ...'
434 fresid = fresid - fresid
441 CALL slcombine( ictxt,
'All',
'>',
'W', 1, 1, wtime )
442 CALL slcombine( ictxt,
'All',
'>',
'C', 1, 1, ctime )
446 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
THEN
452 nops = 4.0d+0 * dble( minmn ) * dble( minmn ) *
453 $ ( dble( maxmn ) - dble( minmn ) / 3.0d+0 )
458 IF( wtime( 1 ).GT.0.0d+0 )
THEN
459 tmflops = nops / wtime( 1 )
463 IF( wtime( 1 ).GE.0.0d+0 )
464 $
WRITE( nout, fmt = 9993 )
'WALL', m, n, nb, nprow,
465 $ npcol, wtime( 1 ), tmflops, fresid, passed
469 IF( ctime( 1 ).GT.0.0d+0 )
THEN
470 tmflops = nops / ctime( 1 )
474 IF( ctime( 1 ).GE.0.0d+0 )
475 $
WRITE( nout, fmt = 9993 )
'CPU ', m, n, nb, nprow,
476 $ npcol, ctime( 1 ), tmflops, fresid, passed
481 CALL blacs_gridexit( ictxt )
487 ktests = kpass + kfail + kskip
488 WRITE( nout, fmt = * )
489 WRITE( nout, fmt = 9992 ) ktests
491 WRITE( nout, fmt = 9991 ) kpass
492 WRITE( nout, fmt = 9989 ) kfail
494 WRITE( nout, fmt = 9990 ) kpass
496 WRITE( nout, fmt = 9988 ) kskip
497 WRITE( nout, fmt = * )
498 WRITE( nout, fmt = * )
499 WRITE( nout, fmt = 9987 )
500 IF( nout.NE.6 .AND. nout.NE.0 )
CLOSE ( nout )
505 9999
FORMAT(
'ILLEGAL ', a6,
': ', a5,
' = ', i3,
506 $
'; It should be at least 1' )
507 9998
FORMAT(
'ILLEGAL GRID: nprow*npcol = ', i4,
'. It can be at most',
509 9997
FORMAT(
'Bad ', a6,
' parameters: going on to next test case.' )
510 9996
FORMAT(
'Unable to perform ', a,
': need TOTMEM of at least',
512 9995
FORMAT(
'TIME M N NB P Q BRD Time ',
513 $
' MFLOPS Residual CHECK' )
514 9994
FORMAT(
'---- ------ ------ --- ----- ----- --------- ',
515 $
'----------- -------- ------' )
516 9993
FORMAT( a4, 1x, i6, 1x, i6, 1x, i3, 1x, i5, 1x, i5, 1x, f9.2, 1x,
517 $ f11.2, 1x, f8.2, 1x, a6 )
518 9992
FORMAT(
'Finished', i4,
' tests, with the following results:' )
519 9991
FORMAT( i5,
' tests completed and passed residual checks.' )
520 9990
FORMAT( i5,
' tests completed without checking.' )
521 9989
FORMAT( i5,
' tests completed and failed residual checks.' )
522 9988
FORMAT( i5,
' tests skipped because of illegal input values.' )
523 9987
FORMAT(
'END OF TESTS.' )
524 9986
FORMAT(
'||A - Q*B*P|| / (||A|| * N * eps) = ', g25.7 )
subroutine pdlafchk(aform, diag, m, n, a, ia, ja, desca, iaseed, anorm, fresid, work)
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 iceil(inum, idenom)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
subroutine pdbrdinfo(summry, nout, nmat, mval, ldmval, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
subroutine pdchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pdfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
subroutine pdgebdrv(m, n, a, ia, ja, desca, d, e, tauq, taup, work, info)
subroutine pdgebrd(m, n, a, ia, ja, desca, d, e, tauq, taup, work, lwork, info)
double precision function pdlange(norm, m, n, a, ia, ja, desca, work)
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)