subroutine aptbase (x, idmax, nbase, nbmax, tol, & nl, il, nr, ir, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTBASE c c call aptbase (x, idmax, nbase, nbmax, tol, c nl, il, nr, ir, nerr) c c Version: aptbase Updated 2004 October 5 14:00. c aptbase Originated 2004 October 5 14:00. c c Authors: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: Convert the decimal number x to base nbase, and return array c il(n), n = 1, nl, the digits of the integer part of x, from c right to left, and array ir(n), n = 1, nr, the digits of the c fractional part of x, from left to right. c The integer part of x may not exceed idmax digits. c Lengths nl and nr may not exceed nbmax. c Fractional parts of x less than tol * x will be ignored. c Flag nerr indicates any input errors. c c See aptbtod, aptdtob, aptbrev. c c Input: x, idmax, nbase, nbmax. c c Output: il, ir, nerr. c c Calls: (none) c c Glossary: c c idmax Input The maximum number of decimal digits in the integer c part of x. c c il(n) Output The digits in the integer part of x, expressed in c base nbase, from right to left, n = 1, nbmax. c c il(n) Output The digits in the fractional part of x, expressed in c base nbase, from left to right, n = 1, nbmax. c c nbase Input The number base to which x is to be converted. c Must be no less than 2. c c nbmax Input The maximum number of digits, in base nbase, to be c calculated, for each of the arrays il and ir. c c nerr Output Indicates an input error or incomplete result, c if not zero: c 1 if idmax is not positive. c 2 if nbase is less than 2. c 3 if nbmax is not positive. c c nl Output The number of values of il returned. c c nr Output The number of values of il returned. c c tol Input Assumed precision of x. c c x Input A decimal number, in floating point format, with no c more than idmax digits in the integer part. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Declarations for arguments. integer nbmax ! Max size of arrays il and ir. integer idmax ! Max no. of digits in integer part of x. integer il(1) ! Digits right to left in integer part. integer ir(1) ! Digits left to right in fractional part. integer nbase ! The number base to which to convert x. integer nerr ! Error flag, zero if no errors. integer nl ! Number of values of il returned. integer nr ! Number of values of ir returned. real tol ! Ignore fractional parts < tol * x. real x ! A decimal floating point number. c.... Declarations for local variables. integer idiv ! Nearest integer <= intx / nbase. integer isign ! -1 if x is negative, otherwise 1. integer n ! Index in arrays il and ir, 1 to nbmax. real fintx ! Nearest integer <= x. real fracx ! Difference xabs - fintx. real fbase ! Floating point value of nbase. real xabs ! Absolute value of x. cbugc***DEBUG begins. cbug 9901 format (/ 'aptbase converting decimal x =',1pe22.15,' to base ', cbug & i8 / ' idmax =',i5,' nbmax =',i5,' tol =',1pe22.15) cbug write ( 3, 9901) x, nbase, idmax, nbmax, tol cbugc***DEBUG ends. c.... Initialize. if (x .lt. 0.0) then isign = -1 xabs = -x else isign = 1 xabs = x endif nl = 0 nr = 0 if (nbmax .gt. 0) then do n = 1, nbmax il(n) = 0 ir(n) = 0 enddo endif nerr = 0 c.... Test for input errors. if (idmax .lt. 1) then nerr = 1 go to 210 endif if (nbase .lt. 2) then nerr = 2 go to 210 endif if (nbmax .lt. 1) then nerr = 3 go to 210 endif c.... Convert the integer part of x to base nbase. errx = abs (tol * x) intx = xabs + errx fintx = intx if(intx .eq. 0) go to 120 do n = 1, nbmax nl = nl + 1 il(nl) = isign * mod (intx, nbase) intx = intx / nbase if (intx .eq. 0) go to 120 cbugcbugc***DEBUG begins. cbugcbug 9701 format ('n =',i3,' il =',i5,' intx =',i5) cbugcbug write (3, 9701) n, il(n), intx cbugcbugc***DEBUG ends. enddo c.... Convert the fractional part of x to base nbase. 120 fracx = xabs - fintx if (abs (fracx) .le. errx) then go to 210 endif fbase = nbase do n = 1, nbmax fmul1 = fracx * fbase fmul2 = fracx * fbase * (1.0 + abs (tol)) nr = nr + 1 ir(nr) = fmul2 fracx = fmul1 - ir(nr) ir(nr) = isign * ir(nr) if (abs (fracx) .lt. errx) then go to 210 endif errx = errx * fbase cbugcbugc***DEBUG begins. cbugcbug 9702 format ('n =',i3,' fmul1 =',1pe12.5,' fracx =',1pe12.5, cbugcbug & ' errx =',1pe12.5) cbugcbug write (3, 9702) n, fmul1, fracx, errx cbugcbugc***DEBUG ends. enddo 210 continue cbugc***DEBUG begins. cbug 9903 format (/ 'aptbase done. nerr =',i2,' nl =',i3,' nr =',i3 /) cbug 9904 format ('n =',i3,' il(n) =',i5) cbug 9905 format ('n =',i3,' ir(n) =',i5) cbug 9999 format (' ') cbug write ( 3, 9903) nerr, nl, nr cbug if(nerr .eq. 0) then cbug if (nl .ge. 1) then cbug write ( 3, 9904) (n, il(n), n = nl, 1, -1) cbug endif cbug write ( 3, 9999) cbug if (nr .ge. 1) then cbug write ( 3, 9905) (n, ir(n), n = 1, nr) cbug endif cbug endif cbugc***DEBUG ends. return c.... End of subroutine aptbase. (+1 line.) end UCRL-WEB-209832