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 )