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

◆ zamntest()

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

Definition at line 21076 of file blacstest.f.

21081*
21082* -- BLACS tester (version 1.0) --
21083* University of Tennessee
21084* December 15, 1994
21085*
21086*
21087* .. Scalar Arguments ..
21088 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
21089 $ TOPSCOHRNT, TOPSREPEAT, VERB
21090* ..
21091* .. Array Arguments ..
21092 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
21093 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
21094 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
21095 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
21096 DOUBLE COMPLEX MEM(MEMLEN)
21097* ..
21098*
21099* Purpose
21100* =======
21101* ZTESTAMN: Test double complex AMN COMBINE
21102*
21103* Arguments
21104* =========
21105* OUTNUM (input) INTEGER
21106* The device number to write output to.
21107*
21108* VERB (input) INTEGER
21109* The level of verbosity (how much printing to do).
21110*
21111* NSCOPE (input) INTEGER
21112* The number of scopes to be tested.
21113*
21114* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
21115* Values of the scopes to be tested.
21116*
21117* NTOP (input) INTEGER
21118* The number of topologies to be tested.
21119*
21120* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
21121* Values of the topologies to be tested.
21122*
21123* NMAT (input) INTEGER
21124* The number of matrices to be tested.
21125*
21126* M0 (input) INTEGER array of dimension (NMAT)
21127* Values of M to be tested.
21128*
21129* M0 (input) INTEGER array of dimension (NMAT)
21130* Values of M to be tested.
21131*
21132* N0 (input) INTEGER array of dimension (NMAT)
21133* Values of N to be tested.
21134*
21135* LDAS0 (input) INTEGER array of dimension (NMAT)
21136* Values of LDAS (leading dimension of A on source process)
21137* to be tested.
21138*
21139* LDAD0 (input) INTEGER array of dimension (NMAT)
21140* Values of LDAD (leading dimension of A on destination
21141* process) to be tested.
21142* LDI0 (input) INTEGER array of dimension (NMAT)
21143* Values of LDI (leading dimension of RA/CA) to be tested.
21144* If LDI == -1, these RA/CA should not be accessed.
21145*
21146* NDEST (input) INTEGER
21147* The number of destinations to be tested.
21148*
21149* RDEST0 (input) INTEGER array of dimension (NNDEST)
21150* Values of RDEST (row coordinate of destination) to be
21151* tested.
21152*
21153* CDEST0 (input) INTEGER array of dimension (NNDEST)
21154* Values of CDEST (column coordinate of destination) to be
21155* tested.
21156*
21157* NGRID (input) INTEGER
21158* The number of process grids to be tested.
21159*
21160* CONTEXT0 (input) INTEGER array of dimension (NGRID)
21161* The BLACS context handles corresponding to the grids.
21162*
21163* P0 (input) INTEGER array of dimension (NGRID)
21164* Values of P (number of process rows, NPROW).
21165*
21166* Q0 (input) INTEGER array of dimension (NGRID)
21167* Values of Q (number of process columns, NPCOL).
21168*
21169* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
21170* Workspace used to hold each process's random number SEED.
21171* This requires NPROCS (number of processor) elements.
21172* If VERB < 2, this workspace also serves to indicate which
21173* tests fail. This requires workspace of NTESTS
21174* (number of tests performed).
21175*
21176* RMEM (workspace) INTEGER array of dimension (RCLEN)
21177* Used for all RA arrays, and their pre and post padding.
21178*
21179* CMEM (workspace) INTEGER array of dimension (RCLEN)
21180* Used for all CA arrays, and their pre and post padding.
21181*
21182* RCLEN (input) INTEGER
21183* The length, in elements, of RMEM and CMEM.
21184*
21185* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
21186* Used for all other workspaces, including the matrix A,
21187* and its pre and post padding.
21188*
21189* MEMLEN (input) INTEGER
21190* The length, in elements, of MEM.
21191*
21192* =====================================================================
21193*
21194* .. External Functions ..
21195 LOGICAL ALLPASS, LSAME
21196 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
21197 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
21198* ..
21199* .. External Subroutines ..
21200 EXTERNAL blacs_gridinfo, zgamn2d
21201 EXTERNAL zinitmat, zchkpad, zbtcheckin
21202* ..
21203* .. Local Scalars ..
21204 CHARACTER*1 SCOPE, TOP
21205 LOGICAL INGRID, TESTOK, ALLRCV
21206 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
21207 $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
21208 $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
21209 $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
21210 $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
21211 $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR, ZSIZE
21212 DOUBLE COMPLEX CHECKVAL
21213* ..
21214* .. Executable Statements ..
21215*
21216* Choose padding value, and make it unique
21217*
21218 checkval = dcmplx( -9.11d0, -9.21d0 )
21219 iam = ibtmyproc()
21220 checkval = iam * checkval
21221 isize = ibtsizeof('I')
21222 zsize = ibtsizeof('Z')
21223 icheckval = -iam
21224*
21225* Verify file parameters
21226*
21227 IF( iam .EQ. 0 ) THEN
21228 WRITE(outnum, *) ' '
21229 WRITE(outnum, *) ' '
21230 WRITE(outnum, 1000 )
21231 IF( verb .GT. 0 ) THEN
21232 WRITE(outnum,*) ' '
21233 WRITE(outnum, 2000) 'NSCOPE:', nscope
21234 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
21235 WRITE(outnum, 2000) 'TReps :', topsrepeat
21236 WRITE(outnum, 2000) 'TCohr :', topscohrnt
21237 WRITE(outnum, 2000) 'NTOP :', ntop
21238 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
21239 WRITE(outnum, 2000) 'NMAT :', nmat
21240 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
21241 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
21242 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
21243 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
21244 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
21245 WRITE(outnum, 2000) 'NDEST :', ndest
21246 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
21247 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
21248 WRITE(outnum, 2000) 'NGRIDS:', ngrid
21249 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
21250 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
21251 WRITE(outnum, 2000) 'VERB :', verb
21252 WRITE(outnum,*) ' '
21253 END IF
21254 IF( verb .GT. 1 ) THEN
21255 WRITE(outnum,4000)
21256 WRITE(outnum,5000)
21257 END IF
21258 END IF
21259 IF (topsrepeat.EQ.0) THEN
21260 itr1 = 0
21261 itr2 = 0
21262 ELSE IF (topsrepeat.EQ.1) THEN
21263 itr1 = 1
21264 itr2 = 1
21265 ELSE
21266 itr1 = 0
21267 itr2 = 1
21268 END IF
21269*
21270* Find biggest matrix, so we know where to stick error info
21271*
21272 i = 0
21273 DO 10 ima = 1, nmat
21274 ipad = 4 * m0(ima)
21275 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
21276 IF( k .GT. i ) i = k
21277 10 CONTINUE
21278 i = i + ibtnprocs()
21279 maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
21280 IF( maxerr .LT. 1 ) THEN
21281 WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
21282 CALL blacs_abort(-1, 1)
21283 END IF
21284 errdptr = i + 1
21285 erriptr = errdptr + maxerr
21286 nerr = 0
21287 testnum = 0
21288 nfail = 0
21289 nskip = 0
21290*
21291* Loop over grids of matrix
21292*
21293 DO 90 igr = 1, ngrid
21294*
21295* allocate process grid for the next batch of tests
21296*
21297 context = context0(igr)
21298 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
21299 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
21300*
21301 DO 80 isc = 1, nscope
21302 scope = scope0(isc)
21303 DO 70 ito = 1, ntop
21304 top = top0(ito)
21305*
21306* If testing multiring ('M') or general tree ('T'), need to
21307* loop over calls to BLACS_SET to do full test
21308*
21309 IF( lsame(top, 'M') ) THEN
21310 setwhat = 13
21311 IF( scope .EQ. 'R' ) THEN
21312 istart = -(npcol - 1)
21313 istop = -istart
21314 ELSE IF (scope .EQ. 'C') THEN
21315 istart = -(nprow - 1)
21316 istop = -istart
21317 ELSE
21318 istart = -(nprow*npcol - 1)
21319 istop = -istart
21320 ENDIF
21321 ELSE IF( lsame(top, 'T') ) THEN
21322 setwhat = 14
21323 istart = 1
21324 IF( scope .EQ. 'R' ) THEN
21325 istop = npcol - 1
21326 ELSE IF (scope .EQ. 'C') THEN
21327 istop = nprow - 1
21328 ELSE
21329 istop = nprow*npcol - 1
21330 ENDIF
21331 ELSE
21332 setwhat = 0
21333 istart = 1
21334 istop = 1
21335 ENDIF
21336 DO 60 ima = 1, nmat
21337 m = m0(ima)
21338 n = n0(ima)
21339 ldasrc = ldas0(ima)
21340 ldadst = ldad0(ima)
21341 ldi = ldi0(ima)
21342 ipre = 2 * m
21343 ipost = ipre
21344 preaptr = 1
21345 aptr = preaptr + ipre
21346*
21347 DO 50 ide = 1, ndest
21348 testnum = testnum + 1
21349 rdest2 = rdest0(ide)
21350 cdest2 = cdest0(ide)
21351*
21352* If everyone gets the answer, create some bogus rdest/cdest
21353* so IF's are easier
21354*
21355 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
21356 IF( allrcv ) THEN
21357 rdest = nprow - 1
21358 cdest = npcol - 1
21359 IF (topscohrnt.EQ.0) THEN
21360 itr1 = 0
21361 itr2 = 0
21362 ELSE IF (topscohrnt.EQ.1) THEN
21363 itr1 = 1
21364 itr2 = 1
21365 ELSE
21366 itr1 = 0
21367 itr2 = 1
21368 END IF
21369 ELSE
21370 rdest = rdest2
21371 cdest = cdest2
21372 itc1 = 0
21373 itc2 = 0
21374 END IF
21375 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
21376 nskip = nskip + 1
21377 GOTO 50
21378 END IF
21379*
21380 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
21381 lda = ldadst
21382 ELSE
21383 lda = ldasrc
21384 END IF
21385 valptr = aptr + ipost + n * lda
21386 IF( verb .GT. 1 ) THEN
21387 IF( iam .EQ. 0 ) THEN
21388 WRITE(outnum, 6000)
21389 $ testnum, 'RUNNING', scope, top, m, n,
21390 $ ldasrc, ldadst, ldi, rdest2, cdest2,
21391 $ nprow, npcol
21392 END IF
21393 END IF
21394*
21395* If I am in scope
21396*
21397 testok = .true.
21398 IF( ingrid ) THEN
21399 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
21400 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
21401 $ (scope .EQ. 'A') ) THEN
21402*
21403 k = nerr
21404 DO 40 itr = itr1, itr2
21405 CALL blacs_set(context, 15, itr)
21406 DO 35 itc = itc1, itc2
21407 CALL blacs_set(context, 16, itc)
21408 DO 30 j = istart, istop
21409 IF( j.EQ.0) GOTO 30
21410 IF( setwhat.NE.0 )
21411 $ CALL blacs_set(context, setwhat, j)
21412*
21413*
21414* generate and pad matrix A
21415*
21416 CALL zinitmat('G','-', m, n, mem(preaptr),
21417 $ lda, ipre, ipost,
21418 $ checkval, testnum,
21419 $ myrow, mycol )
21420*
21421* If they exist, pad RA and CA arrays
21422*
21423 IF( ldi .NE. -1 ) THEN
21424 DO 15 i = 1, n*ldi + ipre + ipost
21425 rmem(i) = icheckval
21426 cmem(i) = icheckval
21427 15 CONTINUE
21428 raptr = 1 + ipre
21429 captr = 1 + ipre
21430 ELSE
21431 DO 20 i = 1, ipre+ipost
21432 rmem(i) = icheckval
21433 cmem(i) = icheckval
21434 20 CONTINUE
21435 raptr = 1
21436 captr = 1
21437 END IF
21438*
21439 CALL zgamn2d(context, scope, top, m, n,
21440 $ mem(aptr), lda, rmem(raptr),
21441 $ cmem(captr), ldi,
21442 $ rdest2, cdest2)
21443*
21444* If I've got the answer, check for errors in
21445* matrix or padding
21446*
21447 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
21448 $ .OR. allrcv ) THEN
21449 CALL zchkpad('G','-', m, n,
21450 $ mem(preaptr), lda, rdest,
21451 $ cdest, myrow, mycol,
21452 $ ipre, ipost, checkval,
21453 $ testnum, maxerr, nerr,
21454 $ mem(erriptr),mem(errdptr))
21455 CALL zchkamn(scope, context, m, n,
21456 $ mem(aptr), lda,
21457 $ rmem(raptr), cmem(captr),
21458 $ ldi, testnum, maxerr,nerr,
21459 $ mem(erriptr),mem(errdptr),
21460 $ iseed, mem(valptr))
21461 CALL zrcchk(ipre, ipost, icheckval,
21462 $ m, n, rmem, cmem, ldi,
21463 $ myrow, mycol, testnum,
21464 $ maxerr, nerr,
21465 $ mem(erriptr), mem(errdptr))
21466 END IF
21467 30 CONTINUE
21468 CALL blacs_set(context, 16, 0)
21469 35 CONTINUE
21470 CALL blacs_set(context, 15, 0)
21471 40 CONTINUE
21472 testok = ( k .EQ. nerr )
21473 END IF
21474 END IF
21475*
21476 IF( verb .GT. 1 ) THEN
21477 i = nerr
21478 CALL zbtcheckin(0, outnum, maxerr, nerr,
21479 $ mem(erriptr), mem(errdptr), iseed)
21480 IF( iam .EQ. 0 ) THEN
21481 IF( testok .AND. nerr.EQ.i ) THEN
21482 WRITE(outnum,6000)testnum,'PASSED ',
21483 $ scope, top, m, n, ldasrc,
21484 $ ldadst, ldi, rdest2, cdest2,
21485 $ nprow, npcol
21486 ELSE
21487 nfail = nfail + 1
21488 WRITE(outnum,6000)testnum,'FAILED ',
21489 $ scope, top, m, n, ldasrc,
21490 $ ldadst, ldi, rdest2, cdest2,
21491 $ nprow, npcol
21492 END IF
21493 END IF
21494*
21495* Once we've printed out errors, can re-use buf space
21496*
21497 nerr = 0
21498 END IF
21499 50 CONTINUE
21500 60 CONTINUE
21501 70 CONTINUE
21502 80 CONTINUE
21503 90 CONTINUE
21504*
21505 IF( verb .LT. 2 ) THEN
21506 nfail = testnum
21507 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
21508 $ mem(errdptr), iseed )
21509 END IF
21510 IF( iam .EQ. 0 ) THEN
21511 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
21512 IF( nfail+nskip .EQ. 0 ) THEN
21513 WRITE(outnum, 7000 ) testnum
21514 ELSE
21515 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
21516 $ nskip, nfail
21517 END IF
21518 END IF
21519*
21520* Log whether their were any failures
21521*
21522 testok = allpass( (nfail.EQ.0) )
21523*
21524 1000 FORMAT('DOUBLE COMPLEX AMN TESTS: BEGIN.' )
21525 2000 FORMAT(1x,a7,3x,10i6)
21526 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
21527 $ 5x,a1,5x,a1)
21528 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
21529 $ 'RDEST CDEST P Q')
21530 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
21531 $ '----- ----- ---- ----')
21532 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
21533 7000 FORMAT('DOUBLE COMPLEX AMN TESTS: PASSED ALL',
21534 $ i5, ' TESTS.')
21535 8000 FORMAT('DOUBLE COMPLEX AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
21536 $ i5,' SKIPPED,',i5,' FAILED.')
21537*
21538 RETURN
21539*
21540* End of ZTESTAMN.
21541*
zrcchk
subroutine zrcchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:18148
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
zchkamn
subroutine zchkamn(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:21547
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: