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