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

◆ zamxtest()

subroutine zamxtest ( 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 17677 of file blacstest.f.

17682*
17683* -- BLACS tester (version 1.0) --
17684* University of Tennessee
17685* December 15, 1994
17686*
17687*
17688* .. Scalar Arguments ..
17689 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
17690 $ TOPSCOHRNT, TOPSREPEAT, VERB
17691* ..
17692* .. Array Arguments ..
17693 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
17694 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
17695 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
17696 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
17697 DOUBLE COMPLEX MEM(MEMLEN)
17698* ..
17699*
17700* Purpose
17701* =======
17702* ZTESTAMX: Test double complex AMX COMBINE
17703*
17704* Arguments
17705* =========
17706* OUTNUM (input) INTEGER
17707* The device number to write output to.
17708*
17709* VERB (input) INTEGER
17710* The level of verbosity (how much printing to do).
17711*
17712* NSCOPE (input) INTEGER
17713* The number of scopes to be tested.
17714*
17715* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
17716* Values of the scopes to be tested.
17717*
17718* NTOP (input) INTEGER
17719* The number of topologies to be tested.
17720*
17721* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
17722* Values of the topologies to be tested.
17723*
17724* NMAT (input) INTEGER
17725* The number of matrices to be tested.
17726*
17727* M0 (input) INTEGER array of dimension (NMAT)
17728* Values of M to be tested.
17729*
17730* M0 (input) INTEGER array of dimension (NMAT)
17731* Values of M to be tested.
17732*
17733* N0 (input) INTEGER array of dimension (NMAT)
17734* Values of N to be tested.
17735*
17736* LDAS0 (input) INTEGER array of dimension (NMAT)
17737* Values of LDAS (leading dimension of A on source process)
17738* to be tested.
17739*
17740* LDAD0 (input) INTEGER array of dimension (NMAT)
17741* Values of LDAD (leading dimension of A on destination
17742* process) to be tested.
17743* LDI0 (input) INTEGER array of dimension (NMAT)
17744* Values of LDI (leading dimension of RA/CA) to be tested.
17745* If LDI == -1, these RA/CA should not be accessed.
17746*
17747* NDEST (input) INTEGER
17748* The number of destinations to be tested.
17749*
17750* RDEST0 (input) INTEGER array of dimension (NNDEST)
17751* Values of RDEST (row coordinate of destination) to be
17752* tested.
17753*
17754* CDEST0 (input) INTEGER array of dimension (NNDEST)
17755* Values of CDEST (column coordinate of destination) to be
17756* tested.
17757*
17758* NGRID (input) INTEGER
17759* The number of process grids to be tested.
17760*
17761* CONTEXT0 (input) INTEGER array of dimension (NGRID)
17762* The BLACS context handles corresponding to the grids.
17763*
17764* P0 (input) INTEGER array of dimension (NGRID)
17765* Values of P (number of process rows, NPROW).
17766*
17767* Q0 (input) INTEGER array of dimension (NGRID)
17768* Values of Q (number of process columns, NPCOL).
17769*
17770* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
17771* Workspace used to hold each process's random number SEED.
17772* This requires NPROCS (number of processor) elements.
17773* If VERB < 2, this workspace also serves to indicate which
17774* tests fail. This requires workspace of NTESTS
17775* (number of tests performed).
17776*
17777* RMEM (workspace) INTEGER array of dimension (RCLEN)
17778* Used for all RA arrays, and their pre and post padding.
17779*
17780* CMEM (workspace) INTEGER array of dimension (RCLEN)
17781* Used for all CA arrays, and their pre and post padding.
17782*
17783* RCLEN (input) INTEGER
17784* The length, in elements, of RMEM and CMEM.
17785*
17786* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
17787* Used for all other workspaces, including the matrix A,
17788* and its pre and post padding.
17789*
17790* MEMLEN (input) INTEGER
17791* The length, in elements, of MEM.
17792*
17793* =====================================================================
17794*
17795* .. External Functions ..
17796 LOGICAL ALLPASS, LSAME
17797 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
17798 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
17799* ..
17800* .. External Subroutines ..
17801 EXTERNAL blacs_gridinfo, zgamx2d
17802 EXTERNAL zinitmat, zchkpad, zbtcheckin
17803* ..
17804* .. Local Scalars ..
17805 CHARACTER*1 SCOPE, TOP
17806 LOGICAL INGRID, TESTOK, ALLRCV
17807 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
17808 $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
17809 $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
17810 $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
17811 $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
17812 $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR, ZSIZE
17813 DOUBLE COMPLEX CHECKVAL
17814* ..
17815* .. Executable Statements ..
17816*
17817* Choose padding value, and make it unique
17818*
17819 checkval = dcmplx( -9.11d0, -9.21d0 )
17820 iam = ibtmyproc()
17821 checkval = iam * checkval
17822 isize = ibtsizeof('I')
17823 zsize = ibtsizeof('Z')
17824 icheckval = -iam
17825*
17826* Verify file parameters
17827*
17828 IF( iam .EQ. 0 ) THEN
17829 WRITE(outnum, *) ' '
17830 WRITE(outnum, *) ' '
17831 WRITE(outnum, 1000 )
17832 IF( verb .GT. 0 ) THEN
17833 WRITE(outnum,*) ' '
17834 WRITE(outnum, 2000) 'NSCOPE:', nscope
17835 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
17836 WRITE(outnum, 2000) 'TReps :', topsrepeat
17837 WRITE(outnum, 2000) 'TCohr :', topscohrnt
17838 WRITE(outnum, 2000) 'NTOP :', ntop
17839 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
17840 WRITE(outnum, 2000) 'NMAT :', nmat
17841 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
17842 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
17843 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
17844 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
17845 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
17846 WRITE(outnum, 2000) 'NDEST :', ndest
17847 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
17848 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
17849 WRITE(outnum, 2000) 'NGRIDS:', ngrid
17850 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
17851 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
17852 WRITE(outnum, 2000) 'VERB :', verb
17853 WRITE(outnum,*) ' '
17854 END IF
17855 IF( verb .GT. 1 ) THEN
17856 WRITE(outnum,4000)
17857 WRITE(outnum,5000)
17858 END IF
17859 END IF
17860 IF (topsrepeat.EQ.0) THEN
17861 itr1 = 0
17862 itr2 = 0
17863 ELSE IF (topsrepeat.EQ.1) THEN
17864 itr1 = 1
17865 itr2 = 1
17866 ELSE
17867 itr1 = 0
17868 itr2 = 1
17869 END IF
17870*
17871* Find biggest matrix, so we know where to stick error info
17872*
17873 i = 0
17874 DO 10 ima = 1, nmat
17875 ipad = 4 * m0(ima)
17876 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
17877 IF( k .GT. i ) i = k
17878 10 CONTINUE
17879 i = i + ibtnprocs()
17880 maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
17881 IF( maxerr .LT. 1 ) THEN
17882 WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
17883 CALL blacs_abort(-1, 1)
17884 END IF
17885 errdptr = i + 1
17886 erriptr = errdptr + maxerr
17887 nerr = 0
17888 testnum = 0
17889 nfail = 0
17890 nskip = 0
17891*
17892* Loop over grids of matrix
17893*
17894 DO 90 igr = 1, ngrid
17895*
17896* allocate process grid for the next batch of tests
17897*
17898 context = context0(igr)
17899 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
17900 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
17901*
17902 DO 80 isc = 1, nscope
17903 scope = scope0(isc)
17904 DO 70 ito = 1, ntop
17905 top = top0(ito)
17906*
17907* If testing multiring ('M') or general tree ('T'), need to
17908* loop over calls to BLACS_SET to do full test
17909*
17910 IF( lsame(top, 'M') ) THEN
17911 setwhat = 13
17912 IF( scope .EQ. 'R' ) THEN
17913 istart = -(npcol - 1)
17914 istop = -istart
17915 ELSE IF (scope .EQ. 'C') THEN
17916 istart = -(nprow - 1)
17917 istop = -istart
17918 ELSE
17919 istart = -(nprow*npcol - 1)
17920 istop = -istart
17921 ENDIF
17922 ELSE IF( lsame(top, 'T') ) THEN
17923 setwhat = 14
17924 istart = 1
17925 IF( scope .EQ. 'R' ) THEN
17926 istop = npcol - 1
17927 ELSE IF (scope .EQ. 'C') THEN
17928 istop = nprow - 1
17929 ELSE
17930 istop = nprow*npcol - 1
17931 ENDIF
17932 ELSE
17933 setwhat = 0
17934 istart = 1
17935 istop = 1
17936 ENDIF
17937 DO 60 ima = 1, nmat
17938 m = m0(ima)
17939 n = n0(ima)
17940 ldasrc = ldas0(ima)
17941 ldadst = ldad0(ima)
17942 ldi = ldi0(ima)
17943 ipre = 2 * m
17944 ipost = ipre
17945 preaptr = 1
17946 aptr = preaptr + ipre
17947*
17948 DO 50 ide = 1, ndest
17949 testnum = testnum + 1
17950 rdest2 = rdest0(ide)
17951 cdest2 = cdest0(ide)
17952*
17953* If everyone gets the answer, create some bogus rdest/cdest
17954* so IF's are easier
17955*
17956 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
17957 IF( allrcv ) THEN
17958 rdest = nprow - 1
17959 cdest = npcol - 1
17960 IF (topscohrnt.EQ.0) THEN
17961 itr1 = 0
17962 itr2 = 0
17963 ELSE IF (topscohrnt.EQ.1) THEN
17964 itr1 = 1
17965 itr2 = 1
17966 ELSE
17967 itr1 = 0
17968 itr2 = 1
17969 END IF
17970 ELSE
17971 rdest = rdest2
17972 cdest = cdest2
17973 itc1 = 0
17974 itc2 = 0
17975 END IF
17976 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
17977 nskip = nskip + 1
17978 GOTO 50
17979 END IF
17980*
17981 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
17982 lda = ldadst
17983 ELSE
17984 lda = ldasrc
17985 END IF
17986 valptr = aptr + ipost + n * lda
17987 IF( verb .GT. 1 ) THEN
17988 IF( iam .EQ. 0 ) THEN
17989 WRITE(outnum, 6000)
17990 $ testnum, 'RUNNING', scope, top, m, n,
17991 $ ldasrc, ldadst, ldi, rdest2, cdest2,
17992 $ nprow, npcol
17993 END IF
17994 END IF
17995*
17996* If I am in scope
17997*
17998 testok = .true.
17999 IF( ingrid ) THEN
18000 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
18001 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
18002 $ (scope .EQ. 'A') ) THEN
18003*
18004 k = nerr
18005 DO 40 itr = itr1, itr2
18006 CALL blacs_set(context, 15, itr)
18007 DO 35 itc = itc1, itc2
18008 CALL blacs_set(context, 16, itc)
18009 DO 30 j = istart, istop
18010 IF( j.EQ.0) GOTO 30
18011 IF( setwhat.NE.0 )
18012 $ CALL blacs_set(context, setwhat, j)
18013*
18014*
18015* generate and pad matrix A
18016*
18017 CALL zinitmat('G','-', m, n, mem(preaptr),
18018 $ lda, ipre, ipost,
18019 $ checkval, testnum,
18020 $ myrow, mycol )
18021*
18022* If they exist, pad RA and CA arrays
18023*
18024 IF( ldi .NE. -1 ) THEN
18025 DO 15 i = 1, n*ldi + ipre + ipost
18026 rmem(i) = icheckval
18027 cmem(i) = icheckval
18028 15 CONTINUE
18029 raptr = 1 + ipre
18030 captr = 1 + ipre
18031 ELSE
18032 DO 20 i = 1, ipre+ipost
18033 rmem(i) = icheckval
18034 cmem(i) = icheckval
18035 20 CONTINUE
18036 raptr = 1
18037 captr = 1
18038 END IF
18039*
18040 CALL zgamx2d(context, scope, top, m, n,
18041 $ mem(aptr), lda, rmem(raptr),
18042 $ cmem(captr), ldi,
18043 $ rdest2, cdest2)
18044*
18045* If I've got the answer, check for errors in
18046* matrix or padding
18047*
18048 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
18049 $ .OR. allrcv ) THEN
18050 CALL zchkpad('G','-', m, n,
18051 $ mem(preaptr), lda, rdest,
18052 $ cdest, myrow, mycol,
18053 $ ipre, ipost, checkval,
18054 $ testnum, maxerr, nerr,
18055 $ mem(erriptr),mem(errdptr))
18056 CALL zchkamx(scope, context, m, n,
18057 $ mem(aptr), lda,
18058 $ rmem(raptr), cmem(captr),
18059 $ ldi, testnum, maxerr,nerr,
18060 $ mem(erriptr),mem(errdptr),
18061 $ iseed, mem(valptr))
18062 CALL zrcchk(ipre, ipost, icheckval,
18063 $ m, n, rmem, cmem, ldi,
18064 $ myrow, mycol, testnum,
18065 $ maxerr, nerr,
18066 $ mem(erriptr), mem(errdptr))
18067 END IF
18068 30 CONTINUE
18069 CALL blacs_set(context, 16, 0)
18070 35 CONTINUE
18071 CALL blacs_set(context, 15, 0)
18072 40 CONTINUE
18073 testok = ( k .EQ. nerr )
18074 END IF
18075 END IF
18076*
18077 IF( verb .GT. 1 ) THEN
18078 i = nerr
18079 CALL zbtcheckin(0, outnum, maxerr, nerr,
18080 $ mem(erriptr), mem(errdptr), iseed)
18081 IF( iam .EQ. 0 ) THEN
18082 IF( testok .AND. nerr.EQ.i ) THEN
18083 WRITE(outnum,6000)testnum,'PASSED ',
18084 $ scope, top, m, n, ldasrc,
18085 $ ldadst, ldi, rdest2, cdest2,
18086 $ nprow, npcol
18087 ELSE
18088 nfail = nfail + 1
18089 WRITE(outnum,6000)testnum,'FAILED ',
18090 $ scope, top, m, n, ldasrc,
18091 $ ldadst, ldi, rdest2, cdest2,
18092 $ nprow, npcol
18093 END IF
18094 END IF
18095*
18096* Once we've printed out errors, can re-use buf space
18097*
18098 nerr = 0
18099 END IF
18100 50 CONTINUE
18101 60 CONTINUE
18102 70 CONTINUE
18103 80 CONTINUE
18104 90 CONTINUE
18105*
18106 IF( verb .LT. 2 ) THEN
18107 nfail = testnum
18108 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
18109 $ mem(errdptr), iseed )
18110 END IF
18111 IF( iam .EQ. 0 ) THEN
18112 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
18113 IF( nfail+nskip .EQ. 0 ) THEN
18114 WRITE(outnum, 7000 ) testnum
18115 ELSE
18116 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
18117 $ nskip, nfail
18118 END IF
18119 END IF
18120*
18121* Log whether their were any failures
18122*
18123 testok = allpass( (nfail.EQ.0) )
18124*
18125 1000 FORMAT('DOUBLE COMPLEX AMX TESTS: BEGIN.' )
18126 2000 FORMAT(1x,a7,3x,10i6)
18127 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
18128 $ 5x,a1,5x,a1)
18129 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
18130 $ 'RDEST CDEST P Q')
18131 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
18132 $ '----- ----- ---- ----')
18133 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
18134 7000 FORMAT('DOUBLE COMPLEX AMX TESTS: PASSED ALL',
18135 $ i5, ' TESTS.')
18136 8000 FORMAT('DOUBLE COMPLEX AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
18137 $ i5,' SKIPPED,',i5,' FAILED.')
18138*
18139 RETURN
18140*
18141* End of ZTESTAMX.
18142*
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
zchkamx
subroutine zchkamx(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:18317
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: