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