SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ damntest()

subroutine damntest ( integer  outnum,
integer  verb,
integer  topsrepeat,
integer  topscohrnt,
integer  nscope,
character*1, dimension(nscope)  scope0,
integer  ntop,
character*1, dimension(ntop)  top0,
integer  nmat,
integer, dimension(nmat)  m0,
integer, dimension(nmat)  n0,
integer, dimension(nmat)  ldas0,
integer, dimension(nmat)  ldad0,
integer, dimension(nmat)  ldi0,
integer  ndest,
integer, dimension(ndest)  rdest0,
integer, dimension(ndest)  cdest0,
integer  ngrid,
integer, dimension(ngrid)  context0,
integer, dimension(ngrid)  p0,
integer, dimension(ngrid)  q0,
integer, dimension(*)  iseed,
integer, dimension(rclen)  rmem,
integer, dimension(rclen)  cmem,
integer  rclen,
double precision, dimension(memlen)  mem,
integer  memlen 
)

Definition at line 19782 of file blacstest.f.

19787*
19788* -- BLACS tester (version 1.0) --
19789* University of Tennessee
19790* December 15, 1994
19791*
19792*
19793* .. Scalar Arguments ..
19794 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
19795 $ TOPSCOHRNT, TOPSREPEAT, VERB
19796* ..
19797* .. Array Arguments ..
19798 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
19799 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
19800 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
19801 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
19802 DOUBLE PRECISION MEM(MEMLEN)
19803* ..
19804*
19805* Purpose
19806* =======
19807* DTESTAMN: Test double precision AMN COMBINE
19808*
19809* Arguments
19810* =========
19811* OUTNUM (input) INTEGER
19812* The device number to write output to.
19813*
19814* VERB (input) INTEGER
19815* The level of verbosity (how much printing to do).
19816*
19817* NSCOPE (input) INTEGER
19818* The number of scopes to be tested.
19819*
19820* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
19821* Values of the scopes to be tested.
19822*
19823* NTOP (input) INTEGER
19824* The number of topologies to be tested.
19825*
19826* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
19827* Values of the topologies to be tested.
19828*
19829* NMAT (input) INTEGER
19830* The number of matrices to be tested.
19831*
19832* M0 (input) INTEGER array of dimension (NMAT)
19833* Values of M to be tested.
19834*
19835* M0 (input) INTEGER array of dimension (NMAT)
19836* Values of M to be tested.
19837*
19838* N0 (input) INTEGER array of dimension (NMAT)
19839* Values of N to be tested.
19840*
19841* LDAS0 (input) INTEGER array of dimension (NMAT)
19842* Values of LDAS (leading dimension of A on source process)
19843* to be tested.
19844*
19845* LDAD0 (input) INTEGER array of dimension (NMAT)
19846* Values of LDAD (leading dimension of A on destination
19847* process) to be tested.
19848* LDI0 (input) INTEGER array of dimension (NMAT)
19849* Values of LDI (leading dimension of RA/CA) to be tested.
19850* If LDI == -1, these RA/CA should not be accessed.
19851*
19852* NDEST (input) INTEGER
19853* The number of destinations to be tested.
19854*
19855* RDEST0 (input) INTEGER array of dimension (NNDEST)
19856* Values of RDEST (row coordinate of destination) to be
19857* tested.
19858*
19859* CDEST0 (input) INTEGER array of dimension (NNDEST)
19860* Values of CDEST (column coordinate of destination) to be
19861* tested.
19862*
19863* NGRID (input) INTEGER
19864* The number of process grids to be tested.
19865*
19866* CONTEXT0 (input) INTEGER array of dimension (NGRID)
19867* The BLACS context handles corresponding to the grids.
19868*
19869* P0 (input) INTEGER array of dimension (NGRID)
19870* Values of P (number of process rows, NPROW).
19871*
19872* Q0 (input) INTEGER array of dimension (NGRID)
19873* Values of Q (number of process columns, NPCOL).
19874*
19875* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
19876* Workspace used to hold each process's random number SEED.
19877* This requires NPROCS (number of processor) elements.
19878* If VERB < 2, this workspace also serves to indicate which
19879* tests fail. This requires workspace of NTESTS
19880* (number of tests performed).
19881*
19882* RMEM (workspace) INTEGER array of dimension (RCLEN)
19883* Used for all RA arrays, and their pre and post padding.
19884*
19885* CMEM (workspace) INTEGER array of dimension (RCLEN)
19886* Used for all CA arrays, and their pre and post padding.
19887*
19888* RCLEN (input) INTEGER
19889* The length, in elements, of RMEM and CMEM.
19890*
19891* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
19892* Used for all other workspaces, including the matrix A,
19893* and its pre and post padding.
19894*
19895* MEMLEN (input) INTEGER
19896* The length, in elements, of MEM.
19897*
19898* =====================================================================
19899*
19900* .. External Functions ..
19901 LOGICAL ALLPASS, LSAME
19902 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
19903 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
19904* ..
19905* .. External Subroutines ..
19906 EXTERNAL blacs_gridinfo, dgamn2d
19907 EXTERNAL dinitmat, dchkpad, dbtcheckin
19908* ..
19909* .. Local Scalars ..
19910 CHARACTER*1 SCOPE, TOP
19911 LOGICAL INGRID, TESTOK, ALLRCV
19912 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR,
19913 $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
19914 $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO,
19915 $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M,
19916 $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP,
19917 $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
19918 DOUBLE PRECISION CHECKVAL
19919* ..
19920* .. Executable Statements ..
19921*
19922* Choose padding value, and make it unique
19923*
19924 checkval = -0.81d0
19925 iam = ibtmyproc()
19926 checkval = iam * checkval
19927 isize = ibtsizeof('I')
19928 dsize = ibtsizeof('D')
19929 icheckval = -iam
19930*
19931* Verify file parameters
19932*
19933 IF( iam .EQ. 0 ) THEN
19934 WRITE(outnum, *) ' '
19935 WRITE(outnum, *) ' '
19936 WRITE(outnum, 1000 )
19937 IF( verb .GT. 0 ) THEN
19938 WRITE(outnum,*) ' '
19939 WRITE(outnum, 2000) 'NSCOPE:', nscope
19940 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
19941 WRITE(outnum, 2000) 'TReps :', topsrepeat
19942 WRITE(outnum, 2000) 'TCohr :', topscohrnt
19943 WRITE(outnum, 2000) 'NTOP :', ntop
19944 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
19945 WRITE(outnum, 2000) 'NMAT :', nmat
19946 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
19947 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
19948 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
19949 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
19950 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
19951 WRITE(outnum, 2000) 'NDEST :', ndest
19952 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
19953 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
19954 WRITE(outnum, 2000) 'NGRIDS:', ngrid
19955 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
19956 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
19957 WRITE(outnum, 2000) 'VERB :', verb
19958 WRITE(outnum,*) ' '
19959 END IF
19960 IF( verb .GT. 1 ) THEN
19961 WRITE(outnum,4000)
19962 WRITE(outnum,5000)
19963 END IF
19964 END IF
19965 IF (topsrepeat.EQ.0) THEN
19966 itr1 = 0
19967 itr2 = 0
19968 ELSE IF (topsrepeat.EQ.1) THEN
19969 itr1 = 1
19970 itr2 = 1
19971 ELSE
19972 itr1 = 0
19973 itr2 = 1
19974 END IF
19975*
19976* Find biggest matrix, so we know where to stick error info
19977*
19978 i = 0
19979 DO 10 ima = 1, nmat
19980 ipad = 4 * m0(ima)
19981 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
19982 IF( k .GT. i ) i = k
19983 10 CONTINUE
19984 i = i + ibtnprocs()
19985 maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
19986 IF( maxerr .LT. 1 ) THEN
19987 WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
19988 CALL blacs_abort(-1, 1)
19989 END IF
19990 errdptr = i + 1
19991 erriptr = errdptr + maxerr
19992 nerr = 0
19993 testnum = 0
19994 nfail = 0
19995 nskip = 0
19996*
19997* Loop over grids of matrix
19998*
19999 DO 90 igr = 1, ngrid
20000*
20001* allocate process grid for the next batch of tests
20002*
20003 context = context0(igr)
20004 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
20005 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
20006*
20007 DO 80 isc = 1, nscope
20008 scope = scope0(isc)
20009 DO 70 ito = 1, ntop
20010 top = top0(ito)
20011*
20012* If testing multiring ('M') or general tree ('T'), need to
20013* loop over calls to BLACS_SET to do full test
20014*
20015 IF( lsame(top, 'M') ) THEN
20016 setwhat = 13
20017 IF( scope .EQ. 'R' ) THEN
20018 istart = -(npcol - 1)
20019 istop = -istart
20020 ELSE IF (scope .EQ. 'C') THEN
20021 istart = -(nprow - 1)
20022 istop = -istart
20023 ELSE
20024 istart = -(nprow*npcol - 1)
20025 istop = -istart
20026 ENDIF
20027 ELSE IF( lsame(top, 'T') ) THEN
20028 setwhat = 14
20029 istart = 1
20030 IF( scope .EQ. 'R' ) THEN
20031 istop = npcol - 1
20032 ELSE IF (scope .EQ. 'C') THEN
20033 istop = nprow - 1
20034 ELSE
20035 istop = nprow*npcol - 1
20036 ENDIF
20037 ELSE
20038 setwhat = 0
20039 istart = 1
20040 istop = 1
20041 ENDIF
20042 DO 60 ima = 1, nmat
20043 m = m0(ima)
20044 n = n0(ima)
20045 ldasrc = ldas0(ima)
20046 ldadst = ldad0(ima)
20047 ldi = ldi0(ima)
20048 ipre = 2 * m
20049 ipost = ipre
20050 preaptr = 1
20051 aptr = preaptr + ipre
20052*
20053 DO 50 ide = 1, ndest
20054 testnum = testnum + 1
20055 rdest2 = rdest0(ide)
20056 cdest2 = cdest0(ide)
20057*
20058* If everyone gets the answer, create some bogus rdest/cdest
20059* so IF's are easier
20060*
20061 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
20062 IF( allrcv ) THEN
20063 rdest = nprow - 1
20064 cdest = npcol - 1
20065 IF (topscohrnt.EQ.0) THEN
20066 itr1 = 0
20067 itr2 = 0
20068 ELSE IF (topscohrnt.EQ.1) THEN
20069 itr1 = 1
20070 itr2 = 1
20071 ELSE
20072 itr1 = 0
20073 itr2 = 1
20074 END IF
20075 ELSE
20076 rdest = rdest2
20077 cdest = cdest2
20078 itc1 = 0
20079 itc2 = 0
20080 END IF
20081 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
20082 nskip = nskip + 1
20083 GOTO 50
20084 END IF
20085*
20086 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
20087 lda = ldadst
20088 ELSE
20089 lda = ldasrc
20090 END IF
20091 valptr = aptr + ipost + n * lda
20092 IF( verb .GT. 1 ) THEN
20093 IF( iam .EQ. 0 ) THEN
20094 WRITE(outnum, 6000)
20095 $ testnum, 'RUNNING', scope, top, m, n,
20096 $ ldasrc, ldadst, ldi, rdest2, cdest2,
20097 $ nprow, npcol
20098 END IF
20099 END IF
20100*
20101* If I am in scope
20102*
20103 testok = .true.
20104 IF( ingrid ) THEN
20105 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
20106 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
20107 $ (scope .EQ. 'A') ) THEN
20108*
20109 k = nerr
20110 DO 40 itr = itr1, itr2
20111 CALL blacs_set(context, 15, itr)
20112 DO 35 itc = itc1, itc2
20113 CALL blacs_set(context, 16, itc)
20114 DO 30 j = istart, istop
20115 IF( j.EQ.0) GOTO 30
20116 IF( setwhat.NE.0 )
20117 $ CALL blacs_set(context, setwhat, j)
20118*
20119*
20120* generate and pad matrix A
20121*
20122 CALL dinitmat('G','-', m, n, mem(preaptr),
20123 $ lda, ipre, ipost,
20124 $ checkval, testnum,
20125 $ myrow, mycol )
20126*
20127* If they exist, pad RA and CA arrays
20128*
20129 IF( ldi .NE. -1 ) THEN
20130 DO 15 i = 1, n*ldi + ipre + ipost
20131 rmem(i) = icheckval
20132 cmem(i) = icheckval
20133 15 CONTINUE
20134 raptr = 1 + ipre
20135 captr = 1 + ipre
20136 ELSE
20137 DO 20 i = 1, ipre+ipost
20138 rmem(i) = icheckval
20139 cmem(i) = icheckval
20140 20 CONTINUE
20141 raptr = 1
20142 captr = 1
20143 END IF
20144*
20145 CALL dgamn2d(context, scope, top, m, n,
20146 $ mem(aptr), lda, rmem(raptr),
20147 $ cmem(captr), ldi,
20148 $ rdest2, cdest2)
20149*
20150* If I've got the answer, check for errors in
20151* matrix or padding
20152*
20153 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
20154 $ .OR. allrcv ) THEN
20155 CALL dchkpad('G','-', m, n,
20156 $ mem(preaptr), lda, rdest,
20157 $ cdest, myrow, mycol,
20158 $ ipre, ipost, checkval,
20159 $ testnum, maxerr, nerr,
20160 $ mem(erriptr),mem(errdptr))
20161 CALL dchkamn(scope, context, m, n,
20162 $ mem(aptr), lda,
20163 $ rmem(raptr), cmem(captr),
20164 $ ldi, testnum, maxerr,nerr,
20165 $ mem(erriptr),mem(errdptr),
20166 $ iseed, mem(valptr))
20167 CALL drcchk(ipre, ipost, icheckval,
20168 $ m, n, rmem, cmem, ldi,
20169 $ myrow, mycol, testnum,
20170 $ maxerr, nerr,
20171 $ mem(erriptr), mem(errdptr))
20172 END IF
20173 30 CONTINUE
20174 CALL blacs_set(context, 16, 0)
20175 35 CONTINUE
20176 CALL blacs_set(context, 15, 0)
20177 40 CONTINUE
20178 testok = ( k .EQ. nerr )
20179 END IF
20180 END IF
20181*
20182 IF( verb .GT. 1 ) THEN
20183 i = nerr
20184 CALL dbtcheckin(0, outnum, maxerr, nerr,
20185 $ mem(erriptr), mem(errdptr), iseed)
20186 IF( iam .EQ. 0 ) THEN
20187 IF( testok .AND. nerr.EQ.i ) THEN
20188 WRITE(outnum,6000)testnum,'PASSED ',
20189 $ scope, top, m, n, ldasrc,
20190 $ ldadst, ldi, rdest2, cdest2,
20191 $ nprow, npcol
20192 ELSE
20193 nfail = nfail + 1
20194 WRITE(outnum,6000)testnum,'FAILED ',
20195 $ scope, top, m, n, ldasrc,
20196 $ ldadst, ldi, rdest2, cdest2,
20197 $ nprow, npcol
20198 END IF
20199 END IF
20200*
20201* Once we've printed out errors, can re-use buf space
20202*
20203 nerr = 0
20204 END IF
20205 50 CONTINUE
20206 60 CONTINUE
20207 70 CONTINUE
20208 80 CONTINUE
20209 90 CONTINUE
20210*
20211 IF( verb .LT. 2 ) THEN
20212 nfail = testnum
20213 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
20214 $ mem(errdptr), iseed )
20215 END IF
20216 IF( iam .EQ. 0 ) THEN
20217 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
20218 IF( nfail+nskip .EQ. 0 ) THEN
20219 WRITE(outnum, 7000 ) testnum
20220 ELSE
20221 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
20222 $ nskip, nfail
20223 END IF
20224 END IF
20225*
20226* Log whether their were any failures
20227*
20228 testok = allpass( (nfail.EQ.0) )
20229*
20230 1000 FORMAT('DOUBLE PRECISION AMN TESTS: BEGIN.' )
20231 2000 FORMAT(1x,a7,3x,10i6)
20232 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
20233 $ 5x,a1,5x,a1)
20234 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
20235 $ 'RDEST CDEST P Q')
20236 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
20237 $ '----- ----- ---- ----')
20238 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
20239 7000 FORMAT('DOUBLE PRECISION AMN TESTS: PASSED ALL',
20240 $ i5, ' TESTS.')
20241 8000 FORMAT('DOUBLE PRECISION AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
20242 $ i5,' SKIPPED,',i5,' FAILED.')
20243*
20244 RETURN
20245*
20246* End of DTESTAMN.
20247*
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
dchkpad
subroutine dchkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:8810
drcchk
subroutine drcchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:16516
dinitmat
subroutine dinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:8527
dchkamn
subroutine dchkamn(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:20253
dbtcheckin
subroutine dbtcheckin(nftests, outnum, maxerr, nerr, ierr, dval, tfailed)
Definition blacstest.f:8405
ibtnprocs
integer function ibtnprocs()
Definition btprim.f:81
ibtmyproc
integer function ibtmyproc()
Definition btprim.f:47
ibtsizeof
integer function ibtsizeof(type)
Definition btprim.f:286
lsame
logical function lsame(ca, cb)
Definition tools.f:1724
Here is the call graph for this function:
Here is the caller graph for this function: