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

◆ ibsbrtest()

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

Definition at line 3921 of file blacstest.f.

3925*
3926* -- BLACS tester (version 1.0) --
3927* University of Tennessee
3928* December 15, 1994
3929*
3930*
3931* .. Scalar Arguments ..
3932 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
3933 INTEGER MEMLEN
3934* ..
3935* .. Array Arguments ..
3936 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
3937 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
3938 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
3939 INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
3940 INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
3941 INTEGER MEM(MEMLEN)
3942* ..
3943*
3944* Purpose
3945* =======
3946* ITESTBSBR: Test integer broadcast
3947*
3948* Arguments
3949* =========
3950* OUTNUM (input) INTEGER
3951* The device number to write output to.
3952*
3953* VERB (input) INTEGER
3954* The level of verbosity (how much printing to do).
3955*
3956* NSCOPE (input) INTEGER
3957* The number of scopes to be tested.
3958*
3959* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
3960* Values of the scopes to be tested.
3961*
3962* NTOP (input) INTEGER
3963* The number of topologies to be tested.
3964*
3965* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
3966* Values of the topologies to be tested.
3967*
3968* NSHAPE (input) INTEGER
3969* The number of matrix shapes to be tested.
3970*
3971* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
3972* Values of UPLO to be tested.
3973*
3974* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
3975* Values of DIAG to be tested.
3976*
3977* NMAT (input) INTEGER
3978* The number of matrices to be tested.
3979*
3980* M0 (input) INTEGER array of dimension (NMAT)
3981* Values of M to be tested.
3982*
3983* M0 (input) INTEGER array of dimension (NMAT)
3984* Values of M to be tested.
3985*
3986* N0 (input) INTEGER array of dimension (NMAT)
3987* Values of N to be tested.
3988*
3989* LDAS0 (input) INTEGER array of dimension (NMAT)
3990* Values of LDAS (leading dimension of A on source process)
3991* to be tested.
3992*
3993* LDAD0 (input) INTEGER array of dimension (NMAT)
3994* Values of LDAD (leading dimension of A on destination
3995* process) to be tested.
3996* NSRC (input) INTEGER
3997* The number of sources to be tested.
3998*
3999* RSRC0 (input) INTEGER array of dimension (NDEST)
4000* Values of RSRC (row coordinate of source) to be tested.
4001*
4002* CSRC0 (input) INTEGER array of dimension (NDEST)
4003* Values of CSRC (column coordinate of source) to be tested.
4004*
4005* NGRID (input) INTEGER
4006* The number of process grids to be tested.
4007*
4008* CONTEXT0 (input) INTEGER array of dimension (NGRID)
4009* The BLACS context handles corresponding to the grids.
4010*
4011* P0 (input) INTEGER array of dimension (NGRID)
4012* Values of P (number of process rows, NPROW).
4013*
4014* Q0 (input) INTEGER array of dimension (NGRID)
4015* Values of Q (number of process columns, NPCOL).
4016*
4017* TFAIL (workspace) INTEGER array of dimension (NTESTS)
4018* If VERB < 2, serves to indicate which tests fail. This
4019* requires workspace of NTESTS (number of tests performed).
4020*
4021* MEM (workspace) INTEGER array of dimension (MEMLEN)
4022* Used for all other workspaces, including the matrix A,
4023* and its pre and post padding.
4024*
4025* MEMLEN (input) INTEGER
4026* The length, in elements, of MEM.
4027*
4028* =====================================================================
4029*
4030* .. External Functions ..
4031 LOGICAL ALLPASS, LSAME
4032 INTEGER IBTMYPROC, IBTSIZEOF
4033 EXTERNAL allpass, lsame, ibtmyproc, ibtsizeof
4034* ..
4035* .. External Subroutines ..
4036 EXTERNAL blacs_gridinfo
4037 EXTERNAL itrbs2d, igebs2d, itrbr2d, igebr2d
4038 EXTERNAL iinitmat, ichkmat, ichkpad, ibtcheckin
4039* ..
4040* .. Local Scalars ..
4041 CHARACTER*1 SCOPE, TOP, UPLO, DIAG
4042 LOGICAL TESTOK, INGRID
4043 INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
4044 INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
4045 INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
4046 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
4047 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE
4048 INTEGER SCHECKVAL, RCHECKVAL
4049* ..
4050* .. Executable Statements ..
4051*
4052 scheckval = -1
4053 rcheckval = -2
4054*
4055 iam = ibtmyproc()
4056 isize = ibtsizeof('I')
4057 isize = ibtsizeof('I')
4058*
4059* Verify file parameters
4060*
4061 IF( iam .EQ. 0 ) THEN
4062 WRITE(outnum, *) ' '
4063 WRITE(outnum, *) ' '
4064 WRITE(outnum, 1000 )
4065 IF( verb .GT. 0 ) THEN
4066 WRITE(outnum,*) ' '
4067 WRITE(outnum, 2000) 'NSCOPE:', nscope
4068 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
4069 WRITE(outnum, 2000) 'NTOP :', ntop
4070 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
4071 WRITE(outnum, 2000) 'NSHAPE:', nshape
4072 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
4073 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
4074 WRITE(outnum, 2000) 'NMAT :', nmat
4075 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
4076 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
4077 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
4078 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
4079 WRITE(outnum, 2000) 'NSRC :', nsrc
4080 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
4081 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
4082 WRITE(outnum, 2000) 'NGRIDS:', ngrid
4083 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
4084 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
4085 WRITE(outnum, 2000) 'VERB :', verb
4086 WRITE(outnum,*) ' '
4087 END IF
4088 IF( verb .GT. 1 ) THEN
4089 WRITE(outnum,5000)
4090 WRITE(outnum,6000)
4091 END IF
4092 END IF
4093*
4094* Find biggest matrix, so we know where to stick error info
4095*
4096 i = 0
4097 DO 10 ima = 1, nmat
4098 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4099 IF( k .GT. i ) i = k
4100 10 CONTINUE
4101 maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
4102 IF( maxerr .LT. 1 ) THEN
4103 WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
4104 CALL blacs_abort(-1, 1)
4105 END IF
4106 errdptr = i + 1
4107 erriptr = errdptr + maxerr
4108 nerr = 0
4109 testnum = 0
4110 nfail = 0
4111 nskip = 0
4112*
4113* Loop over grids of matrix
4114*
4115 DO 110 igr = 1, ngrid
4116*
4117 context = context0(igr)
4118 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4119*
4120 ingrid = ( nprow .GT. 0 )
4121*
4122 DO 100 isc = 1, nscope
4123 scope = scope0(isc)
4124 DO 90 ito = 1, ntop
4125 top = top0(ito)
4126*
4127* If testing multipath ('M') or general tree ('T'),
4128* need to loop over calls to BLACS_SET
4129*
4130 IF( lsame(top, 'M') ) THEN
4131 setwhat = 11
4132 IF( scope .EQ. 'R' ) THEN
4133 istart = -(npcol - 1)
4134 istop = -istart
4135 ELSE IF (scope .EQ. 'C') THEN
4136 istart = -(nprow - 1)
4137 istop = -istart
4138 ELSE
4139 istart = -(nprow*npcol - 1)
4140 istop = -istart
4141 ENDIF
4142 ELSE IF( lsame(top, 'T') ) THEN
4143 setwhat = 12
4144 istart = 1
4145 IF( scope .EQ. 'R' ) THEN
4146 istop = npcol - 1
4147 ELSE IF (scope .EQ. 'C') THEN
4148 istop = nprow - 1
4149 ELSE
4150 istop = nprow*npcol - 1
4151 ENDIF
4152 ELSE
4153 setwhat = 0
4154 istart = 1
4155 istop = 1
4156 ENDIF
4157 DO 80 ish = 1, nshape
4158 uplo = uplo0(ish)
4159 diag = diag0(ish)
4160*
4161 DO 70 ima = 1, nmat
4162 m = m0(ima)
4163 n = n0(ima)
4164 ldasrc = ldas0(ima)
4165 ldadst = ldad0(ima)
4166*
4167 DO 60 iso = 1, nsrc
4168 testnum = testnum + 1
4169 rsrc = rsrc0(iso)
4170 csrc = csrc0(iso)
4171 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
4172 nskip = nskip + 1
4173 GOTO 60
4174 END IF
4175 IF( verb .GT. 1 ) THEN
4176 IF( iam .EQ. 0 ) THEN
4177 WRITE(outnum, 7000)
4178 $ testnum, 'RUNNING',scope, top, uplo, diag,
4179 $ m, n, ldasrc, ldadst, rsrc, csrc,
4180 $ nprow, npcol
4181 END IF
4182 END IF
4183*
4184 testok = .true.
4185 ipre = 2 * m
4186 ipost = ipre
4187 aptr = ipre + 1
4188*
4189* If I am in scope
4190*
4191 IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
4192 $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
4193 $ (scope .EQ. 'A') ) THEN
4194*
4195* source process generates matrix and sends it
4196*
4197 IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
4198 CALL iinitmat(uplo, diag, m, n, mem,
4199 $ ldasrc, ipre, ipost,
4200 $ scheckval, testnum,
4201 $ myrow, mycol )
4202*
4203 DO 20 j = istart, istop
4204 IF( j.EQ.0 ) GOTO 20
4205 IF( setwhat.NE.0 )
4206 $ CALL blacs_set(context, setwhat, j)
4207 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4208 CALL itrbs2d(context, scope, top,
4209 $ uplo, diag, m, n,
4210 $ mem(aptr), ldasrc )
4211 ELSE
4212 CALL igebs2d(context, scope, top,
4213 $ m, n, mem(aptr),
4214 $ ldasrc )
4215 END IF
4216 20 CONTINUE
4217*
4218* Destination processes
4219*
4220 ELSE IF( ingrid ) THEN
4221 DO 40 j = istart, istop
4222 IF( j.EQ.0 ) GOTO 40
4223 IF( setwhat.NE.0 )
4224 $ CALL blacs_set(context, setwhat, j)
4225*
4226* Pad entire matrix area
4227*
4228 DO 30 k = 1, ipre+ipost+ldadst*n
4229 mem(k) = rcheckval
4230 30 CONTINUE
4231*
4232* Receive matrix
4233*
4234 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4235 CALL itrbr2d(context, scope, top,
4236 $ uplo, diag, m, n,
4237 $ mem(aptr), ldadst,
4238 $ rsrc, csrc)
4239 ELSE
4240 CALL igebr2d(context, scope, top,
4241 $ m, n, mem(aptr),
4242 $ ldadst, rsrc, csrc)
4243 END IF
4244*
4245* Check for errors in matrix or padding
4246*
4247 i = nerr
4248 CALL ichkmat(uplo, diag, m, n,
4249 $ mem(aptr), ldadst, rsrc, csrc,
4250 $ myrow, mycol, testnum, maxerr,
4251 $ nerr, mem(erriptr),
4252 $ mem(errdptr))
4253*
4254 CALL ichkpad(uplo, diag, m, n, mem,
4255 $ ldadst, rsrc, csrc, myrow,
4256 $ mycol, ipre, ipost, rcheckval,
4257 $ testnum, maxerr, nerr,
4258 $ mem(erriptr), mem(errdptr))
4259 40 CONTINUE
4260 testok = ( i .EQ. nerr )
4261 END IF
4262 END IF
4263*
4264 IF( verb .GT. 1 ) THEN
4265 i = nerr
4266 CALL ibtcheckin(0, outnum, maxerr, nerr,
4267 $ mem(erriptr), mem(errdptr),
4268 $ tfail)
4269 IF( iam .EQ. 0 ) THEN
4270 testok = ( testok .AND. (i.EQ.nerr) )
4271 IF( testok ) THEN
4272 WRITE(outnum,7000)testnum,'PASSED ',
4273 $ scope, top, uplo, diag, m, n,
4274 $ ldasrc, ldadst, rsrc, csrc,
4275 $ nprow, npcol
4276 ELSE
4277 nfail = nfail + 1
4278 WRITE(outnum,7000)testnum,'FAILED ',
4279 $ scope, top, uplo, diag, m, n,
4280 $ ldasrc, ldadst, rsrc, csrc,
4281 $ nprow, npcol
4282 END IF
4283 END IF
4284*
4285* Once we've printed out errors, can re-use buf space
4286*
4287 nerr = 0
4288 END IF
4289 60 CONTINUE
4290 70 CONTINUE
4291 80 CONTINUE
4292 90 CONTINUE
4293 100 CONTINUE
4294 110 CONTINUE
4295*
4296 IF( verb .LT. 2 ) THEN
4297 nfail = testnum
4298 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
4299 $ mem(errdptr), tfail )
4300 END IF
4301 IF( iam .EQ. 0 ) THEN
4302 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
4303 IF( nfail+nskip .EQ. 0 ) THEN
4304 WRITE(outnum, 8000 ) testnum
4305 ELSE
4306 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
4307 $ nskip, nfail
4308 END IF
4309 END IF
4310*
4311* Log whether their were any failures
4312*
4313 testok = allpass( (nfail.EQ.0) )
4314*
4315 1000 FORMAT('INTEGER BSBR TESTS: BEGIN.' )
4316 2000 FORMAT(1x,a7,3x,10i6)
4317 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
4318 $ 5x,a1,5x,a1)
4319 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
4320 $ ' LDAD RSRC CSRC P Q')
4321 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
4322 $ '----- ---- ---- ---- ----')
4323 7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
4324 8000 FORMAT('INTEGER BSBR TESTS: PASSED ALL',
4325 $ i5, ' TESTS.')
4326 9000 FORMAT('INTEGER BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
4327 $ i5,' SKIPPED,',i5,' FAILED.')
4328*
4329 RETURN
4330*
4331* End of IBSBRTEST.
4332*
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
ichkmat
subroutine ichkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:6943
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
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: