subroutine apthexa (x, nchar, ahex, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTHEXA
c
c call apthexa (x, nchar, ahex, nerr)
c
c Version: apthexa Updated 2001 October 23 14:00.
c apthexa Originated 2001 October 16 16:00.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To convert the real (floating point) number x to a hexadecimal
c character string ahex with nchar characters and nchar - 7
c hexadecimal digits, in format +a.bcdefghijklmnopqH+xyz (with
c signs as appropriate), with a, b, c, ... the hexadecimal digits,
c and xyz the three-digit hexadecimal exponent (places to move the
c hexadecimal point). Further processing could be done to remove
c the "+" characters, to remove one or more characters "0"
c preceding the "H", or to eliminate the character "H", leaving
c the following sign.
c Flag nerr indicates any input or result error.
c
c Input: x, nchar.
c
c Output: ahex, nerr.
c
c Glossary:
c
c ahex Output ASCII representation of the hexadecimal equivalent of
c x, consisting of a sign, a hexadecimal integer part
c with one digit, a hexadecimal point, a
c hexadecimal fractional part with nchar - 8 digits,
c an exponent indicator H, a sign, and a hexadecimal
c exponent with 3 digits, indicating the number of
c places to shift the hexadecimal point.
c Will contain a total of nchar characters.
c Size 1, if character*nchar, up to
c Size nchar, if character*1.
c
c nchar Input The number of characters in ahex. For 64-bit real
c (floating point) numbers, 21 should be enough
c to obtain all significant figures.
c
c nerr Output Indicates an input error.
c 1 if nchar < 8.
c
c x Input A real (floating point) decimal number.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
implicit none
c.... Output arguments.
character*1 ahex(1) ! Hexadecimal equiv of x, in ASCII.
c.... Input arguments.
integer nchar ! # of actual characters in ahex.
integer nerr ! Input error indicator.
real x ! A real (floating point) number.
c.... Local variables.
character*1 adigit(0:15) ! Hexadecimal digits.
integer iexp ! Decimal xponent of xnorm.
integer intx ! Decimal integer part of xnorm.
integer n ! Character index in ahex.
integer nn ! Nonblank haracter index in ahex.
real xfract ! Fractional part of xnorm.
real xnorm ! Normalized positive form of x.
real xnxt ! Remainder of xnorm.
c.... Initialize adigit.
data adigit / '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
& 'A', 'B', 'C', 'D', 'E', 'F' /
cbugc...DEBUG begins.
cbug 9901 format (/ 'apthexa translating decimal to ASCII hexadecimal.' /
cbug & ' nchar=',i3,'. x =',1pe22.14 )
cbug write ( 3, 9901) nchar, x
cbugc...DEBUG ends.
c.... Test for errors.
nerr = 0
do 105 n = 1, nchar
ahex(n) = '?'
105 continue
if (nchar .lt. 8) then
nerr = 1
go to 210
endif
c.... Initialize.
do 110 n = 1, nchar
ahex(n) = '0'
110 continue
ahex(1) = '+'
if (x .lt. 0.0) ahex(1) = '-'
ahex(3) = '.'
ahex(nchar-3) = '+'
ahex(nchar-4) = 'H'
cbugcbugc...DEBUG begins.
cbugcbug 9902 format (' ahex =',80a1)
cbugcbug write ( 3, 9902) (ahex(n), n = 1, nchar)
cbugcbugc...DEBUG ends.
c.... Find the normalized form of x, and the exponent in decimal.
if (x .eq. 0.0) go to 210
xnorm = abs (x)
iexp = log (xnorm) / log (16.0)
xnorm = xnorm / 16.0**iexp
120 if (xnorm .ge. 16.0) then
iexp = iexp + 1
xnorm = xnorm / 16.0
go to 120
endif
140 if (xnorm .lt. 0.0625) then
iexp = iexp - 1
xnorm = xnorm * 16.0
go to 140
endif
intx = xnorm
if (intx .eq. 0) then
iexp = iexp - 1
xnorm = xnorm * 16
endif
cbugcbugc...DEBUG begins.
cbugcbug 9903 format (' iexp = ',i5 )
cbugcbug write ( 3, 9903) iexp
cbugcbugc...DEBUG ends.
if (iexp .lt. 0) ahex(nchar-3) = '-'
c.... Find the integer part of xnorm.
intx = xnorm
ahex (2) = adigit(intx)
cbugcbugc...DEBUG begins.
cbugcbug write ( 3, 9902) (ahex(n), n = 1, nchar)
cbugcbugc...DEBUG ends.
c==============================================================
c....FIX THIS PART.
c.... Convert the decimal fraction into hexadecimal.
xfract = mod (xnorm, 1.0)
if (xfract .eq. 0.0) go to 170
if (nchar .eq. 8) go to 170
do 150 n = 4, nchar - 5
xnxt = xfract * 16.0
intx = xnxt
ahex(n) = adigit(intx)
xfract = xnxt - intx
cbugcbugc...DEBUG begins.
cbugcbug 9905 format (' n=',i3,' intx=',i3,' xnxt=',1pe22.14,
cbugcbug & ' xfract=',1pe22.14)
cbugcbug write ( 3, 9905) n, intx, xnxt, xfract
cbugcbugc...DEBUG ends.
if (xfract .eq. 0.0) go to 170
150 continue
cbugcbugc...DEBUG begins.
cbugcbug write ( 3, 9902) (ahex(n), n = 1, nchar)
cbugcbugc...DEBUG ends.
170 continue
c==============================================================
c.... Convert the exponent into hexadecimal.
intx = abs (iexp)
if (intx .eq. 0) go to 180
n = mod (intx, 16)
ahex(nchar)= adigit(n)
intx = intx / 16.0
if (intx .eq. 0) go to 180
n = mod (intx, 16)
ahex(nchar-1)= adigit(n)
intx = intx / 16.0
if (intx .eq. 0) go to 180
n = mod (intx, 16)
ahex(nchar-2)= adigit(n)
180 continue
210 continue
cbugc...DEBUG begins.
cbug 9906 format (/ 'apthexa results: nerr = ',i3 /
cbug & ' ahex =',80a1)
cbug write ( 3, 9906) nerr, (ahex(n), n = 1, nchar)
cbugc...DEBUG ends.
return
c.... End of subroutine apthexa. (+1 line.)
end
UCRL-WEB-209832