subroutine aptnint (x, dx, tola, tolr, nrnd, xr)
c.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTNINT
c
c call aptnint (x, dx, tola, tolr, nrnd, xr)
c
c Version: aptnint Updated 2000 August 28 17:20.
c aptnint Originated 2000 August 22 15:00.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To round off x to the nearest integer multiple of dx,
c if x is within tola + tolr * abs (x) of that multiple,
c if dx is not zero, if abs (x / dx) does not exceed the
c largest machine integer or rmax, where rmax is the largest
c exact real number.
c Flag nrnd indicates the meaning of the result xr: -1 if dx = 0
c or x / dx exceeds the largest machine integer or rmax,
c and xr = x; 0 if no roundoff occurred and xr = x;
c and 1 if roundoff occurred and xr = dx * nint (x / dx).
c
c For example, to round off x to the nearest integer, if that
c integer is within 1.e-11 * x of x, set dx = 1.0, tola = 0, and
c tolr = 1.e-11. If nrnd = 1, xr will be a real number with an
c integer value. If nrnd = -1, x exceeds the largest machine
c integer.
c
c For example, to always round off x to the nearest 1/12, set
c dx = 1 / 12 = 0.0833333333333333..., tola = 1.0 (anything larger
c than 1 / 24), tolr = 0.0. If nrnd = 1, xr will be an integer
c multiple of 1/12. If nrnd = -1, 12 * x exceeds the largest
c machine integer.
c
c Input: x, dx, tola, tolr.
c
c Output: nrnd, xr.
c
c Glossary:
c
c dx Input If nrnd = 1, xr will be an integer multiple of dx.
c If dx is zero, no roundoff will occur.
c
c nrnd Output Result indicator:
c -1 if no roundoff occurred, xr = x, and dx = 0 or
c abs (x / dx) exceeded the largest machine integer
c or rmax.
c 0 if no roundoff occurred, and xr = x.
c 1 if roundoff occured, and xr = dx * nint (x / dx).
c
c rmax local The largest exact real number. About 1.0e16 on a
c DEC machine with 64-bit real numbers.
c
c tola Input Absolute limit: round off if
c abs (xr - x) < tola + tolr * abs (x).
c
c tolr Input Relative limit: round off if
c abs (xr - x) < tola + tolr * abs (x).
c
c x Input Value to be rounded to an integer multiple of dx,
c if within tola + tolr * abs (x) of that multiple,
c if dx is not zero, and if x / dx does not exceed the
c largest machine integer.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
implicit none
c.... Arguments.
integer nrnd ! Result flag, 1 if x rounded off.
real dx ! Increment between rounded values.
real tola ! Absolute error factor.
real tolr ! Relative error factor.
real x ! Input value.
real xr ! Output value, x or dx * nint (x / dx).
c.... Local variables.
real diffx ! Difference between xtry and x.
real diffi ! Difference between nint (x/dx) and x/dx.
real emax ! Maximum abs (xr - x).
real rmax ! Largest exact real number.
real xtry ! Value dx * nint (x / dx) or -1.e99.
real xodx ! Value x / dx.
real xodxi ! Value nint (x / dx).
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptnint rounding off.' /
cbug & ' x,dx =',1p2e28.20 /
cbug & ' tola,r=',1p2e28.20 )
cbug write ( 3, 9901) x, dx, tola, tolr
cbugc***DEBUG ends.
c.... Initialize.
nrnd = 0
emax = abs (tola) + abs (tolr * x)
rmax = 1.0e16 ! Largest exact real number.
xr = x
xtry = -1.e99
c.... Test for input errors.
if (dx .eq. 0.0) then
nrnd = -1
go to 210
endif
c.... Find rounded value.
xodx = x / dx
xodxi = nint (xodx)
xtry = xodxi * dx
diffi = xodxi - xodx
diffx = diffi * dx
c.... See if x is close enough to rounded value.
if (abs (xodx) .gt. rmax) then
nrnd = -1
elseif (abs (diffi) .gt. 0.5) then
nrnd = -1
elseif (abs (diffx) .le. emax) then
nrnd = 1
xr = xtry
endif
210 continue
cbugc***DEBUG begins.
cbug 9902 format (/ 'aptnint results: nrnd = ',i3 /
cbug & ' x = ',1pe28.20 /
cbug & ' xtry = ',1pe28.20 /
cbug & ' diffx = ',1pe28.20 /
cbug & ' emax = ',1pe28.20 /
cbug & ' xr = ',1pe28.20 )
cbug write ( 3, 9902) nrnd, x, xtry, diffx, emax, xr
cbugc***DEBUG ends.
return
c.... End of subroutine aptnint. (+1 line.)
end
UCRL-WEB-209832