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

◆ dsumtest()

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

Definition at line 12705 of file blacstest.f.

12709*
12710* -- BLACS tester (version 1.0) --
12711* University of Tennessee
12712* December 15, 1994
12713*
12714*
12715* .. Scalar Arguments ..
12716 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
12717 $ TOPSCOHRNT, TOPSREPEAT, VERB
12718* ..
12719* .. Array Arguments ..
12720 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
12721 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
12722 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
12723 INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
12724 DOUBLE PRECISION MEM(MEMLEN)
12725* ..
12726*
12727* Purpose
12728* =======
12729* DTESTSUM: Test double precision SUM COMBINE
12730*
12731* Arguments
12732* =========
12733* OUTNUM (input) INTEGER
12734* The device number to write output to.
12735*
12736* VERB (input) INTEGER
12737* The level of verbosity (how much printing to do).
12738*
12739* NSCOPE (input) INTEGER
12740* The number of scopes to be tested.
12741*
12742* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
12743* Values of the scopes to be tested.
12744*
12745* NTOP (input) INTEGER
12746* The number of topologies to be tested.
12747*
12748* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
12749* Values of the topologies to be tested.
12750*
12751* NMAT (input) INTEGER
12752* The number of matrices to be tested.
12753*
12754* M0 (input) INTEGER array of dimension (NMAT)
12755* Values of M to be tested.
12756*
12757* M0 (input) INTEGER array of dimension (NMAT)
12758* Values of M to be tested.
12759*
12760* N0 (input) INTEGER array of dimension (NMAT)
12761* Values of N to be tested.
12762*
12763* LDAS0 (input) INTEGER array of dimension (NMAT)
12764* Values of LDAS (leading dimension of A on source process)
12765* to be tested.
12766*
12767* LDAD0 (input) INTEGER array of dimension (NMAT)
12768* Values of LDAD (leading dimension of A on destination
12769* process) to be tested.
12770* NDEST (input) INTEGER
12771* The number of destinations to be tested.
12772*
12773* RDEST0 (input) INTEGER array of dimension (NNDEST)
12774* Values of RDEST (row coordinate of destination) to be
12775* tested.
12776*
12777* CDEST0 (input) INTEGER array of dimension (NNDEST)
12778* Values of CDEST (column coordinate of destination) to be
12779* tested.
12780*
12781* NGRID (input) INTEGER
12782* The number of process grids to be tested.
12783*
12784* CONTEXT0 (input) INTEGER array of dimension (NGRID)
12785* The BLACS context handles corresponding to the grids.
12786*
12787* P0 (input) INTEGER array of dimension (NGRID)
12788* Values of P (number of process rows, NPROW).
12789*
12790* Q0 (input) INTEGER array of dimension (NGRID)
12791* Values of Q (number of process columns, NPCOL).
12792*
12793* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
12794* Workspace used to hold each process's random number SEED.
12795* This requires NPROCS (number of processor) elements.
12796* If VERB < 2, this workspace also serves to indicate which
12797* tests fail. This requires workspace of NTESTS
12798* (number of tests performed).
12799*
12800* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
12801* Used for all other workspaces, including the matrix A,
12802* and its pre and post padding.
12803*
12804* MEMLEN (input) INTEGER
12805* The length, in elements, of MEM.
12806*
12807* =====================================================================
12808*
12809* .. External Functions ..
12810 LOGICAL ALLPASS, LSAME
12811 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
12812 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
12813* ..
12814* .. External Subroutines ..
12815 EXTERNAL blacs_gridinfo, dgsum2d
12816 EXTERNAL dinitmat, dchkpad, dbtcheckin
12817* ..
12818* .. Local Scalars ..
12819 CHARACTER*1 SCOPE, TOP
12820 LOGICAL INGRID, TESTOK, ALLRCV
12821 INTEGER APTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR, ERRIPTR, I,
12822 $ IAM, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
12823 $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
12824 $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
12825 $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
12826 $ TESTNUM
12827 DOUBLE PRECISION CHECKVAL
12828* ..
12829* .. Executable Statements ..
12830*
12831* Choose padding value, and make it unique
12832*
12833 checkval = -0.81d0
12834 iam = ibtmyproc()
12835 checkval = iam * checkval
12836 isize = ibtsizeof('I')
12837 dsize = ibtsizeof('D')
12838*
12839* Verify file parameters
12840*
12841 IF( iam .EQ. 0 ) THEN
12842 WRITE(outnum, *) ' '
12843 WRITE(outnum, *) ' '
12844 WRITE(outnum, 1000 )
12845 IF( verb .GT. 0 ) THEN
12846 WRITE(outnum,*) ' '
12847 WRITE(outnum, 2000) 'NSCOPE:', nscope
12848 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
12849 WRITE(outnum, 2000) 'TReps :', topsrepeat
12850 WRITE(outnum, 2000) 'TCohr :', topscohrnt
12851 WRITE(outnum, 2000) 'NTOP :', ntop
12852 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
12853 WRITE(outnum, 2000) 'NMAT :', nmat
12854 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
12855 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
12856 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
12857 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
12858 WRITE(outnum, 2000) 'NDEST :', ndest
12859 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
12860 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
12861 WRITE(outnum, 2000) 'NGRIDS:', ngrid
12862 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
12863 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
12864 WRITE(outnum, 2000) 'VERB :', verb
12865 WRITE(outnum,*) ' '
12866 END IF
12867 IF( verb .GT. 1 ) THEN
12868 WRITE(outnum,4000)
12869 WRITE(outnum,5000)
12870 END IF
12871 END IF
12872 IF (topsrepeat.EQ.0) THEN
12873 itr1 = 0
12874 itr2 = 0
12875 ELSE IF (topsrepeat.EQ.1) THEN
12876 itr1 = 1
12877 itr2 = 1
12878 ELSE
12879 itr1 = 0
12880 itr2 = 1
12881 END IF
12882*
12883* Find biggest matrix, so we know where to stick error info
12884*
12885 i = 0
12886 DO 10 ima = 1, nmat
12887 ipad = 4 * m0(ima)
12888 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
12889 IF( k .GT. i ) i = k
12890 10 CONTINUE
12891 maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
12892 IF( maxerr .LT. 1 ) THEN
12893 WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
12894 CALL blacs_abort(-1, 1)
12895 END IF
12896 errdptr = i + 1
12897 erriptr = errdptr + maxerr
12898 nerr = 0
12899 testnum = 0
12900 nfail = 0
12901 nskip = 0
12902*
12903* Loop over grids of matrix
12904*
12905 DO 90 igr = 1, ngrid
12906*
12907* allocate process grid for the next batch of tests
12908*
12909 context = context0(igr)
12910 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
12911 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
12912*
12913 DO 80 isc = 1, nscope
12914 scope = scope0(isc)
12915 DO 70 ito = 1, ntop
12916 top = top0(ito)
12917*
12918* If testing multiring ('M') or general tree ('T'), need to
12919* loop over calls to BLACS_SET to do full test
12920*
12921 IF( lsame(top, 'M') ) THEN
12922 setwhat = 13
12923 IF( scope .EQ. 'R' ) THEN
12924 istart = -(npcol - 1)
12925 istop = -istart
12926 ELSE IF (scope .EQ. 'C') THEN
12927 istart = -(nprow - 1)
12928 istop = -istart
12929 ELSE
12930 istart = -(nprow*npcol - 1)
12931 istop = -istart
12932 ENDIF
12933 ELSE IF( lsame(top, 'T') ) THEN
12934 setwhat = 14
12935 istart = 1
12936 IF( scope .EQ. 'R' ) THEN
12937 istop = npcol - 1
12938 ELSE IF (scope .EQ. 'C') THEN
12939 istop = nprow - 1
12940 ELSE
12941 istop = nprow*npcol - 1
12942 ENDIF
12943 ELSE
12944 setwhat = 0
12945 istart = 1
12946 istop = 1
12947 ENDIF
12948 DO 60 ima = 1, nmat
12949 m = m0(ima)
12950 n = n0(ima)
12951 ldasrc = ldas0(ima)
12952 ldadst = ldad0(ima)
12953 ipre = 2 * m
12954 ipost = ipre
12955 preaptr = 1
12956 aptr = preaptr + ipre
12957*
12958 DO 50 ide = 1, ndest
12959 testnum = testnum + 1
12960 rdest2 = rdest0(ide)
12961 cdest2 = cdest0(ide)
12962*
12963* If everyone gets the answer, create some bogus rdest/cdest
12964* so IF's are easier
12965*
12966 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
12967 IF( allrcv ) THEN
12968 rdest = nprow - 1
12969 cdest = npcol - 1
12970 IF (topscohrnt.EQ.0) THEN
12971 itr1 = 0
12972 itr2 = 0
12973 ELSE IF (topscohrnt.EQ.1) THEN
12974 itr1 = 1
12975 itr2 = 1
12976 ELSE
12977 itr1 = 0
12978 itr2 = 1
12979 END IF
12980 ELSE
12981 rdest = rdest2
12982 cdest = cdest2
12983 itc1 = 0
12984 itc2 = 0
12985 END IF
12986 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
12987 nskip = nskip + 1
12988 GOTO 50
12989 END IF
12990*
12991 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
12992 lda = ldadst
12993 ELSE
12994 lda = ldasrc
12995 END IF
12996 IF( verb .GT. 1 ) THEN
12997 IF( iam .EQ. 0 ) THEN
12998 WRITE(outnum, 6000)
12999 $ testnum, 'RUNNING', scope, top, m, n,
13000 $ ldasrc, ldadst, rdest2, cdest2,
13001 $ nprow, npcol
13002 END IF
13003 END IF
13004*
13005* If I am in scope
13006*
13007 testok = .true.
13008 IF( ingrid ) THEN
13009 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
13010 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
13011 $ (scope .EQ. 'A') ) THEN
13012*
13013 k = nerr
13014 DO 40 itr = itr1, itr2
13015 CALL blacs_set(context, 15, itr)
13016 DO 35 itc = itc1, itc2
13017 CALL blacs_set(context, 16, itc)
13018 DO 30 j = istart, istop
13019 IF( j.EQ.0) GOTO 30
13020 IF( setwhat.NE.0 )
13021 $ CALL blacs_set(context, setwhat, j)
13022*
13023*
13024* generate and pad matrix A
13025*
13026 CALL dinitmat('G','-', m, n, mem(preaptr),
13027 $ lda, ipre, ipost,
13028 $ checkval, testnum,
13029 $ myrow, mycol )
13030*
13031 CALL dgsum2d(context, scope, top, m, n,
13032 $ mem(aptr), lda, rdest2,
13033 $ cdest2)
13034*
13035* If I've got the answer, check for errors in
13036* matrix or padding
13037*
13038 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
13039 $ .OR. allrcv ) THEN
13040 CALL dchkpad('G','-', m, n,
13041 $ mem(preaptr), lda, rdest,
13042 $ cdest, myrow, mycol,
13043 $ ipre, ipost, checkval,
13044 $ testnum, maxerr, nerr,
13045 $ mem(erriptr),mem(errdptr))
13046 CALL dchksum(scope, context, m, n,
13047 $ mem(aptr), lda,
13048 $ testnum, maxerr, nerr,
13049 $ mem(erriptr),mem(errdptr),
13050 $ iseed)
13051 END IF
13052 30 CONTINUE
13053 CALL blacs_set(context, 16, 0)
13054 35 CONTINUE
13055 CALL blacs_set(context, 15, 0)
13056 40 CONTINUE
13057 testok = ( k .EQ. nerr )
13058 END IF
13059 END IF
13060*
13061 IF( verb .GT. 1 ) THEN
13062 i = nerr
13063 CALL dbtcheckin(0, outnum, maxerr, nerr,
13064 $ mem(erriptr), mem(errdptr), iseed)
13065 IF( iam .EQ. 0 ) THEN
13066 IF( testok .AND. nerr.EQ.i ) THEN
13067 WRITE(outnum,6000)testnum,'PASSED ',
13068 $ scope, top, m, n, ldasrc,
13069 $ ldadst, rdest2, cdest2,
13070 $ nprow, npcol
13071 ELSE
13072 nfail = nfail + 1
13073 WRITE(outnum,6000)testnum,'FAILED ',
13074 $ scope, top, m, n, ldasrc,
13075 $ ldadst, rdest2, cdest2,
13076 $ nprow, npcol
13077 END IF
13078 END IF
13079*
13080* Once we've printed out errors, can re-use buf space
13081*
13082 nerr = 0
13083 END IF
13084 50 CONTINUE
13085 60 CONTINUE
13086 70 CONTINUE
13087 80 CONTINUE
13088 90 CONTINUE
13089*
13090 IF( verb .LT. 2 ) THEN
13091 nfail = testnum
13092 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
13093 $ mem(errdptr), iseed )
13094 END IF
13095 IF( iam .EQ. 0 ) THEN
13096 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
13097 IF( nfail+nskip .EQ. 0 ) THEN
13098 WRITE(outnum, 7000 ) testnum
13099 ELSE
13100 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
13101 $ nskip, nfail
13102 END IF
13103 END IF
13104*
13105* Log whether their were any failures
13106*
13107 testok = allpass( (nfail.EQ.0) )
13108*
13109 1000 FORMAT('DOUBLE PRECISION SUM TESTS: BEGIN.' )
13110 2000 FORMAT(1x,a7,3x,10i6)
13111 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
13112 $ 5x,a1,5x,a1)
13113 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
13114 $ 'RDEST CDEST P Q')
13115 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
13116 $ '----- ----- ---- ----')
13117 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
13118 7000 FORMAT('DOUBLE PRECISION SUM TESTS: PASSED ALL',
13119 $ i5, ' TESTS.')
13120 8000 FORMAT('DOUBLE PRECISION SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
13121 $ i5,' SKIPPED,',i5,' FAILED.')
13122*
13123 RETURN
13124*
13125* End of DTESTSUM.
13126*
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
dchksum
subroutine dchksum(scope, ictxt, m, n, a, lda, testnum, maxerr, nerr, erribuf, errdbuf, iseed)
Definition blacstest.f:13179
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
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: