74 parameter( totmem = 3000000 )
75 INTEGER block_cyclic_2d, csrc_, ctxt_, dlen_, dtype_,
76 $ lld_, mb_, m_, nb_, n_, rsrc_
77 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
78 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
79 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
82 INTEGER dblesz, memsiz, ntests
83 DOUBLE PRECISION padval
84 parameter( dblesz = 8,
85 $ memsiz = totmem / dblesz, ntests = 20,
86 $ padval = -9923.0d+0, zero = 0.0d+0 )
88 parameter( int_one = 1 )
95 INTEGER bwl, bwu, bw_num, fillin_size, free_ptr, h, hh,
96 $ i, iam, iaseed, ibseed, ictxt, ictxtb,
97 $ ierr_temp, imidpad, info, ipa, ipb, ipostpad,
98 $ iprepad, ipw, ipw_size, ipw_solve,
99 $ ipw_solve_size, ip_driver_w, ip_fillin, j, k,
100 $ kfail, kpass, kskip, ktests, mycol, myrhs_size,
101 $ myrow, n, nb, nbw, ngrids, nmat, nnb, nnbr,
102 $ nnr, nout, np, npcol, nprocs, nprocs_real,
103 $ nprow, nq, nrhs, n_first, n_last, worksiz
105 DOUBLE PRECISION anorm, nops, nops2, sresid, tmflops,
109 INTEGER bwlval( ntests ), bwuval( ntests ), desca( 7 ),
110 $ desca2d( dlen_ ), descb( 7 ), descb2d( dlen_ ),
111 $ ierr( 1 ), nbrval( ntests ), nbval( ntests ),
112 $ nrval( ntests ), nval( ntests ),
113 $ pval( ntests ), qval( ntests )
114 DOUBLE PRECISION ctime( 2 ), mem( memsiz ), wtime( 2 )
117 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
118 $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
131 INTRINSIC dble,
max,
min, mod
134 DATA kfail, kpass, kskip, ktests / 4*0 /
143 CALL blacs_pinfo( iam, nprocs )
147 CALL pddbinfo( outfile, nout, trans, nmat, nval, ntests, nbw,
148 $ bwlval, bwuval, ntests, nnb, nbval, ntests, nnr,
149 $ nrval, ntests, nnbr, nbrval, ntests, ngrids, pval,
150 $ ntests, qval, ntests, thresh, mem, iam, nprocs )
152 check = ( thresh.GE.0.0d+0 )
157 WRITE( nout, fmt = * )
158 WRITE( nout, fmt = 9995 )
159 WRITE( nout, fmt = 9994 )
160 WRITE( nout, fmt = * )
173 IF( nprow.LT.1 )
THEN
175 $
WRITE( nout, fmt = 9999 )
'GRID',
'nprow', nprow
177 ELSE IF( npcol.LT.1 )
THEN
179 $
WRITE( nout, fmt = 9999 )
'GRID',
'npcol', npcol
181 ELSE IF( nprow*npcol.GT.nprocs )
THEN
183 $
WRITE( nout, fmt = 9998 ) nprow*npcol, nprocs
187 IF( ierr( 1 ).GT.0 )
THEN
189 $
WRITE( nout, fmt = 9997 )
'grid'
196 CALL blacs_get( -1, 0, ictxt )
197 CALL blacs_gridinit( ictxt,
'Row-major', nprow, npcol )
202 CALL blacs_get( -1, 0, ictxtb )
203 CALL blacs_gridinit( ictxtb,
'Column-major', npcol, nprow )
208 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
210 IF( myrow.LT.0 .OR. mycol.LT.0 )
THEN
224 $
WRITE( nout, fmt = 9999 )
'MATRIX',
'N', n
230 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1,
233 IF( ierr( 1 ).GT.0 )
THEN
235 $
WRITE( nout, fmt = 9997 )
'size'
241 DO 45 bw_num = 1, nbw
245 bwl = bwlval( bw_num )
248 $
WRITE( nout, fmt = 9999 )
'Lower Band',
'bwl', bwl
252 bwu = bwuval( bw_num )
255 $
WRITE( nout, fmt = 9999 )
'Upper Band',
'bwu', bwu
259 IF( bwl.GT.n-1 )
THEN
265 IF( bwu.GT.n-1 )
THEN
273 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1,
276 IF( ierr( 1 ).GT.0 )
THEN
287 nb =( (n-(npcol-1)*
max(bwl,bwu)-1)/npcol + 1 )
289 nb =
max( nb, 2*
max(bwl,bwu) )
296 IF( nb.LT.
min( 2*
max(bwl,bwu), n ) )
THEN
302 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1,
305 IF( ierr( 1 ).GT.0 )
THEN
312 np =
numroc( (bwl+bwu+1), (bwl+bwu+1),
314 nq =
numroc( n, nb, mycol, 0, npcol )
317 iprepad = ((bwl+bwu+1)+10)
319 ipostpad = ((bwl+bwu+1)+10)
328 CALL descinit( desca2d, (bwl+bwu+1), n,
329 $ (bwl+bwu+1), nb, 0, 0,
330 $ ictxt,((bwl+bwu+1)+10), ierr( 1 ) )
339 desca( 6 ) = ((bwl+bwu+1)+10)
342 ierr_temp = ierr( 1 )
344 ierr( 1 ) =
min( ierr( 1 ), ierr_temp )
348 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr, 1, -1, 0 )
350 IF( ierr( 1 ).LT.0 )
THEN
352 $
WRITE( nout, fmt = 9997 )
'descriptor'
364 free_ptr = free_ptr + iprepad
367 free_ptr = free_ptr + desca2d( lld_ )*
380 $ nb*(bwl+bwu)+6*
max(bwl,bwu)*
max(bwl,bwu)
384 free_ptr = free_ptr + iprepad
386 free_ptr = free_ptr + fillin_size
394 ipw_size =
max(bwl,bwu)*
max(bwl,bwu)
399 free_ptr = free_ptr + ipw_size
404 IF( free_ptr.GT.memsiz )
THEN
406 $
WRITE( nout, fmt = 9996 )
407 $
'divide and conquer factorization',
414 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr,
417 IF( ierr( 1 ).GT.0 )
THEN
419 $
WRITE( nout, fmt = 9997 )
'MEMORY'
425 worksiz =
max( ((bwl+bwu+1)+10), nb )
433 worksiz =
max( worksiz, desca2d( nb_ ) )
436 worksiz =
max( worksiz,
440 free_ptr = free_ptr + iprepad
441 ip_driver_w = free_ptr
442 free_ptr = free_ptr + worksiz + ipostpad
448 IF( free_ptr.GT.memsiz )
THEN
450 $
WRITE( nout, fmt = 9996 )
'factorization',
451 $ ( free_ptr )*dblesz
457 CALL igsum2d( ictxt,
'All',
' ', 1, 1, ierr,
460 IF( ierr( 1 ).GT.0 )
THEN
462 $
WRITE( nout, fmt = 9997 )
'MEMORY'
467 CALL pdbmatgen( ictxt,
'G',
'D', bwl, bwu, n,
468 $ (bwl+bwu+1), nb, mem( ipa ),
469 $ ((bwl+bwu+1)+10), 0, 0, iaseed, myrow,
470 $ mycol, nprow, npcol )
472 CALL pdfillpad( ictxt, np, nq, mem( ipa-iprepad ),
473 $ ((bwl+bwu+1)+10), iprepad, ipostpad,
477 $ mem( ip_driver_w-iprepad ), worksiz,
478 $ iprepad, ipostpad, padval )
484 anorm =
pdlange(
'1', (bwl+bwu+1),
485 $ n, mem( ipa ), 1, 1,
486 $ desca2d, mem( ip_driver_w ) )
487 CALL pdchekpad( ictxt,
'PDLANGE', np, nq,
488 $ mem( ipa-iprepad ), ((bwl+bwu+1)+10),
489 $ iprepad, ipostpad, padval )
492 $ mem( ip_driver_w-iprepad ), worksiz,
493 $ iprepad, ipostpad, padval )
498 CALL blacs_barrier( ictxt,
'All' )
504 CALL pddbtrf( n, bwl, bwu, mem( ipa ), 1, desca,
505 $ mem( ip_fillin ), fillin_size, mem( ipw ),
512 WRITE( nout, fmt = * )
'PDDBTRF INFO=', info
523 $ nq, mem( ipa-iprepad ), ((bwl+bwu+1)+10),
524 $ iprepad, ipostpad, padval )
538 CALL descinit( descb2d, n, nrhs, nb, 1, 0, 0,
539 $ ictxtb, nb+10, ierr( 1 ) )
548 descb( 6 ) = descb2d( lld_ )
553 IF( ipb .GT. 0 )
THEN
557 free_ptr = free_ptr + iprepad
559 free_ptr = free_ptr + nrhs*descb2d( lld_ )
564 ipw_solve_size = (
max(bwl,bwu)*nrhs)
567 free_ptr = free_ptr + ipw_solve_size
570 IF( free_ptr.GT.memsiz )
THEN
572 $
WRITE( nout, fmt = 9996 )
'solve',
573 $ ( free_ptr )*dblesz
579 CALL igsum2d( ictxt,
'All',
' ', 1, 1,
582 IF( ierr( 1 ).GT.0 )
THEN
584 $
WRITE( nout, fmt = 9997 )
'MEMORY'
589 myrhs_size =
numroc( n, nb, mycol, 0, npcol )
594 $ descb2d( m_ ), descb2d( n_ ),
595 $ descb2d( mb_ ), descb2d( nb_ ),
597 $ descb2d( lld_ ), descb2d( rsrc_ ),
599 $ ibseed, 0, myrhs_size, 0, nrhs, mycol,
600 $ myrow, npcol, nprow )
604 $ mem( ipb-iprepad ),
609 $ mem( ip_driver_w-iprepad ),
615 CALL blacs_barrier( ictxt,
'All')
620 CALL pddbtrs( trans, n, bwl, bwu, nrhs, mem( ipa ),
621 $ 1, desca, mem( ipb ), 1, descb,
622 $ mem( ip_fillin ), fillin_size,
623 $ mem( ipw_solve ), ipw_solve_size,
630 $
WRITE( nout, fmt = * )
'PDDBTRS INFO=', info
642 $ mem( ip_driver_w-iprepad ),
652 $ mem( ipb ), 1, 1, descb2d,
653 $ iaseed, mem( ipa ), 1, 1, desca2d,
654 $ ibseed, anorm, sresid,
655 $ mem( ip_driver_w ), worksiz )
658 IF( sresid.GT.thresh )
659 $
WRITE( nout, fmt = 9985 ) sresid
664 IF( ( sresid.LE.thresh ).AND.
665 $ ( (sresid-sresid).EQ.0.0d+0 ) )
THEN
680 CALL slcombine( ictxt,
'All',
'>',
'W', 2, 1,
682 CALL slcombine( ictxt,
'All',
'>',
'C', 2, 1,
687 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
THEN
693 nprocs_real = ( n-1 )/nb + 1
694 n_last = mod( n-1, nb ) + 1
699 nops = 2*(dble(n)*dble(bwl)*
701 $ (dble(n)*dble(bwl))
706 $ 2 * (dble(n)*(dble(bwl)+dble(bwu))
714 nops2 = 2*( (dble(n_first)*
715 $ dble(bwl)*dble(bwu)))
717 IF ( nprocs_real .GT. 1)
THEN
723 $ 8*( (dble(n_last)*dble(bwl)
727 IF ( nprocs_real .GT. 2)
THEN
731 nops2 = nops2 + (nprocs_real-2)*
732 $ 8*( (dble(nb)*dble(bwl)
739 $ 2*( nprocs_real-1 ) *
741 IF( nprocs_real .GT. 1 )
THEN
743 $ 2*( nprocs_real-2 ) *
757 $ ( dble(bwl)+dble(bwu))
759 IF ( nprocs_real .GT. 1 )
THEN
767 $ (dble(n_last)*(dble(bwl)+
768 $ dble(bwu)))*dble(nrhs)
771 IF ( nprocs_real .GT. 2 )
THEN
778 $ ( nprocs_real-2)*2*
779 $ ( (dble(nb)*(dble(bwl)+
780 $ dble(bwu)))*dble(nrhs) )
786 $ nrhs*( nprocs_real-1)*2*(bwl*bwu )
787 IF( nprocs_real .GT. 1 )
THEN
789 $ nrhs*( nprocs_real-2 ) *
799 IF( wtime( 1 ) + wtime( 2 ) .GT. 0.0d+0 )
THEN
801 $ ( ( wtime( 1 )+wtime( 2 ) ) * 1.0d+6 )
806 IF( wtime( 1 )+wtime( 2 ).GT.0.0d+0 )
THEN
808 $ ( ( wtime( 1 )+wtime( 2 ) ) * 1.0d+6 )
813 IF( wtime( 2 ).GE.0.0d+0 )
814 $
WRITE( nout, fmt = 9993 )
'WALL', trans,
817 $ nb, nrhs, nprow, npcol,
818 $ wtime( 1 ), wtime( 2 ), tmflops,
823 IF( ctime( 1 )+ctime( 2 ).GT.0.0d+0 )
THEN
825 $ ( ( ctime( 1 )+ctime( 2 ) ) * 1.0d+6 )
830 IF( ctime( 1 )+ctime( 2 ).GT.0.0d+0 )
THEN
832 $ ( ( ctime( 1 )+ctime( 2 ) ) * 1.0d+6 )
837 IF( ctime( 2 ).GE.0.0d+0 )
838 $
WRITE( nout, fmt = 9993 )
'CPU ', trans,
841 $ nb, nrhs, nprow, npcol,
842 $ ctime( 1 ), ctime( 2 ), tmflops,
858 CALL blacs_gridexit( ictxt )
859 CALL blacs_gridexit( ictxtb )
869 ktests = kpass + kfail + kskip
870 WRITE( nout, fmt = * )
871 WRITE( nout, fmt = 9992 ) ktests
873 WRITE( nout, fmt = 9991 ) kpass
874 WRITE( nout, fmt = 9989 ) kfail
876 WRITE( nout, fmt = 9990 ) kpass
878 WRITE( nout, fmt = 9988 ) kskip
879 WRITE( nout, fmt = * )
880 WRITE( nout, fmt = * )
881 WRITE( nout, fmt = 9987 )
882 IF( nout.NE.6 .AND. nout.NE.0 )
888 9999
FORMAT(
'ILLEGAL ', a6,
': ', a5,
' = ', i3,
889 $
'; It should be at least 1' )
890 9998
FORMAT(
'ILLEGAL GRID: nprow*npcol = ', i4,
'. It can be at most',
892 9997
FORMAT(
'Bad ', a6,
' parameters: going on to next test case.' )
893 9996
FORMAT(
'Unable to perform ', a,
': need TOTMEM of at least',
895 9995
FORMAT(
'TIME TR N BWL BWU NB NRHS P Q L*U Time ',
896 $
'Slv Time MFLOPS MFLOP2 CHECK' )
897 9994
FORMAT(
'---- -- ------ --- --- ---- ----- ---- ---- -------- ',
898 $
'-------- -------- -------- ------' )
899 9993
FORMAT( a4,1x,a1,2x,i6,1x,i3,1x,i3,1x,i4,1x,i5,
900 $ 1x,i4,1x,i4,1x,f9.3,
901 $ f9.4, f9.2, f9.2, 1x, a6 )
902 9992
FORMAT(
'Finished ', i6,
' tests, with the following results:' )
903 9991
FORMAT( i5,
' tests completed and passed residual checks.' )
904 9990
FORMAT( i5,
' tests completed without checking.' )
905 9989
FORMAT( i5,
' tests completed and failed residual checks.' )
906 9988
FORMAT( i5,
' tests skipped because of illegal input values.' )
907 9987
FORMAT(
'END OF TESTS.' )
908 9986
FORMAT(
'||A - ', a4,
'|| / (||A|| * N * eps) = ', g25.7 )
909 9985
FORMAT(
'||Ax-b||/(||x||*||A||*eps*N) ', f25.7 )
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 numroc(n, nb, iproc, isrcproc, nprocs)
subroutine pdbmatgen(ictxt, aform, aform2, bwl, bwu, n, mb, nb, a, lda, iarow, iacol, iseed, myrow, mycol, nprow, npcol)
subroutine pdchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pddbinfo(summry, nout, trans, nmat, nval, ldnval, nbw, bwlval, bwuval, ldbwval, nnb, nbval, ldnbval, nnr, nrval, ldnrval, nnbr, nbrval, ldnbrval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
subroutine pddblaschk(symm, uplo, trans, n, bwl, bwu, nrhs, x, ix, jx, descx, iaseed, a, ia, ja, desca, ibseed, anorm, resid, work, worksiz)
subroutine pddbtrf(n, bwl, bwu, a, ja, desca, af, laf, work, lwork, info)
subroutine pddbtrs(trans, n, bwl, bwu, nrhs, a, ja, desca, b, ib, descb, af, laf, work, lwork, info)
subroutine pdfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
double precision function pdlange(norm, m, n, a, ia, ja, desca, work)
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)