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

◆ isumtest()

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

Definition at line 11603 of file blacstest.f.

11607*
11608* -- BLACS tester (version 1.0) --
11609* University of Tennessee
11610* December 15, 1994
11611*
11612*
11613* .. Scalar Arguments ..
11614 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
11615 $ TOPSCOHRNT, TOPSREPEAT, VERB
11616* ..
11617* .. Array Arguments ..
11618 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
11619 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
11620 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
11621 INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
11622 INTEGER MEM(MEMLEN)
11623* ..
11624*
11625* Purpose
11626* =======
11627* ITESTSUM: Test integer SUM COMBINE
11628*
11629* Arguments
11630* =========
11631* OUTNUM (input) INTEGER
11632* The device number to write output to.
11633*
11634* VERB (input) INTEGER
11635* The level of verbosity (how much printing to do).
11636*
11637* NSCOPE (input) INTEGER
11638* The number of scopes to be tested.
11639*
11640* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
11641* Values of the scopes to be tested.
11642*
11643* NTOP (input) INTEGER
11644* The number of topologies to be tested.
11645*
11646* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
11647* Values of the topologies to be tested.
11648*
11649* NMAT (input) INTEGER
11650* The number of matrices to be tested.
11651*
11652* M0 (input) INTEGER array of dimension (NMAT)
11653* Values of M to be tested.
11654*
11655* M0 (input) INTEGER array of dimension (NMAT)
11656* Values of M to be tested.
11657*
11658* N0 (input) INTEGER array of dimension (NMAT)
11659* Values of N to be tested.
11660*
11661* LDAS0 (input) INTEGER array of dimension (NMAT)
11662* Values of LDAS (leading dimension of A on source process)
11663* to be tested.
11664*
11665* LDAD0 (input) INTEGER array of dimension (NMAT)
11666* Values of LDAD (leading dimension of A on destination
11667* process) to be tested.
11668* NDEST (input) INTEGER
11669* The number of destinations to be tested.
11670*
11671* RDEST0 (input) INTEGER array of dimension (NNDEST)
11672* Values of RDEST (row coordinate of destination) to be
11673* tested.
11674*
11675* CDEST0 (input) INTEGER array of dimension (NNDEST)
11676* Values of CDEST (column coordinate of destination) to be
11677* tested.
11678*
11679* NGRID (input) INTEGER
11680* The number of process grids to be tested.
11681*
11682* CONTEXT0 (input) INTEGER array of dimension (NGRID)
11683* The BLACS context handles corresponding to the grids.
11684*
11685* P0 (input) INTEGER array of dimension (NGRID)
11686* Values of P (number of process rows, NPROW).
11687*
11688* Q0 (input) INTEGER array of dimension (NGRID)
11689* Values of Q (number of process columns, NPCOL).
11690*
11691* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
11692* Workspace used to hold each process's random number SEED.
11693* This requires NPROCS (number of processor) elements.
11694* If VERB < 2, this workspace also serves to indicate which
11695* tests fail. This requires workspace of NTESTS
11696* (number of tests performed).
11697*
11698* MEM (workspace) INTEGER array of dimension (MEMLEN)
11699* Used for all other workspaces, including the matrix A,
11700* and its pre and post padding.
11701*
11702* MEMLEN (input) INTEGER
11703* The length, in elements, of MEM.
11704*
11705* =====================================================================
11706*
11707* .. External Functions ..
11708 LOGICAL ALLPASS, LSAME
11709 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
11710 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
11711* ..
11712* .. External Subroutines ..
11713 EXTERNAL blacs_gridinfo, igsum2d
11714 EXTERNAL iinitmat, ichkpad, ibtcheckin
11715* ..
11716* .. Local Scalars ..
11717 CHARACTER*1 SCOPE, TOP
11718 LOGICAL INGRID, TESTOK, ALLRCV
11719 INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
11720 $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
11721 $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
11722 $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
11723 $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
11724 $ TESTNUM
11725 INTEGER CHECKVAL
11726* ..
11727* .. Executable Statements ..
11728*
11729* Choose padding value, and make it unique
11730*
11731 checkval = -911
11732 iam = ibtmyproc()
11733 checkval = iam * checkval
11734 isize = ibtsizeof('I')
11735*
11736* Verify file parameters
11737*
11738 IF( iam .EQ. 0 ) THEN
11739 WRITE(outnum, *) ' '
11740 WRITE(outnum, *) ' '
11741 WRITE(outnum, 1000 )
11742 IF( verb .GT. 0 ) THEN
11743 WRITE(outnum,*) ' '
11744 WRITE(outnum, 2000) 'NSCOPE:', nscope
11745 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
11746 WRITE(outnum, 2000) 'TReps :', topsrepeat
11747 WRITE(outnum, 2000) 'TCohr :', topscohrnt
11748 WRITE(outnum, 2000) 'NTOP :', ntop
11749 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
11750 WRITE(outnum, 2000) 'NMAT :', nmat
11751 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
11752 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
11753 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
11754 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
11755 WRITE(outnum, 2000) 'NDEST :', ndest
11756 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
11757 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
11758 WRITE(outnum, 2000) 'NGRIDS:', ngrid
11759 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
11760 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
11761 WRITE(outnum, 2000) 'VERB :', verb
11762 WRITE(outnum,*) ' '
11763 END IF
11764 IF( verb .GT. 1 ) THEN
11765 WRITE(outnum,4000)
11766 WRITE(outnum,5000)
11767 END IF
11768 END IF
11769 IF (topsrepeat.EQ.0) THEN
11770 itr1 = 0
11771 itr2 = 0
11772 ELSE IF (topsrepeat.EQ.1) THEN
11773 itr1 = 1
11774 itr2 = 1
11775 ELSE
11776 itr1 = 0
11777 itr2 = 1
11778 END IF
11779*
11780* Find biggest matrix, so we know where to stick error info
11781*
11782 i = 0
11783 DO 10 ima = 1, nmat
11784 ipad = 4 * m0(ima)
11785 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
11786 IF( k .GT. i ) i = k
11787 10 CONTINUE
11788 maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
11789 IF( maxerr .LT. 1 ) THEN
11790 WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
11791 CALL blacs_abort(-1, 1)
11792 END IF
11793 errdptr = i + 1
11794 erriptr = errdptr + maxerr
11795 nerr = 0
11796 testnum = 0
11797 nfail = 0
11798 nskip = 0
11799*
11800* Loop over grids of matrix
11801*
11802 DO 90 igr = 1, ngrid
11803*
11804* allocate process grid for the next batch of tests
11805*
11806 context = context0(igr)
11807 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
11808 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
11809*
11810 DO 80 isc = 1, nscope
11811 scope = scope0(isc)
11812 DO 70 ito = 1, ntop
11813 top = top0(ito)
11814*
11815* If testing multiring ('M') or general tree ('T'), need to
11816* loop over calls to BLACS_SET to do full test
11817*
11818 IF( lsame(top, 'M') ) THEN
11819 setwhat = 13
11820 IF( scope .EQ. 'R' ) THEN
11821 istart = -(npcol - 1)
11822 istop = -istart
11823 ELSE IF (scope .EQ. 'C') THEN
11824 istart = -(nprow - 1)
11825 istop = -istart
11826 ELSE
11827 istart = -(nprow*npcol - 1)
11828 istop = -istart
11829 ENDIF
11830 ELSE IF( lsame(top, 'T') ) THEN
11831 setwhat = 14
11832 istart = 1
11833 IF( scope .EQ. 'R' ) THEN
11834 istop = npcol - 1
11835 ELSE IF (scope .EQ. 'C') THEN
11836 istop = nprow - 1
11837 ELSE
11838 istop = nprow*npcol - 1
11839 ENDIF
11840 ELSE
11841 setwhat = 0
11842 istart = 1
11843 istop = 1
11844 ENDIF
11845 DO 60 ima = 1, nmat
11846 m = m0(ima)
11847 n = n0(ima)
11848 ldasrc = ldas0(ima)
11849 ldadst = ldad0(ima)
11850 ipre = 2 * m
11851 ipost = ipre
11852 preaptr = 1
11853 aptr = preaptr + ipre
11854*
11855 DO 50 ide = 1, ndest
11856 testnum = testnum + 1
11857 rdest2 = rdest0(ide)
11858 cdest2 = cdest0(ide)
11859*
11860* If everyone gets the answer, create some bogus rdest/cdest
11861* so IF's are easier
11862*
11863 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
11864 IF( allrcv ) THEN
11865 rdest = nprow - 1
11866 cdest = npcol - 1
11867 IF (topscohrnt.EQ.0) THEN
11868 itr1 = 0
11869 itr2 = 0
11870 ELSE IF (topscohrnt.EQ.1) THEN
11871 itr1 = 1
11872 itr2 = 1
11873 ELSE
11874 itr1 = 0
11875 itr2 = 1
11876 END IF
11877 ELSE
11878 rdest = rdest2
11879 cdest = cdest2
11880 itc1 = 0
11881 itc2 = 0
11882 END IF
11883 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
11884 nskip = nskip + 1
11885 GOTO 50
11886 END IF
11887*
11888 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
11889 lda = ldadst
11890 ELSE
11891 lda = ldasrc
11892 END IF
11893 IF( verb .GT. 1 ) THEN
11894 IF( iam .EQ. 0 ) THEN
11895 WRITE(outnum, 6000)
11896 $ testnum, 'RUNNING', scope, top, m, n,
11897 $ ldasrc, ldadst, rdest2, cdest2,
11898 $ nprow, npcol
11899 END IF
11900 END IF
11901*
11902* If I am in scope
11903*
11904 testok = .true.
11905 IF( ingrid ) THEN
11906 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
11907 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
11908 $ (scope .EQ. 'A') ) THEN
11909*
11910 k = nerr
11911 DO 40 itr = itr1, itr2
11912 CALL blacs_set(context, 15, itr)
11913 DO 35 itc = itc1, itc2
11914 CALL blacs_set(context, 16, itc)
11915 DO 30 j = istart, istop
11916 IF( j.EQ.0) GOTO 30
11917 IF( setwhat.NE.0 )
11918 $ CALL blacs_set(context, setwhat, j)
11919*
11920*
11921* generate and pad matrix A
11922*
11923 CALL iinitmat('G','-', m, n, mem(preaptr),
11924 $ lda, ipre, ipost,
11925 $ checkval, testnum,
11926 $ myrow, mycol )
11927*
11928 CALL igsum2d(context, scope, top, m, n,
11929 $ mem(aptr), lda, rdest2,
11930 $ cdest2)
11931*
11932* If I've got the answer, check for errors in
11933* matrix or padding
11934*
11935 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
11936 $ .OR. allrcv ) THEN
11937 CALL ichkpad('G','-', m, n,
11938 $ mem(preaptr), lda, rdest,
11939 $ cdest, myrow, mycol,
11940 $ ipre, ipost, checkval,
11941 $ testnum, maxerr, nerr,
11942 $ mem(erriptr),mem(errdptr))
11943 CALL ichksum(scope, context, m, n,
11944 $ mem(aptr), lda,
11945 $ testnum, maxerr, nerr,
11946 $ mem(erriptr),mem(errdptr),
11947 $ iseed)
11948 END IF
11949 30 CONTINUE
11950 CALL blacs_set(context, 16, 0)
11951 35 CONTINUE
11952 CALL blacs_set(context, 15, 0)
11953 40 CONTINUE
11954 testok = ( k .EQ. nerr )
11955 END IF
11956 END IF
11957*
11958 IF( verb .GT. 1 ) THEN
11959 i = nerr
11960 CALL ibtcheckin(0, outnum, maxerr, nerr,
11961 $ mem(erriptr), mem(errdptr), iseed)
11962 IF( iam .EQ. 0 ) THEN
11963 IF( testok .AND. nerr.EQ.i ) THEN
11964 WRITE(outnum,6000)testnum,'PASSED ',
11965 $ scope, top, m, n, ldasrc,
11966 $ ldadst, rdest2, cdest2,
11967 $ nprow, npcol
11968 ELSE
11969 nfail = nfail + 1
11970 WRITE(outnum,6000)testnum,'FAILED ',
11971 $ scope, top, m, n, ldasrc,
11972 $ ldadst, rdest2, cdest2,
11973 $ nprow, npcol
11974 END IF
11975 END IF
11976*
11977* Once we've printed out errors, can re-use buf space
11978*
11979 nerr = 0
11980 END IF
11981 50 CONTINUE
11982 60 CONTINUE
11983 70 CONTINUE
11984 80 CONTINUE
11985 90 CONTINUE
11986*
11987 IF( verb .LT. 2 ) THEN
11988 nfail = testnum
11989 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
11990 $ mem(errdptr), iseed )
11991 END IF
11992 IF( iam .EQ. 0 ) THEN
11993 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
11994 IF( nfail+nskip .EQ. 0 ) THEN
11995 WRITE(outnum, 7000 ) testnum
11996 ELSE
11997 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
11998 $ nskip, nfail
11999 END IF
12000 END IF
12001*
12002* Log whether their were any failures
12003*
12004 testok = allpass( (nfail.EQ.0) )
12005*
12006 1000 FORMAT('INTEGER SUM TESTS: BEGIN.' )
12007 2000 FORMAT(1x,a7,3x,10i6)
12008 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
12009 $ 5x,a1,5x,a1)
12010 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
12011 $ 'RDEST CDEST P Q')
12012 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
12013 $ '----- ----- ---- ----')
12014 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
12015 7000 FORMAT('INTEGER SUM TESTS: PASSED ALL',
12016 $ i5, ' TESTS.')
12017 8000 FORMAT('INTEGER SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
12018 $ i5,' SKIPPED,',i5,' FAILED.')
12019*
12020 RETURN
12021*
12022* End of ITESTSUM.
12023*
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
ichksum
subroutine ichksum(scope, ictxt, m, n, a, lda, testnum, maxerr, nerr, erribuf, errdbuf, iseed)
Definition blacstest.f:12034
iinitmat
subroutine iinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:6394
ibtcheckin
subroutine ibtcheckin(nftests, outnum, maxerr, nerr, ierr, ival, tfailed)
Definition blacstest.f:6272
ichkpad
subroutine ichkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:6682
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: