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

◆ camxtest()

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

Definition at line 16860 of file blacstest.f.

16865*
16866* -- BLACS tester (version 1.0) --
16867* University of Tennessee
16868* December 15, 1994
16869*
16870*
16871* .. Scalar Arguments ..
16872 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
16873 $ TOPSCOHRNT, TOPSREPEAT, VERB
16874* ..
16875* .. Array Arguments ..
16876 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
16877 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
16878 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
16879 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
16880 COMPLEX MEM(MEMLEN)
16881* ..
16882*
16883* Purpose
16884* =======
16885* CTESTAMX: Test complex AMX COMBINE
16886*
16887* Arguments
16888* =========
16889* OUTNUM (input) INTEGER
16890* The device number to write output to.
16891*
16892* VERB (input) INTEGER
16893* The level of verbosity (how much printing to do).
16894*
16895* NSCOPE (input) INTEGER
16896* The number of scopes to be tested.
16897*
16898* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
16899* Values of the scopes to be tested.
16900*
16901* NTOP (input) INTEGER
16902* The number of topologies to be tested.
16903*
16904* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
16905* Values of the topologies to be tested.
16906*
16907* NMAT (input) INTEGER
16908* The number of matrices to be tested.
16909*
16910* M0 (input) INTEGER array of dimension (NMAT)
16911* Values of M to be tested.
16912*
16913* M0 (input) INTEGER array of dimension (NMAT)
16914* Values of M to be tested.
16915*
16916* N0 (input) INTEGER array of dimension (NMAT)
16917* Values of N to be tested.
16918*
16919* LDAS0 (input) INTEGER array of dimension (NMAT)
16920* Values of LDAS (leading dimension of A on source process)
16921* to be tested.
16922*
16923* LDAD0 (input) INTEGER array of dimension (NMAT)
16924* Values of LDAD (leading dimension of A on destination
16925* process) to be tested.
16926* LDI0 (input) INTEGER array of dimension (NMAT)
16927* Values of LDI (leading dimension of RA/CA) to be tested.
16928* If LDI == -1, these RA/CA should not be accessed.
16929*
16930* NDEST (input) INTEGER
16931* The number of destinations to be tested.
16932*
16933* RDEST0 (input) INTEGER array of dimension (NNDEST)
16934* Values of RDEST (row coordinate of destination) to be
16935* tested.
16936*
16937* CDEST0 (input) INTEGER array of dimension (NNDEST)
16938* Values of CDEST (column coordinate of destination) to be
16939* tested.
16940*
16941* NGRID (input) INTEGER
16942* The number of process grids to be tested.
16943*
16944* CONTEXT0 (input) INTEGER array of dimension (NGRID)
16945* The BLACS context handles corresponding to the grids.
16946*
16947* P0 (input) INTEGER array of dimension (NGRID)
16948* Values of P (number of process rows, NPROW).
16949*
16950* Q0 (input) INTEGER array of dimension (NGRID)
16951* Values of Q (number of process columns, NPCOL).
16952*
16953* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
16954* Workspace used to hold each process's random number SEED.
16955* This requires NPROCS (number of processor) elements.
16956* If VERB < 2, this workspace also serves to indicate which
16957* tests fail. This requires workspace of NTESTS
16958* (number of tests performed).
16959*
16960* RMEM (workspace) INTEGER array of dimension (RCLEN)
16961* Used for all RA arrays, and their pre and post padding.
16962*
16963* CMEM (workspace) INTEGER array of dimension (RCLEN)
16964* Used for all CA arrays, and their pre and post padding.
16965*
16966* RCLEN (input) INTEGER
16967* The length, in elements, of RMEM and CMEM.
16968*
16969* MEM (workspace) COMPLEX array of dimension (MEMLEN)
16970* Used for all other workspaces, including the matrix A,
16971* and its pre and post padding.
16972*
16973* MEMLEN (input) INTEGER
16974* The length, in elements, of MEM.
16975*
16976* =====================================================================
16977*
16978* .. External Functions ..
16979 LOGICAL ALLPASS, LSAME
16980 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
16981 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
16982* ..
16983* .. External Subroutines ..
16984 EXTERNAL blacs_gridinfo, cgamx2d
16985 EXTERNAL cinitmat, cchkpad, cbtcheckin
16986* ..
16987* .. Local Scalars ..
16988 CHARACTER*1 SCOPE, TOP
16989 LOGICAL INGRID, TESTOK, ALLRCV
16990 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR,
16991 $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
16992 $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO,
16993 $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M,
16994 $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP,
16995 $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
16996 COMPLEX CHECKVAL
16997* ..
16998* .. Executable Statements ..
16999*
17000* Choose padding value, and make it unique
17001*
17002 checkval = cmplx( -0.91e0, -0.71e0 )
17003 iam = ibtmyproc()
17004 checkval = iam * checkval
17005 isize = ibtsizeof('I')
17006 csize = ibtsizeof('C')
17007 icheckval = -iam
17008*
17009* Verify file parameters
17010*
17011 IF( iam .EQ. 0 ) THEN
17012 WRITE(outnum, *) ' '
17013 WRITE(outnum, *) ' '
17014 WRITE(outnum, 1000 )
17015 IF( verb .GT. 0 ) THEN
17016 WRITE(outnum,*) ' '
17017 WRITE(outnum, 2000) 'NSCOPE:', nscope
17018 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
17019 WRITE(outnum, 2000) 'TReps :', topsrepeat
17020 WRITE(outnum, 2000) 'TCohr :', topscohrnt
17021 WRITE(outnum, 2000) 'NTOP :', ntop
17022 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
17023 WRITE(outnum, 2000) 'NMAT :', nmat
17024 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
17025 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
17026 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
17027 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
17028 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
17029 WRITE(outnum, 2000) 'NDEST :', ndest
17030 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
17031 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
17032 WRITE(outnum, 2000) 'NGRIDS:', ngrid
17033 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
17034 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
17035 WRITE(outnum, 2000) 'VERB :', verb
17036 WRITE(outnum,*) ' '
17037 END IF
17038 IF( verb .GT. 1 ) THEN
17039 WRITE(outnum,4000)
17040 WRITE(outnum,5000)
17041 END IF
17042 END IF
17043 IF (topsrepeat.EQ.0) THEN
17044 itr1 = 0
17045 itr2 = 0
17046 ELSE IF (topsrepeat.EQ.1) THEN
17047 itr1 = 1
17048 itr2 = 1
17049 ELSE
17050 itr1 = 0
17051 itr2 = 1
17052 END IF
17053*
17054* Find biggest matrix, so we know where to stick error info
17055*
17056 i = 0
17057 DO 10 ima = 1, nmat
17058 ipad = 4 * m0(ima)
17059 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
17060 IF( k .GT. i ) i = k
17061 10 CONTINUE
17062 i = i + ibtnprocs()
17063 maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
17064 IF( maxerr .LT. 1 ) THEN
17065 WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
17066 CALL blacs_abort(-1, 1)
17067 END IF
17068 errdptr = i + 1
17069 erriptr = errdptr + maxerr
17070 nerr = 0
17071 testnum = 0
17072 nfail = 0
17073 nskip = 0
17074*
17075* Loop over grids of matrix
17076*
17077 DO 90 igr = 1, ngrid
17078*
17079* allocate process grid for the next batch of tests
17080*
17081 context = context0(igr)
17082 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
17083 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
17084*
17085 DO 80 isc = 1, nscope
17086 scope = scope0(isc)
17087 DO 70 ito = 1, ntop
17088 top = top0(ito)
17089*
17090* If testing multiring ('M') or general tree ('T'), need to
17091* loop over calls to BLACS_SET to do full test
17092*
17093 IF( lsame(top, 'M') ) THEN
17094 setwhat = 13
17095 IF( scope .EQ. 'R' ) THEN
17096 istart = -(npcol - 1)
17097 istop = -istart
17098 ELSE IF (scope .EQ. 'C') THEN
17099 istart = -(nprow - 1)
17100 istop = -istart
17101 ELSE
17102 istart = -(nprow*npcol - 1)
17103 istop = -istart
17104 ENDIF
17105 ELSE IF( lsame(top, 'T') ) THEN
17106 setwhat = 14
17107 istart = 1
17108 IF( scope .EQ. 'R' ) THEN
17109 istop = npcol - 1
17110 ELSE IF (scope .EQ. 'C') THEN
17111 istop = nprow - 1
17112 ELSE
17113 istop = nprow*npcol - 1
17114 ENDIF
17115 ELSE
17116 setwhat = 0
17117 istart = 1
17118 istop = 1
17119 ENDIF
17120 DO 60 ima = 1, nmat
17121 m = m0(ima)
17122 n = n0(ima)
17123 ldasrc = ldas0(ima)
17124 ldadst = ldad0(ima)
17125 ldi = ldi0(ima)
17126 ipre = 2 * m
17127 ipost = ipre
17128 preaptr = 1
17129 aptr = preaptr + ipre
17130*
17131 DO 50 ide = 1, ndest
17132 testnum = testnum + 1
17133 rdest2 = rdest0(ide)
17134 cdest2 = cdest0(ide)
17135*
17136* If everyone gets the answer, create some bogus rdest/cdest
17137* so IF's are easier
17138*
17139 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
17140 IF( allrcv ) THEN
17141 rdest = nprow - 1
17142 cdest = npcol - 1
17143 IF (topscohrnt.EQ.0) THEN
17144 itr1 = 0
17145 itr2 = 0
17146 ELSE IF (topscohrnt.EQ.1) THEN
17147 itr1 = 1
17148 itr2 = 1
17149 ELSE
17150 itr1 = 0
17151 itr2 = 1
17152 END IF
17153 ELSE
17154 rdest = rdest2
17155 cdest = cdest2
17156 itc1 = 0
17157 itc2 = 0
17158 END IF
17159 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
17160 nskip = nskip + 1
17161 GOTO 50
17162 END IF
17163*
17164 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
17165 lda = ldadst
17166 ELSE
17167 lda = ldasrc
17168 END IF
17169 valptr = aptr + ipost + n * lda
17170 IF( verb .GT. 1 ) THEN
17171 IF( iam .EQ. 0 ) THEN
17172 WRITE(outnum, 6000)
17173 $ testnum, 'RUNNING', scope, top, m, n,
17174 $ ldasrc, ldadst, ldi, rdest2, cdest2,
17175 $ nprow, npcol
17176 END IF
17177 END IF
17178*
17179* If I am in scope
17180*
17181 testok = .true.
17182 IF( ingrid ) THEN
17183 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
17184 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
17185 $ (scope .EQ. 'A') ) THEN
17186*
17187 k = nerr
17188 DO 40 itr = itr1, itr2
17189 CALL blacs_set(context, 15, itr)
17190 DO 35 itc = itc1, itc2
17191 CALL blacs_set(context, 16, itc)
17192 DO 30 j = istart, istop
17193 IF( j.EQ.0) GOTO 30
17194 IF( setwhat.NE.0 )
17195 $ CALL blacs_set(context, setwhat, j)
17196*
17197*
17198* generate and pad matrix A
17199*
17200 CALL cinitmat('G','-', m, n, mem(preaptr),
17201 $ lda, ipre, ipost,
17202 $ checkval, testnum,
17203 $ myrow, mycol )
17204*
17205* If they exist, pad RA and CA arrays
17206*
17207 IF( ldi .NE. -1 ) THEN
17208 DO 15 i = 1, n*ldi + ipre + ipost
17209 rmem(i) = icheckval
17210 cmem(i) = icheckval
17211 15 CONTINUE
17212 raptr = 1 + ipre
17213 captr = 1 + ipre
17214 ELSE
17215 DO 20 i = 1, ipre+ipost
17216 rmem(i) = icheckval
17217 cmem(i) = icheckval
17218 20 CONTINUE
17219 raptr = 1
17220 captr = 1
17221 END IF
17222*
17223 CALL cgamx2d(context, scope, top, m, n,
17224 $ mem(aptr), lda, rmem(raptr),
17225 $ cmem(captr), ldi,
17226 $ rdest2, cdest2)
17227*
17228* If I've got the answer, check for errors in
17229* matrix or padding
17230*
17231 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
17232 $ .OR. allrcv ) THEN
17233 CALL cchkpad('G','-', m, n,
17234 $ mem(preaptr), lda, rdest,
17235 $ cdest, myrow, mycol,
17236 $ ipre, ipost, checkval,
17237 $ testnum, maxerr, nerr,
17238 $ mem(erriptr),mem(errdptr))
17239 CALL cchkamx(scope, context, m, n,
17240 $ mem(aptr), lda,
17241 $ rmem(raptr), cmem(captr),
17242 $ ldi, testnum, maxerr,nerr,
17243 $ mem(erriptr),mem(errdptr),
17244 $ iseed, mem(valptr))
17245 CALL crcchk(ipre, ipost, icheckval,
17246 $ m, n, rmem, cmem, ldi,
17247 $ myrow, mycol, testnum,
17248 $ maxerr, nerr,
17249 $ mem(erriptr), mem(errdptr))
17250 END IF
17251 30 CONTINUE
17252 CALL blacs_set(context, 16, 0)
17253 35 CONTINUE
17254 CALL blacs_set(context, 15, 0)
17255 40 CONTINUE
17256 testok = ( k .EQ. nerr )
17257 END IF
17258 END IF
17259*
17260 IF( verb .GT. 1 ) THEN
17261 i = nerr
17262 CALL cbtcheckin(0, outnum, maxerr, nerr,
17263 $ mem(erriptr), mem(errdptr), iseed)
17264 IF( iam .EQ. 0 ) THEN
17265 IF( testok .AND. nerr.EQ.i ) THEN
17266 WRITE(outnum,6000)testnum,'PASSED ',
17267 $ scope, top, m, n, ldasrc,
17268 $ ldadst, ldi, rdest2, cdest2,
17269 $ nprow, npcol
17270 ELSE
17271 nfail = nfail + 1
17272 WRITE(outnum,6000)testnum,'FAILED ',
17273 $ scope, top, m, n, ldasrc,
17274 $ ldadst, ldi, rdest2, cdest2,
17275 $ nprow, npcol
17276 END IF
17277 END IF
17278*
17279* Once we've printed out errors, can re-use buf space
17280*
17281 nerr = 0
17282 END IF
17283 50 CONTINUE
17284 60 CONTINUE
17285 70 CONTINUE
17286 80 CONTINUE
17287 90 CONTINUE
17288*
17289 IF( verb .LT. 2 ) THEN
17290 nfail = testnum
17291 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
17292 $ mem(errdptr), iseed )
17293 END IF
17294 IF( iam .EQ. 0 ) THEN
17295 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
17296 IF( nfail+nskip .EQ. 0 ) THEN
17297 WRITE(outnum, 7000 ) testnum
17298 ELSE
17299 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
17300 $ nskip, nfail
17301 END IF
17302 END IF
17303*
17304* Log whether their were any failures
17305*
17306 testok = allpass( (nfail.EQ.0) )
17307*
17308 1000 FORMAT('COMPLEX AMX TESTS: BEGIN.' )
17309 2000 FORMAT(1x,a7,3x,10i6)
17310 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
17311 $ 5x,a1,5x,a1)
17312 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
17313 $ 'RDEST CDEST P Q')
17314 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
17315 $ '----- ----- ---- ----')
17316 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
17317 7000 FORMAT('COMPLEX AMX TESTS: PASSED ALL',
17318 $ i5, ' TESTS.')
17319 8000 FORMAT('COMPLEX AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
17320 $ i5,' SKIPPED,',i5,' FAILED.')
17321*
17322 RETURN
17323*
17324* End of CTESTAMX.
17325*
cmplx
float cmplx[2]
Definition pblas.h:136
crcchk
subroutine crcchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:17331
cchkpad
subroutine cchkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:9872
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
cinitmat
subroutine cinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:9591
cchkamx
subroutine cchkamx(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:17500
cbtcheckin
subroutine cbtcheckin(nftests, outnum, maxerr, nerr, ierr, cval, tfailed)
Definition blacstest.f:9469
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: