subroutine aptalsh (xl, xr, nbins, nb, np, xran, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTALSH
c
c call aptalsh (xl, xr, nbins, nb, np, xran, nerr)
c
c Version: aptalsh Updated 1990 July 19 13:00.
c aptalsh Originated 1990 July 19 13:00.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To randomly sample np values of xran from nbins bins.
c Each bin has a relative probability distribution function
c which is uniform from xl(n) on the left to xr(n) on the right.
c Each value xran(n) is to be sampled from bin nb(n), where nb
c must be in the range from 1 to nbins.
c Flag nerr indicates any input error.
c
c Note: Use subroutines aptalsb, aptalst, aptcums, aptcumt,
c apteqsb or apteqxs to randomly sample the bin indices nb
c from any tabulated aliased, cumulative, or equal-probability
c probability distribution function.
c Use subroutine aptalsl instead of aptalsh when the distribution
c in each bin is linear instead of uniform.
c
c Input: xl, xr, nbins, nb, np.
c
c Output: xran, nerr.
c
c Glossary:
c
c nb Input Bin number for which a value of xran is to be randomly
c sampled. Must be in the range from 1 to nbins.
c Size np.
c
c nbins Input Size of arrays xl, xr.
c
c nerr Output Indicates an input error, if not 0.
c 1 if nbins is not positive.
c 2 if np is not positive.
c
c np Input Number of random samples xran. Size of nb, xran.
c
c xl, xr Input Values of random variable xran at the left and right
c boundaries of the bin, respectively. Size nbins.
c
c xran Output Randomly sampled value from bin nb(n). Size np.
c in the range from xl(nb(n)) to xr(nb(n).
c In a bin, the expected value of xran is
c = 0.5 * (xl + xr).
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
c---- Index of bin to be sampled.
dimension nb (1)
c---- Value of xran at left of bin.
dimension xl (1)
c---- Value of xran at right of bin.
dimension xr (1)
c---- Randomly sampled value of xran.
dimension xran (1)
c.... Local variables.
c---- Index in local array.
common /laptalsh/ n
c---- First index of subset of data.
common /laptalsh/ n1
c---- Last index of subset of data.
common /laptalsh/ n2
c---- Index of a bin.
common /laptalsh/ nbin
c---- Index in external array.
common /laptalsh/ nn
c---- Size of current subset of data.
common /laptalsh/ ns
c---- Random number from 0.0 to 1.0.
common /laptalsh/ ranfp (64)
cbugc***DEBUG begins.
cbugc---- Mean value of sample in bin.
cbug common /laptalsh/ xavg
cbugc---- Total of samples in bin.
cbug common /laptalsh/ xtot
cbug 9901 format (/ 'aptalsh sampling from specified uniform bins.' /
cbug & (i3,' xl,xr=',1p2e22.14))
cbug 9902 format (/ 'np=',i5,' nb=' / (20i4))
cbug write ( 3, 9901) (n, xl(n), xr(n), n = 1, nbins)
cbug write ( 3, 9902) np, (nb(n), n = 1, np)
cbugc***DEBUG ends.
c.... initialize.
nerr = 0
c.... Test for input errors.
if (nbins .le. 0) then
nerr = 1
go to 210
endif
if (np .le. 0) then
nerr = 2
go to 210
endif
c.... Set up the indices of the first subset of data.
n1 = 1
n2 = min (np, 64)
c---- Loop over subset of samples.
110 ns = n2 - n1 + 1
c.... Generate ns pairs of random numbers.
c---- Loop over local arrays.
do 120 n = 1, ns
ranfp(n) = ranf( )
c---- End of loop over local arrays.
120 continue
c.... Randomly sample values of xran from the bins.
c---- Loop over samples.
do 130 n = 1, ns
nn = n + n1 - 1
nbin = nb(nn)
xran(nn) = xl(nbin) + ranfp(n) * (xr(nbin) - xl(nbin))
c---- End of loop over samples.
130 continue
c.... See if all data subsets are done.
c---- Do another subset of samples.
if (n2 .lt. np) then
n1 = n2 + 1
n2 = min (np, n1 + 63)
c---- End of loop over subset of samples.
go to 110
endif
cbugc***DEBUG begins.
cbug 9903 format (/ 'aptalsh results: xran')
cbug 9904 format (' n=',i5,' nb=',i3,' xran=',1pe22.14)
cbug write ( 3, 9903)
cbug write ( 3, 9904) (n, nb(n), xran(n), n = 1, np)
cbug
cbug 9905 format (/ ' summary by bins:')
cbug 9906 format (i5,' xavg=',1pe22.14,' samples=',i5)
cbug write ( 3, 9905)
cbugc---- Loop over bins.
cbug do 150 nbin = 1, nbins
cbug ns = 0
cbug xtot = 0.0
cbugc---- Loop over samples.
cbug do 140 n = 1, np
cbug if (nb(n) .eq. nbin) then
cbug ns = ns + 1
cbug xtot = xtot + xran(n)
cbug endif
cbugc---- End of loop over samples.
cbug 140 continue
cbug xavg = xtot / (ns + 1.e-99)
cbug write ( 3, 9906) nbin, xavg, ns
cbugc---- End of loop over bins.
cbug 150 continue
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptalsh. (+1 line.)
end
UCRL-WEB-209832