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

◆ csumtest()

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

Definition at line 13283 of file blacstest.f.

13287*
13288* -- BLACS tester (version 1.0) --
13289* University of Tennessee
13290* December 15, 1994
13291*
13292*
13293* .. Scalar Arguments ..
13294 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
13295 $ TOPSCOHRNT, TOPSREPEAT, VERB
13296* ..
13297* .. Array Arguments ..
13298 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
13299 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
13300 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
13301 INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
13302 COMPLEX MEM(MEMLEN)
13303* ..
13304*
13305* Purpose
13306* =======
13307* CTESTSUM: Test complex SUM COMBINE
13308*
13309* Arguments
13310* =========
13311* OUTNUM (input) INTEGER
13312* The device number to write output to.
13313*
13314* VERB (input) INTEGER
13315* The level of verbosity (how much printing to do).
13316*
13317* NSCOPE (input) INTEGER
13318* The number of scopes to be tested.
13319*
13320* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
13321* Values of the scopes to be tested.
13322*
13323* NTOP (input) INTEGER
13324* The number of topologies to be tested.
13325*
13326* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
13327* Values of the topologies to be tested.
13328*
13329* NMAT (input) INTEGER
13330* The number of matrices to be tested.
13331*
13332* M0 (input) INTEGER array of dimension (NMAT)
13333* Values of M to be tested.
13334*
13335* M0 (input) INTEGER array of dimension (NMAT)
13336* Values of M to be tested.
13337*
13338* N0 (input) INTEGER array of dimension (NMAT)
13339* Values of N to be tested.
13340*
13341* LDAS0 (input) INTEGER array of dimension (NMAT)
13342* Values of LDAS (leading dimension of A on source process)
13343* to be tested.
13344*
13345* LDAD0 (input) INTEGER array of dimension (NMAT)
13346* Values of LDAD (leading dimension of A on destination
13347* process) to be tested.
13348* NDEST (input) INTEGER
13349* The number of destinations to be tested.
13350*
13351* RDEST0 (input) INTEGER array of dimension (NNDEST)
13352* Values of RDEST (row coordinate of destination) to be
13353* tested.
13354*
13355* CDEST0 (input) INTEGER array of dimension (NNDEST)
13356* Values of CDEST (column coordinate of destination) to be
13357* tested.
13358*
13359* NGRID (input) INTEGER
13360* The number of process grids to be tested.
13361*
13362* CONTEXT0 (input) INTEGER array of dimension (NGRID)
13363* The BLACS context handles corresponding to the grids.
13364*
13365* P0 (input) INTEGER array of dimension (NGRID)
13366* Values of P (number of process rows, NPROW).
13367*
13368* Q0 (input) INTEGER array of dimension (NGRID)
13369* Values of Q (number of process columns, NPCOL).
13370*
13371* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
13372* Workspace used to hold each process's random number SEED.
13373* This requires NPROCS (number of processor) elements.
13374* If VERB < 2, this workspace also serves to indicate which
13375* tests fail. This requires workspace of NTESTS
13376* (number of tests performed).
13377*
13378* MEM (workspace) COMPLEX array of dimension (MEMLEN)
13379* Used for all other workspaces, including the matrix A,
13380* and its pre and post padding.
13381*
13382* MEMLEN (input) INTEGER
13383* The length, in elements, of MEM.
13384*
13385* =====================================================================
13386*
13387* .. External Functions ..
13388 LOGICAL ALLPASS, LSAME
13389 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
13390 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
13391* ..
13392* .. External Subroutines ..
13393 EXTERNAL blacs_gridinfo, cgsum2d
13394 EXTERNAL cinitmat, cchkpad, cbtcheckin
13395* ..
13396* .. Local Scalars ..
13397 CHARACTER*1 SCOPE, TOP
13398 LOGICAL INGRID, TESTOK, ALLRCV
13399 INTEGER APTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR, ERRIPTR, I,
13400 $ IAM, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
13401 $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
13402 $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
13403 $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
13404 $ TESTNUM
13405 COMPLEX CHECKVAL
13406* ..
13407* .. Executable Statements ..
13408*
13409* Choose padding value, and make it unique
13410*
13411 checkval = cmplx( -0.91e0, -0.71e0 )
13412 iam = ibtmyproc()
13413 checkval = iam * checkval
13414 isize = ibtsizeof('I')
13415 csize = ibtsizeof('C')
13416*
13417* Verify file parameters
13418*
13419 IF( iam .EQ. 0 ) THEN
13420 WRITE(outnum, *) ' '
13421 WRITE(outnum, *) ' '
13422 WRITE(outnum, 1000 )
13423 IF( verb .GT. 0 ) THEN
13424 WRITE(outnum,*) ' '
13425 WRITE(outnum, 2000) 'NSCOPE:', nscope
13426 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
13427 WRITE(outnum, 2000) 'TReps :', topsrepeat
13428 WRITE(outnum, 2000) 'TCohr :', topscohrnt
13429 WRITE(outnum, 2000) 'NTOP :', ntop
13430 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
13431 WRITE(outnum, 2000) 'NMAT :', nmat
13432 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
13433 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
13434 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
13435 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
13436 WRITE(outnum, 2000) 'NDEST :', ndest
13437 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
13438 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
13439 WRITE(outnum, 2000) 'NGRIDS:', ngrid
13440 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
13441 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
13442 WRITE(outnum, 2000) 'VERB :', verb
13443 WRITE(outnum,*) ' '
13444 END IF
13445 IF( verb .GT. 1 ) THEN
13446 WRITE(outnum,4000)
13447 WRITE(outnum,5000)
13448 END IF
13449 END IF
13450 IF (topsrepeat.EQ.0) THEN
13451 itr1 = 0
13452 itr2 = 0
13453 ELSE IF (topsrepeat.EQ.1) THEN
13454 itr1 = 1
13455 itr2 = 1
13456 ELSE
13457 itr1 = 0
13458 itr2 = 1
13459 END IF
13460*
13461* Find biggest matrix, so we know where to stick error info
13462*
13463 i = 0
13464 DO 10 ima = 1, nmat
13465 ipad = 4 * m0(ima)
13466 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
13467 IF( k .GT. i ) i = k
13468 10 CONTINUE
13469 maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
13470 IF( maxerr .LT. 1 ) THEN
13471 WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
13472 CALL blacs_abort(-1, 1)
13473 END IF
13474 errdptr = i + 1
13475 erriptr = errdptr + maxerr
13476 nerr = 0
13477 testnum = 0
13478 nfail = 0
13479 nskip = 0
13480*
13481* Loop over grids of matrix
13482*
13483 DO 90 igr = 1, ngrid
13484*
13485* allocate process grid for the next batch of tests
13486*
13487 context = context0(igr)
13488 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
13489 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
13490*
13491 DO 80 isc = 1, nscope
13492 scope = scope0(isc)
13493 DO 70 ito = 1, ntop
13494 top = top0(ito)
13495*
13496* If testing multiring ('M') or general tree ('T'), need to
13497* loop over calls to BLACS_SET to do full test
13498*
13499 IF( lsame(top, 'M') ) THEN
13500 setwhat = 13
13501 IF( scope .EQ. 'R' ) THEN
13502 istart = -(npcol - 1)
13503 istop = -istart
13504 ELSE IF (scope .EQ. 'C') THEN
13505 istart = -(nprow - 1)
13506 istop = -istart
13507 ELSE
13508 istart = -(nprow*npcol - 1)
13509 istop = -istart
13510 ENDIF
13511 ELSE IF( lsame(top, 'T') ) THEN
13512 setwhat = 14
13513 istart = 1
13514 IF( scope .EQ. 'R' ) THEN
13515 istop = npcol - 1
13516 ELSE IF (scope .EQ. 'C') THEN
13517 istop = nprow - 1
13518 ELSE
13519 istop = nprow*npcol - 1
13520 ENDIF
13521 ELSE
13522 setwhat = 0
13523 istart = 1
13524 istop = 1
13525 ENDIF
13526 DO 60 ima = 1, nmat
13527 m = m0(ima)
13528 n = n0(ima)
13529 ldasrc = ldas0(ima)
13530 ldadst = ldad0(ima)
13531 ipre = 2 * m
13532 ipost = ipre
13533 preaptr = 1
13534 aptr = preaptr + ipre
13535*
13536 DO 50 ide = 1, ndest
13537 testnum = testnum + 1
13538 rdest2 = rdest0(ide)
13539 cdest2 = cdest0(ide)
13540*
13541* If everyone gets the answer, create some bogus rdest/cdest
13542* so IF's are easier
13543*
13544 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
13545 IF( allrcv ) THEN
13546 rdest = nprow - 1
13547 cdest = npcol - 1
13548 IF (topscohrnt.EQ.0) THEN
13549 itr1 = 0
13550 itr2 = 0
13551 ELSE IF (topscohrnt.EQ.1) THEN
13552 itr1 = 1
13553 itr2 = 1
13554 ELSE
13555 itr1 = 0
13556 itr2 = 1
13557 END IF
13558 ELSE
13559 rdest = rdest2
13560 cdest = cdest2
13561 itc1 = 0
13562 itc2 = 0
13563 END IF
13564 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
13565 nskip = nskip + 1
13566 GOTO 50
13567 END IF
13568*
13569 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
13570 lda = ldadst
13571 ELSE
13572 lda = ldasrc
13573 END IF
13574 IF( verb .GT. 1 ) THEN
13575 IF( iam .EQ. 0 ) THEN
13576 WRITE(outnum, 6000)
13577 $ testnum, 'RUNNING', scope, top, m, n,
13578 $ ldasrc, ldadst, rdest2, cdest2,
13579 $ nprow, npcol
13580 END IF
13581 END IF
13582*
13583* If I am in scope
13584*
13585 testok = .true.
13586 IF( ingrid ) THEN
13587 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
13588 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
13589 $ (scope .EQ. 'A') ) THEN
13590*
13591 k = nerr
13592 DO 40 itr = itr1, itr2
13593 CALL blacs_set(context, 15, itr)
13594 DO 35 itc = itc1, itc2
13595 CALL blacs_set(context, 16, itc)
13596 DO 30 j = istart, istop
13597 IF( j.EQ.0) GOTO 30
13598 IF( setwhat.NE.0 )
13599 $ CALL blacs_set(context, setwhat, j)
13600*
13601*
13602* generate and pad matrix A
13603*
13604 CALL cinitmat('G','-', m, n, mem(preaptr),
13605 $ lda, ipre, ipost,
13606 $ checkval, testnum,
13607 $ myrow, mycol )
13608*
13609 CALL cgsum2d(context, scope, top, m, n,
13610 $ mem(aptr), lda, rdest2,
13611 $ cdest2)
13612*
13613* If I've got the answer, check for errors in
13614* matrix or padding
13615*
13616 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
13617 $ .OR. allrcv ) THEN
13618 CALL cchkpad('G','-', m, n,
13619 $ mem(preaptr), lda, rdest,
13620 $ cdest, myrow, mycol,
13621 $ ipre, ipost, checkval,
13622 $ testnum, maxerr, nerr,
13623 $ mem(erriptr),mem(errdptr))
13624 CALL cchksum(scope, context, m, n,
13625 $ mem(aptr), lda,
13626 $ testnum, maxerr, nerr,
13627 $ mem(erriptr),mem(errdptr),
13628 $ iseed)
13629 END IF
13630 30 CONTINUE
13631 CALL blacs_set(context, 16, 0)
13632 35 CONTINUE
13633 CALL blacs_set(context, 15, 0)
13634 40 CONTINUE
13635 testok = ( k .EQ. nerr )
13636 END IF
13637 END IF
13638*
13639 IF( verb .GT. 1 ) THEN
13640 i = nerr
13641 CALL cbtcheckin(0, outnum, maxerr, nerr,
13642 $ mem(erriptr), mem(errdptr), iseed)
13643 IF( iam .EQ. 0 ) THEN
13644 IF( testok .AND. nerr.EQ.i ) THEN
13645 WRITE(outnum,6000)testnum,'PASSED ',
13646 $ scope, top, m, n, ldasrc,
13647 $ ldadst, rdest2, cdest2,
13648 $ nprow, npcol
13649 ELSE
13650 nfail = nfail + 1
13651 WRITE(outnum,6000)testnum,'FAILED ',
13652 $ scope, top, m, n, ldasrc,
13653 $ ldadst, rdest2, cdest2,
13654 $ nprow, npcol
13655 END IF
13656 END IF
13657*
13658* Once we've printed out errors, can re-use buf space
13659*
13660 nerr = 0
13661 END IF
13662 50 CONTINUE
13663 60 CONTINUE
13664 70 CONTINUE
13665 80 CONTINUE
13666 90 CONTINUE
13667*
13668 IF( verb .LT. 2 ) THEN
13669 nfail = testnum
13670 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
13671 $ mem(errdptr), iseed )
13672 END IF
13673 IF( iam .EQ. 0 ) THEN
13674 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
13675 IF( nfail+nskip .EQ. 0 ) THEN
13676 WRITE(outnum, 7000 ) testnum
13677 ELSE
13678 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
13679 $ nskip, nfail
13680 END IF
13681 END IF
13682*
13683* Log whether their were any failures
13684*
13685 testok = allpass( (nfail.EQ.0) )
13686*
13687 1000 FORMAT('COMPLEX SUM TESTS: BEGIN.' )
13688 2000 FORMAT(1x,a7,3x,10i6)
13689 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
13690 $ 5x,a1,5x,a1)
13691 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
13692 $ 'RDEST CDEST P Q')
13693 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
13694 $ '----- ----- ---- ----')
13695 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
13696 7000 FORMAT('COMPLEX SUM TESTS: PASSED ALL',
13697 $ i5, ' TESTS.')
13698 8000 FORMAT('COMPLEX SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
13699 $ i5,' SKIPPED,',i5,' FAILED.')
13700*
13701 RETURN
13702*
13703* End of CTESTSUM.
13704*
cmplx
float cmplx[2]
Definition pblas.h:136
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
cchksum
subroutine cchksum(scope, ictxt, m, n, a, lda, testnum, maxerr, nerr, erribuf, errdbuf, iseed)
Definition blacstest.f:13715
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: