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

◆ ssumtest()

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

Definition at line 12127 of file blacstest.f.

12131*
12132* -- BLACS tester (version 1.0) --
12133* University of Tennessee
12134* December 15, 1994
12135*
12136*
12137* .. Scalar Arguments ..
12138 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
12139 $ TOPSCOHRNT, TOPSREPEAT, VERB
12140* ..
12141* .. Array Arguments ..
12142 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
12143 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
12144 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
12145 INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
12146 REAL MEM(MEMLEN)
12147* ..
12148*
12149* Purpose
12150* =======
12151* STESTSUM: Test real SUM COMBINE
12152*
12153* Arguments
12154* =========
12155* OUTNUM (input) INTEGER
12156* The device number to write output to.
12157*
12158* VERB (input) INTEGER
12159* The level of verbosity (how much printing to do).
12160*
12161* NSCOPE (input) INTEGER
12162* The number of scopes to be tested.
12163*
12164* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
12165* Values of the scopes to be tested.
12166*
12167* NTOP (input) INTEGER
12168* The number of topologies to be tested.
12169*
12170* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
12171* Values of the topologies to be tested.
12172*
12173* NMAT (input) INTEGER
12174* The number of matrices to be tested.
12175*
12176* M0 (input) INTEGER array of dimension (NMAT)
12177* Values of M to be tested.
12178*
12179* M0 (input) INTEGER array of dimension (NMAT)
12180* Values of M to be tested.
12181*
12182* N0 (input) INTEGER array of dimension (NMAT)
12183* Values of N to be tested.
12184*
12185* LDAS0 (input) INTEGER array of dimension (NMAT)
12186* Values of LDAS (leading dimension of A on source process)
12187* to be tested.
12188*
12189* LDAD0 (input) INTEGER array of dimension (NMAT)
12190* Values of LDAD (leading dimension of A on destination
12191* process) to be tested.
12192* NDEST (input) INTEGER
12193* The number of destinations to be tested.
12194*
12195* RDEST0 (input) INTEGER array of dimension (NNDEST)
12196* Values of RDEST (row coordinate of destination) to be
12197* tested.
12198*
12199* CDEST0 (input) INTEGER array of dimension (NNDEST)
12200* Values of CDEST (column coordinate of destination) to be
12201* tested.
12202*
12203* NGRID (input) INTEGER
12204* The number of process grids to be tested.
12205*
12206* CONTEXT0 (input) INTEGER array of dimension (NGRID)
12207* The BLACS context handles corresponding to the grids.
12208*
12209* P0 (input) INTEGER array of dimension (NGRID)
12210* Values of P (number of process rows, NPROW).
12211*
12212* Q0 (input) INTEGER array of dimension (NGRID)
12213* Values of Q (number of process columns, NPCOL).
12214*
12215* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
12216* Workspace used to hold each process's random number SEED.
12217* This requires NPROCS (number of processor) elements.
12218* If VERB < 2, this workspace also serves to indicate which
12219* tests fail. This requires workspace of NTESTS
12220* (number of tests performed).
12221*
12222* MEM (workspace) REAL array of dimension (MEMLEN)
12223* Used for all other workspaces, including the matrix A,
12224* and its pre and post padding.
12225*
12226* MEMLEN (input) INTEGER
12227* The length, in elements, of MEM.
12228*
12229* =====================================================================
12230*
12231* .. External Functions ..
12232 LOGICAL ALLPASS, LSAME
12233 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
12234 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
12235* ..
12236* .. External Subroutines ..
12237 EXTERNAL blacs_gridinfo, sgsum2d
12238 EXTERNAL sinitmat, schkpad, sbtcheckin
12239* ..
12240* .. Local Scalars ..
12241 CHARACTER*1 SCOPE, TOP
12242 LOGICAL INGRID, TESTOK, ALLRCV
12243 INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
12244 $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
12245 $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
12246 $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
12247 $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
12248 $ SSIZE, TESTNUM
12249 REAL CHECKVAL
12250* ..
12251* .. Executable Statements ..
12252*
12253* Choose padding value, and make it unique
12254*
12255 checkval = -0.61e0
12256 iam = ibtmyproc()
12257 checkval = iam * checkval
12258 isize = ibtsizeof('I')
12259 ssize = ibtsizeof('S')
12260*
12261* Verify file parameters
12262*
12263 IF( iam .EQ. 0 ) THEN
12264 WRITE(outnum, *) ' '
12265 WRITE(outnum, *) ' '
12266 WRITE(outnum, 1000 )
12267 IF( verb .GT. 0 ) THEN
12268 WRITE(outnum,*) ' '
12269 WRITE(outnum, 2000) 'NSCOPE:', nscope
12270 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
12271 WRITE(outnum, 2000) 'TReps :', topsrepeat
12272 WRITE(outnum, 2000) 'TCohr :', topscohrnt
12273 WRITE(outnum, 2000) 'NTOP :', ntop
12274 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
12275 WRITE(outnum, 2000) 'NMAT :', nmat
12276 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
12277 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
12278 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
12279 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
12280 WRITE(outnum, 2000) 'NDEST :', ndest
12281 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
12282 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
12283 WRITE(outnum, 2000) 'NGRIDS:', ngrid
12284 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
12285 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
12286 WRITE(outnum, 2000) 'VERB :', verb
12287 WRITE(outnum,*) ' '
12288 END IF
12289 IF( verb .GT. 1 ) THEN
12290 WRITE(outnum,4000)
12291 WRITE(outnum,5000)
12292 END IF
12293 END IF
12294 IF (topsrepeat.EQ.0) THEN
12295 itr1 = 0
12296 itr2 = 0
12297 ELSE IF (topsrepeat.EQ.1) THEN
12298 itr1 = 1
12299 itr2 = 1
12300 ELSE
12301 itr1 = 0
12302 itr2 = 1
12303 END IF
12304*
12305* Find biggest matrix, so we know where to stick error info
12306*
12307 i = 0
12308 DO 10 ima = 1, nmat
12309 ipad = 4 * m0(ima)
12310 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
12311 IF( k .GT. i ) i = k
12312 10 CONTINUE
12313 maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
12314 IF( maxerr .LT. 1 ) THEN
12315 WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
12316 CALL blacs_abort(-1, 1)
12317 END IF
12318 errdptr = i + 1
12319 erriptr = errdptr + maxerr
12320 nerr = 0
12321 testnum = 0
12322 nfail = 0
12323 nskip = 0
12324*
12325* Loop over grids of matrix
12326*
12327 DO 90 igr = 1, ngrid
12328*
12329* allocate process grid for the next batch of tests
12330*
12331 context = context0(igr)
12332 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
12333 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
12334*
12335 DO 80 isc = 1, nscope
12336 scope = scope0(isc)
12337 DO 70 ito = 1, ntop
12338 top = top0(ito)
12339*
12340* If testing multiring ('M') or general tree ('T'), need to
12341* loop over calls to BLACS_SET to do full test
12342*
12343 IF( lsame(top, 'M') ) THEN
12344 setwhat = 13
12345 IF( scope .EQ. 'R' ) THEN
12346 istart = -(npcol - 1)
12347 istop = -istart
12348 ELSE IF (scope .EQ. 'C') THEN
12349 istart = -(nprow - 1)
12350 istop = -istart
12351 ELSE
12352 istart = -(nprow*npcol - 1)
12353 istop = -istart
12354 ENDIF
12355 ELSE IF( lsame(top, 'T') ) THEN
12356 setwhat = 14
12357 istart = 1
12358 IF( scope .EQ. 'R' ) THEN
12359 istop = npcol - 1
12360 ELSE IF (scope .EQ. 'C') THEN
12361 istop = nprow - 1
12362 ELSE
12363 istop = nprow*npcol - 1
12364 ENDIF
12365 ELSE
12366 setwhat = 0
12367 istart = 1
12368 istop = 1
12369 ENDIF
12370 DO 60 ima = 1, nmat
12371 m = m0(ima)
12372 n = n0(ima)
12373 ldasrc = ldas0(ima)
12374 ldadst = ldad0(ima)
12375 ipre = 2 * m
12376 ipost = ipre
12377 preaptr = 1
12378 aptr = preaptr + ipre
12379*
12380 DO 50 ide = 1, ndest
12381 testnum = testnum + 1
12382 rdest2 = rdest0(ide)
12383 cdest2 = cdest0(ide)
12384*
12385* If everyone gets the answer, create some bogus rdest/cdest
12386* so IF's are easier
12387*
12388 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
12389 IF( allrcv ) THEN
12390 rdest = nprow - 1
12391 cdest = npcol - 1
12392 IF (topscohrnt.EQ.0) THEN
12393 itr1 = 0
12394 itr2 = 0
12395 ELSE IF (topscohrnt.EQ.1) THEN
12396 itr1 = 1
12397 itr2 = 1
12398 ELSE
12399 itr1 = 0
12400 itr2 = 1
12401 END IF
12402 ELSE
12403 rdest = rdest2
12404 cdest = cdest2
12405 itc1 = 0
12406 itc2 = 0
12407 END IF
12408 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
12409 nskip = nskip + 1
12410 GOTO 50
12411 END IF
12412*
12413 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
12414 lda = ldadst
12415 ELSE
12416 lda = ldasrc
12417 END IF
12418 IF( verb .GT. 1 ) THEN
12419 IF( iam .EQ. 0 ) THEN
12420 WRITE(outnum, 6000)
12421 $ testnum, 'RUNNING', scope, top, m, n,
12422 $ ldasrc, ldadst, rdest2, cdest2,
12423 $ nprow, npcol
12424 END IF
12425 END IF
12426*
12427* If I am in scope
12428*
12429 testok = .true.
12430 IF( ingrid ) THEN
12431 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
12432 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
12433 $ (scope .EQ. 'A') ) THEN
12434*
12435 k = nerr
12436 DO 40 itr = itr1, itr2
12437 CALL blacs_set(context, 15, itr)
12438 DO 35 itc = itc1, itc2
12439 CALL blacs_set(context, 16, itc)
12440 DO 30 j = istart, istop
12441 IF( j.EQ.0) GOTO 30
12442 IF( setwhat.NE.0 )
12443 $ CALL blacs_set(context, setwhat, j)
12444*
12445*
12446* generate and pad matrix A
12447*
12448 CALL sinitmat('G','-', m, n, mem(preaptr),
12449 $ lda, ipre, ipost,
12450 $ checkval, testnum,
12451 $ myrow, mycol )
12452*
12453 CALL sgsum2d(context, scope, top, m, n,
12454 $ mem(aptr), lda, rdest2,
12455 $ cdest2)
12456*
12457* If I've got the answer, check for errors in
12458* matrix or padding
12459*
12460 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
12461 $ .OR. allrcv ) THEN
12462 CALL schkpad('G','-', m, n,
12463 $ mem(preaptr), lda, rdest,
12464 $ cdest, myrow, mycol,
12465 $ ipre, ipost, checkval,
12466 $ testnum, maxerr, nerr,
12467 $ mem(erriptr),mem(errdptr))
12468 CALL schksum(scope, context, m, n,
12469 $ mem(aptr), lda,
12470 $ testnum, maxerr, nerr,
12471 $ mem(erriptr),mem(errdptr),
12472 $ iseed)
12473 END IF
12474 30 CONTINUE
12475 CALL blacs_set(context, 16, 0)
12476 35 CONTINUE
12477 CALL blacs_set(context, 15, 0)
12478 40 CONTINUE
12479 testok = ( k .EQ. nerr )
12480 END IF
12481 END IF
12482*
12483 IF( verb .GT. 1 ) THEN
12484 i = nerr
12485 CALL sbtcheckin(0, outnum, maxerr, nerr,
12486 $ mem(erriptr), mem(errdptr), iseed)
12487 IF( iam .EQ. 0 ) THEN
12488 IF( testok .AND. nerr.EQ.i ) THEN
12489 WRITE(outnum,6000)testnum,'PASSED ',
12490 $ scope, top, m, n, ldasrc,
12491 $ ldadst, rdest2, cdest2,
12492 $ nprow, npcol
12493 ELSE
12494 nfail = nfail + 1
12495 WRITE(outnum,6000)testnum,'FAILED ',
12496 $ scope, top, m, n, ldasrc,
12497 $ ldadst, rdest2, cdest2,
12498 $ nprow, npcol
12499 END IF
12500 END IF
12501*
12502* Once we've printed out errors, can re-use buf space
12503*
12504 nerr = 0
12505 END IF
12506 50 CONTINUE
12507 60 CONTINUE
12508 70 CONTINUE
12509 80 CONTINUE
12510 90 CONTINUE
12511*
12512 IF( verb .LT. 2 ) THEN
12513 nfail = testnum
12514 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
12515 $ mem(errdptr), iseed )
12516 END IF
12517 IF( iam .EQ. 0 ) THEN
12518 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
12519 IF( nfail+nskip .EQ. 0 ) THEN
12520 WRITE(outnum, 7000 ) testnum
12521 ELSE
12522 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
12523 $ nskip, nfail
12524 END IF
12525 END IF
12526*
12527* Log whether their were any failures
12528*
12529 testok = allpass( (nfail.EQ.0) )
12530*
12531 1000 FORMAT('REAL SUM TESTS: BEGIN.' )
12532 2000 FORMAT(1x,a7,3x,10i6)
12533 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
12534 $ 5x,a1,5x,a1)
12535 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
12536 $ 'RDEST CDEST P Q')
12537 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
12538 $ '----- ----- ---- ----')
12539 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
12540 7000 FORMAT('REAL SUM TESTS: PASSED ALL',
12541 $ i5, ' TESTS.')
12542 8000 FORMAT('REAL SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
12543 $ i5,' SKIPPED,',i5,' FAILED.')
12544*
12545 RETURN
12546*
12547* End of STESTSUM.
12548*
sbtcheckin
subroutine sbtcheckin(nftests, outnum, maxerr, nerr, ierr, sval, tfailed)
Definition blacstest.f:7341
schkpad
subroutine schkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:7746
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
schksum
subroutine schksum(scope, ictxt, m, n, a, lda, testnum, maxerr, nerr, erribuf, errdbuf, iseed)
Definition blacstest.f:12601
sinitmat
subroutine sinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:7463
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: