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

◆ zsumtest()

subroutine zsumtest ( 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  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,
double complex, dimension(memlen)  mem,
integer  memlen 
)

Definition at line 13832 of file blacstest.f.

13836*
13837* -- BLACS tester (version 1.0) --
13838* University of Tennessee
13839* December 15, 1994
13840*
13841*
13842* .. Scalar Arguments ..
13843 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
13844 $ TOPSCOHRNT, TOPSREPEAT, VERB
13845* ..
13846* .. Array Arguments ..
13847 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
13848 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
13849 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
13850 INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
13851 DOUBLE COMPLEX MEM(MEMLEN)
13852* ..
13853*
13854* Purpose
13855* =======
13856* ZTESTSUM: Test double complex SUM COMBINE
13857*
13858* Arguments
13859* =========
13860* OUTNUM (input) INTEGER
13861* The device number to write output to.
13862*
13863* VERB (input) INTEGER
13864* The level of verbosity (how much printing to do).
13865*
13866* NSCOPE (input) INTEGER
13867* The number of scopes to be tested.
13868*
13869* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
13870* Values of the scopes to be tested.
13871*
13872* NTOP (input) INTEGER
13873* The number of topologies to be tested.
13874*
13875* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
13876* Values of the topologies to be tested.
13877*
13878* NMAT (input) INTEGER
13879* The number of matrices to be tested.
13880*
13881* M0 (input) INTEGER array of dimension (NMAT)
13882* Values of M to be tested.
13883*
13884* M0 (input) INTEGER array of dimension (NMAT)
13885* Values of M to be tested.
13886*
13887* N0 (input) INTEGER array of dimension (NMAT)
13888* Values of N to be tested.
13889*
13890* LDAS0 (input) INTEGER array of dimension (NMAT)
13891* Values of LDAS (leading dimension of A on source process)
13892* to be tested.
13893*
13894* LDAD0 (input) INTEGER array of dimension (NMAT)
13895* Values of LDAD (leading dimension of A on destination
13896* process) to be tested.
13897* NDEST (input) INTEGER
13898* The number of destinations to be tested.
13899*
13900* RDEST0 (input) INTEGER array of dimension (NNDEST)
13901* Values of RDEST (row coordinate of destination) to be
13902* tested.
13903*
13904* CDEST0 (input) INTEGER array of dimension (NNDEST)
13905* Values of CDEST (column coordinate of destination) to be
13906* tested.
13907*
13908* NGRID (input) INTEGER
13909* The number of process grids to be tested.
13910*
13911* CONTEXT0 (input) INTEGER array of dimension (NGRID)
13912* The BLACS context handles corresponding to the grids.
13913*
13914* P0 (input) INTEGER array of dimension (NGRID)
13915* Values of P (number of process rows, NPROW).
13916*
13917* Q0 (input) INTEGER array of dimension (NGRID)
13918* Values of Q (number of process columns, NPCOL).
13919*
13920* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
13921* Workspace used to hold each process's random number SEED.
13922* This requires NPROCS (number of processor) elements.
13923* If VERB < 2, this workspace also serves to indicate which
13924* tests fail. This requires workspace of NTESTS
13925* (number of tests performed).
13926*
13927* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
13928* Used for all other workspaces, including the matrix A,
13929* and its pre and post padding.
13930*
13931* MEMLEN (input) INTEGER
13932* The length, in elements, of MEM.
13933*
13934* =====================================================================
13935*
13936* .. External Functions ..
13937 LOGICAL ALLPASS, LSAME
13938 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
13939 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
13940* ..
13941* .. External Subroutines ..
13942 EXTERNAL blacs_gridinfo, zgsum2d
13943 EXTERNAL zinitmat, zchkpad, zbtcheckin
13944* ..
13945* .. Local Scalars ..
13946 CHARACTER*1 SCOPE, TOP
13947 LOGICAL INGRID, TESTOK, ALLRCV
13948 INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
13949 $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
13950 $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
13951 $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
13952 $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
13953 $ TESTNUM, ZSIZE
13954 DOUBLE COMPLEX CHECKVAL
13955* ..
13956* .. Executable Statements ..
13957*
13958* Choose padding value, and make it unique
13959*
13960 checkval = dcmplx( -9.11d0, -9.21d0 )
13961 iam = ibtmyproc()
13962 checkval = iam * checkval
13963 isize = ibtsizeof('I')
13964 zsize = ibtsizeof('Z')
13965*
13966* Verify file parameters
13967*
13968 IF( iam .EQ. 0 ) THEN
13969 WRITE(outnum, *) ' '
13970 WRITE(outnum, *) ' '
13971 WRITE(outnum, 1000 )
13972 IF( verb .GT. 0 ) THEN
13973 WRITE(outnum,*) ' '
13974 WRITE(outnum, 2000) 'NSCOPE:', nscope
13975 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
13976 WRITE(outnum, 2000) 'TReps :', topsrepeat
13977 WRITE(outnum, 2000) 'TCohr :', topscohrnt
13978 WRITE(outnum, 2000) 'NTOP :', ntop
13979 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
13980 WRITE(outnum, 2000) 'NMAT :', nmat
13981 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
13982 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
13983 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
13984 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
13985 WRITE(outnum, 2000) 'NDEST :', ndest
13986 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
13987 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
13988 WRITE(outnum, 2000) 'NGRIDS:', ngrid
13989 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
13990 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
13991 WRITE(outnum, 2000) 'VERB :', verb
13992 WRITE(outnum,*) ' '
13993 END IF
13994 IF( verb .GT. 1 ) THEN
13995 WRITE(outnum,4000)
13996 WRITE(outnum,5000)
13997 END IF
13998 END IF
13999 IF (topsrepeat.EQ.0) THEN
14000 itr1 = 0
14001 itr2 = 0
14002 ELSE IF (topsrepeat.EQ.1) THEN
14003 itr1 = 1
14004 itr2 = 1
14005 ELSE
14006 itr1 = 0
14007 itr2 = 1
14008 END IF
14009*
14010* Find biggest matrix, so we know where to stick error info
14011*
14012 i = 0
14013 DO 10 ima = 1, nmat
14014 ipad = 4 * m0(ima)
14015 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
14016 IF( k .GT. i ) i = k
14017 10 CONTINUE
14018 maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
14019 IF( maxerr .LT. 1 ) THEN
14020 WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
14021 CALL blacs_abort(-1, 1)
14022 END IF
14023 errdptr = i + 1
14024 erriptr = errdptr + maxerr
14025 nerr = 0
14026 testnum = 0
14027 nfail = 0
14028 nskip = 0
14029*
14030* Loop over grids of matrix
14031*
14032 DO 90 igr = 1, ngrid
14033*
14034* allocate process grid for the next batch of tests
14035*
14036 context = context0(igr)
14037 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
14038 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
14039*
14040 DO 80 isc = 1, nscope
14041 scope = scope0(isc)
14042 DO 70 ito = 1, ntop
14043 top = top0(ito)
14044*
14045* If testing multiring ('M') or general tree ('T'), need to
14046* loop over calls to BLACS_SET to do full test
14047*
14048 IF( lsame(top, 'M') ) THEN
14049 setwhat = 13
14050 IF( scope .EQ. 'R' ) THEN
14051 istart = -(npcol - 1)
14052 istop = -istart
14053 ELSE IF (scope .EQ. 'C') THEN
14054 istart = -(nprow - 1)
14055 istop = -istart
14056 ELSE
14057 istart = -(nprow*npcol - 1)
14058 istop = -istart
14059 ENDIF
14060 ELSE IF( lsame(top, 'T') ) THEN
14061 setwhat = 14
14062 istart = 1
14063 IF( scope .EQ. 'R' ) THEN
14064 istop = npcol - 1
14065 ELSE IF (scope .EQ. 'C') THEN
14066 istop = nprow - 1
14067 ELSE
14068 istop = nprow*npcol - 1
14069 ENDIF
14070 ELSE
14071 setwhat = 0
14072 istart = 1
14073 istop = 1
14074 ENDIF
14075 DO 60 ima = 1, nmat
14076 m = m0(ima)
14077 n = n0(ima)
14078 ldasrc = ldas0(ima)
14079 ldadst = ldad0(ima)
14080 ipre = 2 * m
14081 ipost = ipre
14082 preaptr = 1
14083 aptr = preaptr + ipre
14084*
14085 DO 50 ide = 1, ndest
14086 testnum = testnum + 1
14087 rdest2 = rdest0(ide)
14088 cdest2 = cdest0(ide)
14089*
14090* If everyone gets the answer, create some bogus rdest/cdest
14091* so IF's are easier
14092*
14093 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
14094 IF( allrcv ) THEN
14095 rdest = nprow - 1
14096 cdest = npcol - 1
14097 IF (topscohrnt.EQ.0) THEN
14098 itr1 = 0
14099 itr2 = 0
14100 ELSE IF (topscohrnt.EQ.1) THEN
14101 itr1 = 1
14102 itr2 = 1
14103 ELSE
14104 itr1 = 0
14105 itr2 = 1
14106 END IF
14107 ELSE
14108 rdest = rdest2
14109 cdest = cdest2
14110 itc1 = 0
14111 itc2 = 0
14112 END IF
14113 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
14114 nskip = nskip + 1
14115 GOTO 50
14116 END IF
14117*
14118 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
14119 lda = ldadst
14120 ELSE
14121 lda = ldasrc
14122 END IF
14123 IF( verb .GT. 1 ) THEN
14124 IF( iam .EQ. 0 ) THEN
14125 WRITE(outnum, 6000)
14126 $ testnum, 'RUNNING', scope, top, m, n,
14127 $ ldasrc, ldadst, rdest2, cdest2,
14128 $ nprow, npcol
14129 END IF
14130 END IF
14131*
14132* If I am in scope
14133*
14134 testok = .true.
14135 IF( ingrid ) THEN
14136 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
14137 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
14138 $ (scope .EQ. 'A') ) THEN
14139*
14140 k = nerr
14141 DO 40 itr = itr1, itr2
14142 CALL blacs_set(context, 15, itr)
14143 DO 35 itc = itc1, itc2
14144 CALL blacs_set(context, 16, itc)
14145 DO 30 j = istart, istop
14146 IF( j.EQ.0) GOTO 30
14147 IF( setwhat.NE.0 )
14148 $ CALL blacs_set(context, setwhat, j)
14149*
14150*
14151* generate and pad matrix A
14152*
14153 CALL zinitmat('G','-', m, n, mem(preaptr),
14154 $ lda, ipre, ipost,
14155 $ checkval, testnum,
14156 $ myrow, mycol )
14157*
14158 CALL zgsum2d(context, scope, top, m, n,
14159 $ mem(aptr), lda, rdest2,
14160 $ cdest2)
14161*
14162* If I've got the answer, check for errors in
14163* matrix or padding
14164*
14165 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
14166 $ .OR. allrcv ) THEN
14167 CALL zchkpad('G','-', m, n,
14168 $ mem(preaptr), lda, rdest,
14169 $ cdest, myrow, mycol,
14170 $ ipre, ipost, checkval,
14171 $ testnum, maxerr, nerr,
14172 $ mem(erriptr),mem(errdptr))
14173 CALL zchksum(scope, context, m, n,
14174 $ mem(aptr), lda,
14175 $ testnum, maxerr, nerr,
14176 $ mem(erriptr),mem(errdptr),
14177 $ iseed)
14178 END IF
14179 30 CONTINUE
14180 CALL blacs_set(context, 16, 0)
14181 35 CONTINUE
14182 CALL blacs_set(context, 15, 0)
14183 40 CONTINUE
14184 testok = ( k .EQ. nerr )
14185 END IF
14186 END IF
14187*
14188 IF( verb .GT. 1 ) THEN
14189 i = nerr
14190 CALL zbtcheckin(0, outnum, maxerr, nerr,
14191 $ mem(erriptr), mem(errdptr), iseed)
14192 IF( iam .EQ. 0 ) THEN
14193 IF( testok .AND. nerr.EQ.i ) THEN
14194 WRITE(outnum,6000)testnum,'PASSED ',
14195 $ scope, top, m, n, ldasrc,
14196 $ ldadst, rdest2, cdest2,
14197 $ nprow, npcol
14198 ELSE
14199 nfail = nfail + 1
14200 WRITE(outnum,6000)testnum,'FAILED ',
14201 $ scope, top, m, n, ldasrc,
14202 $ ldadst, rdest2, cdest2,
14203 $ nprow, npcol
14204 END IF
14205 END IF
14206*
14207* Once we've printed out errors, can re-use buf space
14208*
14209 nerr = 0
14210 END IF
14211 50 CONTINUE
14212 60 CONTINUE
14213 70 CONTINUE
14214 80 CONTINUE
14215 90 CONTINUE
14216*
14217 IF( verb .LT. 2 ) THEN
14218 nfail = testnum
14219 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
14220 $ mem(errdptr), iseed )
14221 END IF
14222 IF( iam .EQ. 0 ) THEN
14223 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
14224 IF( nfail+nskip .EQ. 0 ) THEN
14225 WRITE(outnum, 7000 ) testnum
14226 ELSE
14227 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
14228 $ nskip, nfail
14229 END IF
14230 END IF
14231*
14232* Log whether their were any failures
14233*
14234 testok = allpass( (nfail.EQ.0) )
14235*
14236 1000 FORMAT('DOUBLE COMPLEX SUM TESTS: BEGIN.' )
14237 2000 FORMAT(1x,a7,3x,10i6)
14238 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
14239 $ 5x,a1,5x,a1)
14240 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
14241 $ 'RDEST CDEST P Q')
14242 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
14243 $ '----- ----- ---- ----')
14244 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
14245 7000 FORMAT('DOUBLE COMPLEX SUM TESTS: PASSED ALL',
14246 $ i5, ' TESTS.')
14247 8000 FORMAT('DOUBLE COMPLEX SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
14248 $ i5,' SKIPPED,',i5,' FAILED.')
14249*
14250 RETURN
14251*
14252* End of ZTESTSUM.
14253*
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
zchksum
subroutine zchksum(scope, ictxt, m, n, a, lda, testnum, maxerr, nerr, erribuf, errdbuf, iseed)
Definition blacstest.f:14264
zinitmat
subroutine zinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:10659
zchkpad
subroutine zchkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:10940
zbtcheckin
subroutine zbtcheckin(nftests, outnum, maxerr, nerr, ierr, zval, tfailed)
Definition blacstest.f:10537
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: