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

◆ dbsbrtest()

subroutine dbsbrtest ( integer  outnum,
integer  verb,
integer  nscope,
character*1, dimension(nscope)  scope0,
integer  ntop,
character*1, dimension(ntop)  top0,
integer  nshape,
character*1, dimension(nshape)  uplo0,
character*1, dimension(nshape)  diag0,
integer  nmat,
integer, dimension(nmat)  m0,
integer, dimension(nmat)  n0,
integer, dimension(nmat)  ldas0,
integer, dimension(nmat)  ldad0,
integer  nsrc,
integer, dimension(nsrc)  rsrc0,
integer, dimension(nsrc)  csrc0,
integer  ngrid,
integer, dimension(ngrid)  context0,
integer, dimension(ngrid)  p0,
integer, dimension(ngrid)  q0,
integer, dimension(*)  tfail,
double precision, dimension(memlen)  mem,
integer  memlen 
)

Definition at line 4751 of file blacstest.f.

4755*
4756* -- BLACS tester (version 1.0) --
4757* University of Tennessee
4758* December 15, 1994
4759*
4760*
4761* .. Scalar Arguments ..
4762 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
4763 INTEGER MEMLEN
4764* ..
4765* .. Array Arguments ..
4766 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
4767 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
4768 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
4769 INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
4770 INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
4771 DOUBLE PRECISION MEM(MEMLEN)
4772* ..
4773*
4774* Purpose
4775* =======
4776* DTESTBSBR: Test double precision broadcast
4777*
4778* Arguments
4779* =========
4780* OUTNUM (input) INTEGER
4781* The device number to write output to.
4782*
4783* VERB (input) INTEGER
4784* The level of verbosity (how much printing to do).
4785*
4786* NSCOPE (input) INTEGER
4787* The number of scopes to be tested.
4788*
4789* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
4790* Values of the scopes to be tested.
4791*
4792* NTOP (input) INTEGER
4793* The number of topologies to be tested.
4794*
4795* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
4796* Values of the topologies to be tested.
4797*
4798* NSHAPE (input) INTEGER
4799* The number of matrix shapes to be tested.
4800*
4801* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
4802* Values of UPLO to be tested.
4803*
4804* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
4805* Values of DIAG to be tested.
4806*
4807* NMAT (input) INTEGER
4808* The number of matrices to be tested.
4809*
4810* M0 (input) INTEGER array of dimension (NMAT)
4811* Values of M to be tested.
4812*
4813* M0 (input) INTEGER array of dimension (NMAT)
4814* Values of M to be tested.
4815*
4816* N0 (input) INTEGER array of dimension (NMAT)
4817* Values of N to be tested.
4818*
4819* LDAS0 (input) INTEGER array of dimension (NMAT)
4820* Values of LDAS (leading dimension of A on source process)
4821* to be tested.
4822*
4823* LDAD0 (input) INTEGER array of dimension (NMAT)
4824* Values of LDAD (leading dimension of A on destination
4825* process) to be tested.
4826* NSRC (input) INTEGER
4827* The number of sources to be tested.
4828*
4829* RSRC0 (input) INTEGER array of dimension (NDEST)
4830* Values of RSRC (row coordinate of source) to be tested.
4831*
4832* CSRC0 (input) INTEGER array of dimension (NDEST)
4833* Values of CSRC (column coordinate of source) to be tested.
4834*
4835* NGRID (input) INTEGER
4836* The number of process grids to be tested.
4837*
4838* CONTEXT0 (input) INTEGER array of dimension (NGRID)
4839* The BLACS context handles corresponding to the grids.
4840*
4841* P0 (input) INTEGER array of dimension (NGRID)
4842* Values of P (number of process rows, NPROW).
4843*
4844* Q0 (input) INTEGER array of dimension (NGRID)
4845* Values of Q (number of process columns, NPCOL).
4846*
4847* TFAIL (workspace) INTEGER array of dimension (NTESTS)
4848* If VERB < 2, serves to indicate which tests fail. This
4849* requires workspace of NTESTS (number of tests performed).
4850*
4851* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
4852* Used for all other workspaces, including the matrix A,
4853* and its pre and post padding.
4854*
4855* MEMLEN (input) INTEGER
4856* The length, in elements, of MEM.
4857*
4858* =====================================================================
4859*
4860* .. External Functions ..
4861 LOGICAL ALLPASS, LSAME
4862 INTEGER IBTMYPROC, IBTSIZEOF
4863 EXTERNAL allpass, lsame, ibtmyproc, ibtsizeof
4864* ..
4865* .. External Subroutines ..
4866 EXTERNAL blacs_gridinfo
4867 EXTERNAL dtrbs2d, dgebs2d, dtrbr2d, dgebr2d
4868 EXTERNAL dinitmat, dchkmat, dchkpad, dbtcheckin
4869* ..
4870* .. Local Scalars ..
4871 CHARACTER*1 SCOPE, TOP, UPLO, DIAG
4872 LOGICAL TESTOK, INGRID
4873 INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
4874 INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
4875 INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
4876 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
4877 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE
4878 DOUBLE PRECISION SCHECKVAL, RCHECKVAL
4879* ..
4880* .. Executable Statements ..
4881*
4882 scheckval = -0.01d0
4883 rcheckval = -0.02d0
4884*
4885 iam = ibtmyproc()
4886 isize = ibtsizeof('I')
4887 dsize = ibtsizeof('D')
4888*
4889* Verify file parameters
4890*
4891 IF( iam .EQ. 0 ) THEN
4892 WRITE(outnum, *) ' '
4893 WRITE(outnum, *) ' '
4894 WRITE(outnum, 1000 )
4895 IF( verb .GT. 0 ) THEN
4896 WRITE(outnum,*) ' '
4897 WRITE(outnum, 2000) 'NSCOPE:', nscope
4898 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
4899 WRITE(outnum, 2000) 'NTOP :', ntop
4900 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
4901 WRITE(outnum, 2000) 'NSHAPE:', nshape
4902 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
4903 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
4904 WRITE(outnum, 2000) 'NMAT :', nmat
4905 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
4906 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
4907 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
4908 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
4909 WRITE(outnum, 2000) 'NSRC :', nsrc
4910 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
4911 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
4912 WRITE(outnum, 2000) 'NGRIDS:', ngrid
4913 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
4914 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
4915 WRITE(outnum, 2000) 'VERB :', verb
4916 WRITE(outnum,*) ' '
4917 END IF
4918 IF( verb .GT. 1 ) THEN
4919 WRITE(outnum,5000)
4920 WRITE(outnum,6000)
4921 END IF
4922 END IF
4923*
4924* Find biggest matrix, so we know where to stick error info
4925*
4926 i = 0
4927 DO 10 ima = 1, nmat
4928 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4929 IF( k .GT. i ) i = k
4930 10 CONTINUE
4931 maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
4932 IF( maxerr .LT. 1 ) THEN
4933 WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
4934 CALL blacs_abort(-1, 1)
4935 END IF
4936 errdptr = i + 1
4937 erriptr = errdptr + maxerr
4938 nerr = 0
4939 testnum = 0
4940 nfail = 0
4941 nskip = 0
4942*
4943* Loop over grids of matrix
4944*
4945 DO 110 igr = 1, ngrid
4946*
4947 context = context0(igr)
4948 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4949*
4950 ingrid = ( nprow .GT. 0 )
4951*
4952 DO 100 isc = 1, nscope
4953 scope = scope0(isc)
4954 DO 90 ito = 1, ntop
4955 top = top0(ito)
4956*
4957* If testing multipath ('M') or general tree ('T'),
4958* need to loop over calls to BLACS_SET
4959*
4960 IF( lsame(top, 'M') ) THEN
4961 setwhat = 11
4962 IF( scope .EQ. 'R' ) THEN
4963 istart = -(npcol - 1)
4964 istop = -istart
4965 ELSE IF (scope .EQ. 'C') THEN
4966 istart = -(nprow - 1)
4967 istop = -istart
4968 ELSE
4969 istart = -(nprow*npcol - 1)
4970 istop = -istart
4971 ENDIF
4972 ELSE IF( lsame(top, 'T') ) THEN
4973 setwhat = 12
4974 istart = 1
4975 IF( scope .EQ. 'R' ) THEN
4976 istop = npcol - 1
4977 ELSE IF (scope .EQ. 'C') THEN
4978 istop = nprow - 1
4979 ELSE
4980 istop = nprow*npcol - 1
4981 ENDIF
4982 ELSE
4983 setwhat = 0
4984 istart = 1
4985 istop = 1
4986 ENDIF
4987 DO 80 ish = 1, nshape
4988 uplo = uplo0(ish)
4989 diag = diag0(ish)
4990*
4991 DO 70 ima = 1, nmat
4992 m = m0(ima)
4993 n = n0(ima)
4994 ldasrc = ldas0(ima)
4995 ldadst = ldad0(ima)
4996*
4997 DO 60 iso = 1, nsrc
4998 testnum = testnum + 1
4999 rsrc = rsrc0(iso)
5000 csrc = csrc0(iso)
5001 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
5002 nskip = nskip + 1
5003 GOTO 60
5004 END IF
5005 IF( verb .GT. 1 ) THEN
5006 IF( iam .EQ. 0 ) THEN
5007 WRITE(outnum, 7000)
5008 $ testnum, 'RUNNING',scope, top, uplo, diag,
5009 $ m, n, ldasrc, ldadst, rsrc, csrc,
5010 $ nprow, npcol
5011 END IF
5012 END IF
5013*
5014 testok = .true.
5015 ipre = 2 * m
5016 ipost = ipre
5017 aptr = ipre + 1
5018*
5019* If I am in scope
5020*
5021 IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
5022 $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
5023 $ (scope .EQ. 'A') ) THEN
5024*
5025* source process generates matrix and sends it
5026*
5027 IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
5028 CALL dinitmat(uplo, diag, m, n, mem,
5029 $ ldasrc, ipre, ipost,
5030 $ scheckval, testnum,
5031 $ myrow, mycol )
5032*
5033 DO 20 j = istart, istop
5034 IF( j.EQ.0 ) GOTO 20
5035 IF( setwhat.NE.0 )
5036 $ CALL blacs_set(context, setwhat, j)
5037 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5038 CALL dtrbs2d(context, scope, top,
5039 $ uplo, diag, m, n,
5040 $ mem(aptr), ldasrc )
5041 ELSE
5042 CALL dgebs2d(context, scope, top,
5043 $ m, n, mem(aptr),
5044 $ ldasrc )
5045 END IF
5046 20 CONTINUE
5047*
5048* Destination processes
5049*
5050 ELSE IF( ingrid ) THEN
5051 DO 40 j = istart, istop
5052 IF( j.EQ.0 ) GOTO 40
5053 IF( setwhat.NE.0 )
5054 $ CALL blacs_set(context, setwhat, j)
5055*
5056* Pad entire matrix area
5057*
5058 DO 30 k = 1, ipre+ipost+ldadst*n
5059 mem(k) = rcheckval
5060 30 CONTINUE
5061*
5062* Receive matrix
5063*
5064 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5065 CALL dtrbr2d(context, scope, top,
5066 $ uplo, diag, m, n,
5067 $ mem(aptr), ldadst,
5068 $ rsrc, csrc)
5069 ELSE
5070 CALL dgebr2d(context, scope, top,
5071 $ m, n, mem(aptr),
5072 $ ldadst, rsrc, csrc)
5073 END IF
5074*
5075* Check for errors in matrix or padding
5076*
5077 i = nerr
5078 CALL dchkmat(uplo, diag, m, n,
5079 $ mem(aptr), ldadst, rsrc, csrc,
5080 $ myrow, mycol, testnum, maxerr,
5081 $ nerr, mem(erriptr),
5082 $ mem(errdptr))
5083*
5084 CALL dchkpad(uplo, diag, m, n, mem,
5085 $ ldadst, rsrc, csrc, myrow,
5086 $ mycol, ipre, ipost, rcheckval,
5087 $ testnum, maxerr, nerr,
5088 $ mem(erriptr), mem(errdptr))
5089 40 CONTINUE
5090 testok = ( i .EQ. nerr )
5091 END IF
5092 END IF
5093*
5094 IF( verb .GT. 1 ) THEN
5095 i = nerr
5096 CALL dbtcheckin(0, outnum, maxerr, nerr,
5097 $ mem(erriptr), mem(errdptr),
5098 $ tfail)
5099 IF( iam .EQ. 0 ) THEN
5100 testok = ( testok .AND. (i.EQ.nerr) )
5101 IF( testok ) THEN
5102 WRITE(outnum,7000)testnum,'PASSED ',
5103 $ scope, top, uplo, diag, m, n,
5104 $ ldasrc, ldadst, rsrc, csrc,
5105 $ nprow, npcol
5106 ELSE
5107 nfail = nfail + 1
5108 WRITE(outnum,7000)testnum,'FAILED ',
5109 $ scope, top, uplo, diag, m, n,
5110 $ ldasrc, ldadst, rsrc, csrc,
5111 $ nprow, npcol
5112 END IF
5113 END IF
5114*
5115* Once we've printed out errors, can re-use buf space
5116*
5117 nerr = 0
5118 END IF
5119 60 CONTINUE
5120 70 CONTINUE
5121 80 CONTINUE
5122 90 CONTINUE
5123 100 CONTINUE
5124 110 CONTINUE
5125*
5126 IF( verb .LT. 2 ) THEN
5127 nfail = testnum
5128 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
5129 $ mem(errdptr), tfail )
5130 END IF
5131 IF( iam .EQ. 0 ) THEN
5132 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
5133 IF( nfail+nskip .EQ. 0 ) THEN
5134 WRITE(outnum, 8000 ) testnum
5135 ELSE
5136 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
5137 $ nskip, nfail
5138 END IF
5139 END IF
5140*
5141* Log whether their were any failures
5142*
5143 testok = allpass( (nfail.EQ.0) )
5144*
5145 1000 FORMAT('DOUBLE PRECISION BSBR TESTS: BEGIN.' )
5146 2000 FORMAT(1x,a7,3x,10i6)
5147 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
5148 $ 5x,a1,5x,a1)
5149 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
5150 $ ' LDAD RSRC CSRC P Q')
5151 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
5152 $ '----- ---- ---- ---- ----')
5153 7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
5154 8000 FORMAT('DOUBLE PRECISION BSBR TESTS: PASSED ALL',
5155 $ i5, ' TESTS.')
5156 9000 FORMAT('DOUBLE PRECISION BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
5157 $ i5,' SKIPPED,',i5,' FAILED.')
5158*
5159 RETURN
5160*
5161* End of DBSBRTEST.
5162*
dchkmat
subroutine dchkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:9071
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
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
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 caller graph for this function: