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

◆ damxtest()

subroutine damxtest ( 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 16045 of file blacstest.f.

16050*
16051* -- BLACS tester (version 1.0) --
16052* University of Tennessee
16053* December 15, 1994
16054*
16055*
16056* .. Scalar Arguments ..
16057 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
16058 $ TOPSCOHRNT, TOPSREPEAT, VERB
16059* ..
16060* .. Array Arguments ..
16061 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
16062 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
16063 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
16064 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
16065 DOUBLE PRECISION MEM(MEMLEN)
16066* ..
16067*
16068* Purpose
16069* =======
16070* DTESTAMX: Test double precision AMX COMBINE
16071*
16072* Arguments
16073* =========
16074* OUTNUM (input) INTEGER
16075* The device number to write output to.
16076*
16077* VERB (input) INTEGER
16078* The level of verbosity (how much printing to do).
16079*
16080* NSCOPE (input) INTEGER
16081* The number of scopes to be tested.
16082*
16083* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
16084* Values of the scopes to be tested.
16085*
16086* NTOP (input) INTEGER
16087* The number of topologies to be tested.
16088*
16089* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
16090* Values of the topologies to be tested.
16091*
16092* NMAT (input) INTEGER
16093* The number of matrices to be tested.
16094*
16095* M0 (input) INTEGER array of dimension (NMAT)
16096* Values of M to be tested.
16097*
16098* M0 (input) INTEGER array of dimension (NMAT)
16099* Values of M to be tested.
16100*
16101* N0 (input) INTEGER array of dimension (NMAT)
16102* Values of N to be tested.
16103*
16104* LDAS0 (input) INTEGER array of dimension (NMAT)
16105* Values of LDAS (leading dimension of A on source process)
16106* to be tested.
16107*
16108* LDAD0 (input) INTEGER array of dimension (NMAT)
16109* Values of LDAD (leading dimension of A on destination
16110* process) to be tested.
16111* LDI0 (input) INTEGER array of dimension (NMAT)
16112* Values of LDI (leading dimension of RA/CA) to be tested.
16113* If LDI == -1, these RA/CA should not be accessed.
16114*
16115* NDEST (input) INTEGER
16116* The number of destinations to be tested.
16117*
16118* RDEST0 (input) INTEGER array of dimension (NNDEST)
16119* Values of RDEST (row coordinate of destination) to be
16120* tested.
16121*
16122* CDEST0 (input) INTEGER array of dimension (NNDEST)
16123* Values of CDEST (column coordinate of destination) to be
16124* tested.
16125*
16126* NGRID (input) INTEGER
16127* The number of process grids to be tested.
16128*
16129* CONTEXT0 (input) INTEGER array of dimension (NGRID)
16130* The BLACS context handles corresponding to the grids.
16131*
16132* P0 (input) INTEGER array of dimension (NGRID)
16133* Values of P (number of process rows, NPROW).
16134*
16135* Q0 (input) INTEGER array of dimension (NGRID)
16136* Values of Q (number of process columns, NPCOL).
16137*
16138* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
16139* Workspace used to hold each process's random number SEED.
16140* This requires NPROCS (number of processor) elements.
16141* If VERB < 2, this workspace also serves to indicate which
16142* tests fail. This requires workspace of NTESTS
16143* (number of tests performed).
16144*
16145* RMEM (workspace) INTEGER array of dimension (RCLEN)
16146* Used for all RA arrays, and their pre and post padding.
16147*
16148* CMEM (workspace) INTEGER array of dimension (RCLEN)
16149* Used for all CA arrays, and their pre and post padding.
16150*
16151* RCLEN (input) INTEGER
16152* The length, in elements, of RMEM and CMEM.
16153*
16154* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
16155* Used for all other workspaces, including the matrix A,
16156* and its pre and post padding.
16157*
16158* MEMLEN (input) INTEGER
16159* The length, in elements, of MEM.
16160*
16161* =====================================================================
16162*
16163* .. External Functions ..
16164 LOGICAL ALLPASS, LSAME
16165 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
16166 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
16167* ..
16168* .. External Subroutines ..
16169 EXTERNAL blacs_gridinfo, dgamx2d
16170 EXTERNAL dinitmat, dchkpad, dbtcheckin
16171* ..
16172* .. Local Scalars ..
16173 CHARACTER*1 SCOPE, TOP
16174 LOGICAL INGRID, TESTOK, ALLRCV
16175 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR,
16176 $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
16177 $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO,
16178 $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M,
16179 $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP,
16180 $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
16181 DOUBLE PRECISION CHECKVAL
16182* ..
16183* .. Executable Statements ..
16184*
16185* Choose padding value, and make it unique
16186*
16187 checkval = -0.81d0
16188 iam = ibtmyproc()
16189 checkval = iam * checkval
16190 isize = ibtsizeof('I')
16191 dsize = ibtsizeof('D')
16192 icheckval = -iam
16193*
16194* Verify file parameters
16195*
16196 IF( iam .EQ. 0 ) THEN
16197 WRITE(outnum, *) ' '
16198 WRITE(outnum, *) ' '
16199 WRITE(outnum, 1000 )
16200 IF( verb .GT. 0 ) THEN
16201 WRITE(outnum,*) ' '
16202 WRITE(outnum, 2000) 'NSCOPE:', nscope
16203 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
16204 WRITE(outnum, 2000) 'TReps :', topsrepeat
16205 WRITE(outnum, 2000) 'TCohr :', topscohrnt
16206 WRITE(outnum, 2000) 'NTOP :', ntop
16207 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
16208 WRITE(outnum, 2000) 'NMAT :', nmat
16209 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
16210 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
16211 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
16212 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
16213 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
16214 WRITE(outnum, 2000) 'NDEST :', ndest
16215 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
16216 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
16217 WRITE(outnum, 2000) 'NGRIDS:', ngrid
16218 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
16219 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
16220 WRITE(outnum, 2000) 'VERB :', verb
16221 WRITE(outnum,*) ' '
16222 END IF
16223 IF( verb .GT. 1 ) THEN
16224 WRITE(outnum,4000)
16225 WRITE(outnum,5000)
16226 END IF
16227 END IF
16228 IF (topsrepeat.EQ.0) THEN
16229 itr1 = 0
16230 itr2 = 0
16231 ELSE IF (topsrepeat.EQ.1) THEN
16232 itr1 = 1
16233 itr2 = 1
16234 ELSE
16235 itr1 = 0
16236 itr2 = 1
16237 END IF
16238*
16239* Find biggest matrix, so we know where to stick error info
16240*
16241 i = 0
16242 DO 10 ima = 1, nmat
16243 ipad = 4 * m0(ima)
16244 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
16245 IF( k .GT. i ) i = k
16246 10 CONTINUE
16247 i = i + ibtnprocs()
16248 maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
16249 IF( maxerr .LT. 1 ) THEN
16250 WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
16251 CALL blacs_abort(-1, 1)
16252 END IF
16253 errdptr = i + 1
16254 erriptr = errdptr + maxerr
16255 nerr = 0
16256 testnum = 0
16257 nfail = 0
16258 nskip = 0
16259*
16260* Loop over grids of matrix
16261*
16262 DO 90 igr = 1, ngrid
16263*
16264* allocate process grid for the next batch of tests
16265*
16266 context = context0(igr)
16267 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
16268 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
16269*
16270 DO 80 isc = 1, nscope
16271 scope = scope0(isc)
16272 DO 70 ito = 1, ntop
16273 top = top0(ito)
16274*
16275* If testing multiring ('M') or general tree ('T'), need to
16276* loop over calls to BLACS_SET to do full test
16277*
16278 IF( lsame(top, 'M') ) THEN
16279 setwhat = 13
16280 IF( scope .EQ. 'R' ) THEN
16281 istart = -(npcol - 1)
16282 istop = -istart
16283 ELSE IF (scope .EQ. 'C') THEN
16284 istart = -(nprow - 1)
16285 istop = -istart
16286 ELSE
16287 istart = -(nprow*npcol - 1)
16288 istop = -istart
16289 ENDIF
16290 ELSE IF( lsame(top, 'T') ) THEN
16291 setwhat = 14
16292 istart = 1
16293 IF( scope .EQ. 'R' ) THEN
16294 istop = npcol - 1
16295 ELSE IF (scope .EQ. 'C') THEN
16296 istop = nprow - 1
16297 ELSE
16298 istop = nprow*npcol - 1
16299 ENDIF
16300 ELSE
16301 setwhat = 0
16302 istart = 1
16303 istop = 1
16304 ENDIF
16305 DO 60 ima = 1, nmat
16306 m = m0(ima)
16307 n = n0(ima)
16308 ldasrc = ldas0(ima)
16309 ldadst = ldad0(ima)
16310 ldi = ldi0(ima)
16311 ipre = 2 * m
16312 ipost = ipre
16313 preaptr = 1
16314 aptr = preaptr + ipre
16315*
16316 DO 50 ide = 1, ndest
16317 testnum = testnum + 1
16318 rdest2 = rdest0(ide)
16319 cdest2 = cdest0(ide)
16320*
16321* If everyone gets the answer, create some bogus rdest/cdest
16322* so IF's are easier
16323*
16324 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
16325 IF( allrcv ) THEN
16326 rdest = nprow - 1
16327 cdest = npcol - 1
16328 IF (topscohrnt.EQ.0) THEN
16329 itr1 = 0
16330 itr2 = 0
16331 ELSE IF (topscohrnt.EQ.1) THEN
16332 itr1 = 1
16333 itr2 = 1
16334 ELSE
16335 itr1 = 0
16336 itr2 = 1
16337 END IF
16338 ELSE
16339 rdest = rdest2
16340 cdest = cdest2
16341 itc1 = 0
16342 itc2 = 0
16343 END IF
16344 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
16345 nskip = nskip + 1
16346 GOTO 50
16347 END IF
16348*
16349 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
16350 lda = ldadst
16351 ELSE
16352 lda = ldasrc
16353 END IF
16354 valptr = aptr + ipost + n * lda
16355 IF( verb .GT. 1 ) THEN
16356 IF( iam .EQ. 0 ) THEN
16357 WRITE(outnum, 6000)
16358 $ testnum, 'RUNNING', scope, top, m, n,
16359 $ ldasrc, ldadst, ldi, rdest2, cdest2,
16360 $ nprow, npcol
16361 END IF
16362 END IF
16363*
16364* If I am in scope
16365*
16366 testok = .true.
16367 IF( ingrid ) THEN
16368 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
16369 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
16370 $ (scope .EQ. 'A') ) THEN
16371*
16372 k = nerr
16373 DO 40 itr = itr1, itr2
16374 CALL blacs_set(context, 15, itr)
16375 DO 35 itc = itc1, itc2
16376 CALL blacs_set(context, 16, itc)
16377 DO 30 j = istart, istop
16378 IF( j.EQ.0) GOTO 30
16379 IF( setwhat.NE.0 )
16380 $ CALL blacs_set(context, setwhat, j)
16381*
16382*
16383* generate and pad matrix A
16384*
16385 CALL dinitmat('G','-', m, n, mem(preaptr),
16386 $ lda, ipre, ipost,
16387 $ checkval, testnum,
16388 $ myrow, mycol )
16389*
16390* If they exist, pad RA and CA arrays
16391*
16392 IF( ldi .NE. -1 ) THEN
16393 DO 15 i = 1, n*ldi + ipre + ipost
16394 rmem(i) = icheckval
16395 cmem(i) = icheckval
16396 15 CONTINUE
16397 raptr = 1 + ipre
16398 captr = 1 + ipre
16399 ELSE
16400 DO 20 i = 1, ipre+ipost
16401 rmem(i) = icheckval
16402 cmem(i) = icheckval
16403 20 CONTINUE
16404 raptr = 1
16405 captr = 1
16406 END IF
16407*
16408 CALL dgamx2d(context, scope, top, m, n,
16409 $ mem(aptr), lda, rmem(raptr),
16410 $ cmem(captr), ldi,
16411 $ rdest2, cdest2)
16412*
16413* If I've got the answer, check for errors in
16414* matrix or padding
16415*
16416 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
16417 $ .OR. allrcv ) THEN
16418 CALL dchkpad('G','-', m, n,
16419 $ mem(preaptr), lda, rdest,
16420 $ cdest, myrow, mycol,
16421 $ ipre, ipost, checkval,
16422 $ testnum, maxerr, nerr,
16423 $ mem(erriptr),mem(errdptr))
16424 CALL dchkamx(scope, context, m, n,
16425 $ mem(aptr), lda,
16426 $ rmem(raptr), cmem(captr),
16427 $ ldi, testnum, maxerr,nerr,
16428 $ mem(erriptr),mem(errdptr),
16429 $ iseed, mem(valptr))
16430 CALL drcchk(ipre, ipost, icheckval,
16431 $ m, n, rmem, cmem, ldi,
16432 $ myrow, mycol, testnum,
16433 $ maxerr, nerr,
16434 $ mem(erriptr), mem(errdptr))
16435 END IF
16436 30 CONTINUE
16437 CALL blacs_set(context, 16, 0)
16438 35 CONTINUE
16439 CALL blacs_set(context, 15, 0)
16440 40 CONTINUE
16441 testok = ( k .EQ. nerr )
16442 END IF
16443 END IF
16444*
16445 IF( verb .GT. 1 ) THEN
16446 i = nerr
16447 CALL dbtcheckin(0, outnum, maxerr, nerr,
16448 $ mem(erriptr), mem(errdptr), iseed)
16449 IF( iam .EQ. 0 ) THEN
16450 IF( testok .AND. nerr.EQ.i ) THEN
16451 WRITE(outnum,6000)testnum,'PASSED ',
16452 $ scope, top, m, n, ldasrc,
16453 $ ldadst, ldi, rdest2, cdest2,
16454 $ nprow, npcol
16455 ELSE
16456 nfail = nfail + 1
16457 WRITE(outnum,6000)testnum,'FAILED ',
16458 $ scope, top, m, n, ldasrc,
16459 $ ldadst, ldi, rdest2, cdest2,
16460 $ nprow, npcol
16461 END IF
16462 END IF
16463*
16464* Once we've printed out errors, can re-use buf space
16465*
16466 nerr = 0
16467 END IF
16468 50 CONTINUE
16469 60 CONTINUE
16470 70 CONTINUE
16471 80 CONTINUE
16472 90 CONTINUE
16473*
16474 IF( verb .LT. 2 ) THEN
16475 nfail = testnum
16476 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
16477 $ mem(errdptr), iseed )
16478 END IF
16479 IF( iam .EQ. 0 ) THEN
16480 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
16481 IF( nfail+nskip .EQ. 0 ) THEN
16482 WRITE(outnum, 7000 ) testnum
16483 ELSE
16484 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
16485 $ nskip, nfail
16486 END IF
16487 END IF
16488*
16489* Log whether their were any failures
16490*
16491 testok = allpass( (nfail.EQ.0) )
16492*
16493 1000 FORMAT('DOUBLE PRECISION AMX TESTS: BEGIN.' )
16494 2000 FORMAT(1x,a7,3x,10i6)
16495 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
16496 $ 5x,a1,5x,a1)
16497 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
16498 $ 'RDEST CDEST P Q')
16499 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
16500 $ '----- ----- ---- ----')
16501 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
16502 7000 FORMAT('DOUBLE PRECISION AMX TESTS: PASSED ALL',
16503 $ i5, ' TESTS.')
16504 8000 FORMAT('DOUBLE PRECISION AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
16505 $ i5,' SKIPPED,',i5,' FAILED.')
16506*
16507 RETURN
16508*
16509* End of DTESTAMX.
16510*
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
dchkamx
subroutine dchkamx(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:16685
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
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: