subroutine aptltob (floga, nbase, ndigm, idiga, ndiga, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTLTOB c c call aptltob (floga, nbase, ndigm, idiga, ndiga, nerr) c c Version: aptltob Updated 2006 May 12 14:00. c aptltob Originated 2005 July 28 14:00. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To translate floga, the log to the base 10 of a positive decimal c floating point number, into the nearest big integer "a", stored c as the array of ndiga non-negative base nbase digits c idiga(n), n = 1, ndiga. c c The ndiga digits idiga are the base nbase digits c representing the integer ideca nearest to the non-negative c decimal floating point number floga, in order from most c significant to least significant, using the equation: c ideca = sum (idiga(n) * nbase^(N-n), n = 1, N = ndiga). c c To obtain floga from the integer array idiga, call aptbtod. c Flag nerr indicates any input error. c c See aptbtod, aptbadd, aptbsub, aptbmul, aptbdiv, aptbpow, c aptbrtn, aptbfac. c c Input: floga, nbase, ndigm. c c Output: idiga, ndiga, nerr. c c Calls: aptbrev c c Glossary: c c floga Input The log to the base 10 of a positive decimal floating c point number, stored in a single machine c word. Note: log10 (x) = log (x) / log (10), where c log (x) is the log of x to any base. c c idiga Output An array of integers, each representing a single c "digit" in the base nbase representation of the c integer ideca nearest to the decimal floating point c number fdeca = 10.0**floga, in order from most to c least significant. c If nbase exceeds 10, each "digit" may require 2 or c more integers. For example, for floga = 4.821E3 c (decimal), and nbase = 16 (hexadecimal), c idiga(n) = (1, 2, 13, 5 c ideca = 1 * 4096 + 2 * 256 + 13 * 16 + 5 * 1. c c In the usual hexadecimal notation 13 would be c represented by the letter "D", with ideca = 12D5 hex. c c Also note the equation: c ideca = sum (n = 1, ndiga) idiga*nbase**(n-1). c c nbase Input The number base in which result idiga will be c expressed. Must be 2 or more. c c ndiga Output The number of words in the integer array idiga. c Memory space for idiga must be at least ndigm, c and ndiga may not exceed ndigm. c c ndigm Input The maximum number of words allowed in integer array c idiga. Memory space for idiga must be at least c ndigm, and ndigm must be at least as big as c 1 + floga / log10 (nbase). c c nerr Output Indicates an input or a result error, if not zero. c 1 if nbase is less than 2. c 2 if ndigm is less than 1. c 3 if ndigm is insufficient to store integer array c idiga. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Dimensioned arguments. integer idiga(1) cbugc***DEBUG begins. cbug 9901 format (/ 'aptltob translating 10.0**floga to base nbase,' / cbug & ' with digits in idiga(n), n = 1, ndiga <= ndigm,' / cbug & ' in order from most to least significant.' / cbug & ' floga =',1pe25.18,', nbase =',i10,', ndigm =',i7,'.') cbug write ( 3, 9901) floga, nbase, ndigm cbugc***DEBUG ends. c.... Initialize. ndiga = 0 do n = 1, ndigm idiga(n) = 0 enddo c.... Test for input errors. nerr = 0 if (nbase .lt. 2) then nerr = 1 go to 210 endif if (ndigm .lt. 1) then nerr = 2 go to 210 endif c.... See if "a" rounds off to zero. flogh = log10 (0.5) if (floga .lt. flogh) then ndiga = 1 idiga(1) = 0 go to 210 endif c.... Find biggest power of nbase needed. fnbase = nbase nmax = floga / log10 (fnbase) cbugcbugc***DEBUG begins. cbugcbug 9771 format ('nmax=',i6) cbugcbug write ( 3, 9771) nmax cbugcbugc***DEBUG ends. if (nmax .gt. ndigm) then nerr = 3 go to 210 endif c.... Find biggest power of nbase that has 16 decimal digits. nuse = 16 / log10 (fnbase) cbugcbugc***DEBUG begins. cbugcbug 9772 format ('nuse=',i6) cbugcbug write ( 3, 9772) nuse cbugcbugc***DEBUG ends. c.... Find factor to reduce floga to 16 decimal digits. ndiff = nmax - nuse if (ndiff .lt. 1) ndiff = 0 cbugcbugc***DEBUG begins. cbugcbug 9773 format ('ndiff=',i6) cbugcbug write ( 3, 9773) ndiff cbugcbugc***DEBUG ends. c.... Find nearest integer to reduced floating point number. fndiff = ndiff fsmall = 10.0**(floga - ndiff * log10 (fnbase)) ismall = fsmall + 0.5 cbugcbugc***DEBUG begins. cbugcbug 9774 format ('fsmall=',1pe25.18,' ismall=',i20) cbugcbug write ( 3, 9774) fsmall, ismall cbugcbugc***DEBUG ends. c.... Convert decimal integer ismall to base nbase. icarry = ismall c.... Find big number "a" in order from least to most significant digit. 110 ndiga = ndiga + 1 if (ndiga .gt. ndigm) then nerr = 4 do nn = 1, ndiga idiga(nn) = 0 enddo ndiga = 0 go to 210 endif idiga(ndiga) = mod (icarry, nbase) icarry = icarry / nbase if (icarry .gt. 0) go to 110 cbugcbugc***DEBUG begins. cbugcbug write ( 3, 9911) ndiga, nerr cbugcbug if (ndiga .gt. 0) then cbugcbug call aptbrev (idiga, ndiga, nerrb) cbugcbug do nin = 1, ndiga, 25 cbugcbug nlast = min (nin + 24, ndiga) cbugcbug write ( 3, 9912) nin, (idiga(n), n = nin, nlast) cbugcbug enddo cbugcbug call aptbrev (idiga, ndiga, nerrb) cbugcbug endif cbugcbugc***DEBUG ends. c.... Multiply "a" by nbase^ndiff to restore size (shift right ndiff digits). do n = ndiga + ndiff, 1 + ndiff, -1 idiga(n) = idiga(n-ndiff) enddo do n = 1, ndiff idiga(n) = 0 enddo ndiga = ndiga + ndiff cbugcbugc***DEBUG begins. cbugcbug write ( 3, 9911) ndiga, nerr cbugcbug if (ndiga .gt. 0) then cbugcbug call aptbrev (idiga, ndiga, nerrb) cbugcbug do nin = 1, ndiga, 25 cbugcbug nlast = min (nin + 24, ndiga) cbugcbug write ( 3, 9912) nin, (idiga(n), n = nin, nlast) cbugcbug enddo cbugcbug call aptbrev (idiga, ndiga, nerrb) cbugcbug endif cbugcbugc***DEBUG ends. 210 continue c.... Change "a" to most significant digit first. call aptbrev (idiga, ndiga, nerrb) if (nerr .ne. 0) then ndiga = 0 do n = 1, ndigm idiga(n) = -999999 enddo endif cbugc***DEBUG begins. cbug 9911 format (/ 'aptltob results: ndiga=',i3,', nerr=',i2,'.') cbug 9912 format ('bint a ',1x,i6,' = ',25i2) cbug write ( 3, 9911) ndiga, nerr cbug if (ndiga .gt. 0) then cbug do nin = 1, ndiga, 25 cbug nlast = min (nin + 24, ndiga) cbug write ( 3, 9912) nin, (idiga(n), n = nin, nlast) cbug enddo cbug endif cbugc***DEBUG ends. return c.... End of subroutine aptltob. (+1 line.) end UCRL-WEB-209832