subroutine apthexd (asrce, isrce, nchar, iamax, idmax, iemax,
& aword, iword, fword, mtype, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTHEXD
c
c call apthexd (asrce, isrce, nchar, iamax, idmax, iemax,
c & aword, iword, fword, mtype, nerr)
c
c Version: apthexd Updated 1997 August 4 11:20.
c apthexd Originated 1993 February 16 11:50.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To translate a hexadecimal character string to a decimal
c integer or floating point number, if possible.
c The string is in array asrce, starting at character position
c isrce, and has a length of nchar characters.
c The word length in character array aword is iamax characters.
c Integers may have up to idmax hexadecimal digits.
c Floating point numbers may have exponents up to iemax
c hexadecimal digits.
c The results are stored in the character array aword, the
c decimal integer word iword, and/or the floating point word
c fword, depending on the data type of the string, mtype.
c Flag nerr indicates any input or result error.
c
c Note: Do not convert this source file to all upper or lower case.
c It contains both upper and lower case character variables.
c
c Input: asrce, isrce, nchar, idmax, iemax.
c
c Output: aword, iword, fword, mtype, nerr.
c Note: do not equivalence fword and iword.
c
c Glossary:
c
c asrce Input A character array, containing the character string to
c be translated, starting in character position isrce,
c with a length of nchar characters.
c
c aword Output A character array containing iamax characters per word,
c compatible with a calling routine argument of type
c character*iamax, or iamax words of type character*1,
c etc. Always filled with up to iamax characters of
c the character string, and right-filled with blanks
c as necessary.
c
c fword Output A decimal floating point number, initialized to zero.
c The maximum allowable exponent is iemax.
c If the string is translated into an integer
c (mtype = 2) or into a decimal floating point number
c (mtype = 3), its floating point value will be
c returned in fword. If the string is formatted as an
c integer, but contains more than idmax digits after
c any leading zeros, it will be translated into a
c floating point number, and returned in fword.
c The character string may have leading or trailing
c blanks. The first non-blank character may be a "+"
c or "-". The mantissa may contain any positive number
c of digits, but no more than one decimal point, and
c may have trailing blanks. If an exponent is given,
c it must begin with "h", "H", "+" or "-".
c An initial "h" or "H", may be followed by
c a "+" or "-". The digits of the exponent may have
c leading and trailing blanks, but no additional
c characters following any trailing blanks.
c Note: do not equivalence iword to fword.
c
c iamax Input Number of characters in each word of type character
c array aword.
c
c idmax Input Maximum number of digits in an integer. Depends on
c the machine.
c Must be positive.
c
c iemax Input Maximum size (positive or negative) of the exponent
c of a floating point number. Depends on the machine.
c Approximately 308 on a 64-bit floating point machine.
c Must be positive.
c
c isrce Input The character position in array asrec of the first
c character of the string. E. g., isrce = 1 means
c the leftmost character of asrce(1).
c Must be positive.
c
c iword Output An integer. Initialized to zero. The maximum number
c of digits is idmax. If the character string is
c translated into an integer (mtype = 2), iword will
c contain its decimal integer value, and fword will
c contain its decimal floating point value.
c Note: do not equivalence fword and iword.
c The character string may have leading or trailing
c blanks. For a hexadecimal number, the first
c non-blank character may be a "+" or "-".
c All other characters must be hexadecimal digits,
c with no more than idmax digits following any leading
c zeros.
c
c mtype Output An integer. Indicates the data type of the character
c string, and which results are returned:
c 0: Not recognizable as a hexadecimal integer or
c floating point number, and longer than iamax
c characters (nerr = 0), or a hexadecimal
c floating point number whose exponent exceeds the
c limit iemax (nerr = 5).
c Returned in aword.
c 1: Not recognizable as a hexadecimal integer or
c floating point number. String has 1 to iamax
c characters.
c Returned in aword, left-adjusted, right-filled
c with blanks, as necessary.
c 2: Character string translated into decimal integer
c mode. The integer value is returned in iword,
c and the decimal floating point value is returned
c in fword.
c Also returned in aword, as for mtype = 1.
c 3: Character string translated into decimal
c floating point mode, and returned in fword.
c The integer value can not be stored in iword,
c because of the possibility of overflow of numbers
c with large exponents. If nerr = 4, the character
c string was an integer with more than idmax
c digits.
c Also returned in aword, as for mtype = 1.
c
c nerr Output Indicates an input or result error, if not zero.
c 1 if nchar is not positive.
c 2 if isrce is not positive.
c 3 if iamax, idmax or iemax is not positive.
c 4 if an integer exceeds idmax characters. If so,
c a floating point result is returned in fword,
c with mtype = 3.
c 5 if a floating point exponent exceeds iemax.
c If so, a character string is returned in aword,
c with mtype = 0.
c
c nchar Input The number of characters in the character string.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Declarations for arguments.
dimension asrce (1) ! Array of characters.
character*1 asrce ! Array of characters.
dimension aword (1) ! Character interpretation of string.
character*1 aword ! Character interpretation of string.
c.... Local variables.
common /lapthexd/ fintadd ! Floating point idig - 1.
common /lapthexd/ fintval ! Floating point mantissa value.
common /lapthexd/ fsign ! Indicates sign of mantissa.
common /lapthexd/ icharm ! Index in aword.
common /lapthexd/ idig ! Index in array adigit or bdigit.
common /lapthexd/ intval ! Integer mantissa value.
common /lapthexd/ ipt ! Indicates position of decimal point.
common /lapthexd/ isign ! Indicates sign of mantissa.
common /lapthexd/ kdigit ! Number of exponent digits.
common /lapthexd/ kexp ! Integer exponent value.
common /lapthexd/ ksign ! Indicates sign of exponent.
common /lapthexd/ nbeg ! Index in the string.
common /lapthexd/ nc ! Index in the string.
common /lapthexd/ ndigall ! Number of mantissa digits.
common /lapthexd/ ndigit ! Number of significant digits.
common /lapthexd/ nzeros ! Number of zeroes to insert.
common /capthexd/ achar ! A single character in string.
character*1 achar
dimension adigit(16) ! Integer digits from 0 to F.
character*1 adigit
data adigit / '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
& 'A', 'B', 'C', 'D', 'E', 'F' /
dimension bdigit(16) ! Integer digits from 0 to f.
character*1 bdigit
data bdigit / '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
& 'a', 'b', 'c', 'd', 'e', 'f' /
cbugc***DEBUG begins.
cbug common /lapthexd/ nmaxa ! # of characters of asrce to write.
cbug 9901 format (/ 'apthexd translating an ASCII word.' /
cbug & ' isrce=',i6,' nchar=',i6,
cbug & ' iamax=',i3,' idmax=',i3,' iemax=',i6)
cbug 9902 format (' asrce=',64a1)
cbug write ( 3, 9901) isrce, nchar, iamax, idmax, iemax
cbug nmaxa = 8 * (1 + (isrce + nchar - 2) / 8)
cbug write ( 3, 9902) (asrce(nc), nc = 1, nmaxa)
cbugc***DEBUG ends.
c.... Initialize the output.
nerr = 0
mtype = 1
iword = 0
fword = 0.0
do 105 nc = 1, iamax ! Loop over output characters.
aword(nc) = ' '
105 continue ! End of loop over output characters.
c.... Test for input errors.
if (nchar .le. 0) then
nerr = 1
go to 210
endif
if (isrce .le. 0) then
nerr = 2
go to 210
endif
if ((iamax .le. 0) .or. (idmax .le. 0) .or. (iemax .le. 0)) then
nerr = 3
go to 210
endif
c.... Put up to iamax characters of string into aword.
icharm = nchar
if (icharm .gt. iamax) then
mtype = 0 ! Type character (>iamax) or bad f-p.
icharm = iamax
endif
do 110 nc = 1, icharm ! Loop over output characters.
aword(nc) = asrce(isrce+nc-1)
110 continue ! End of loop over output characters.
cbugcbugc***DEBUG begins.
cbugcbug 9701 format ('aword= ',24a1)
cbugcbug write ( 3, 9701) (aword(nc), nc = 1, 24)
cbugcbugc***DEBUG ends.
c=======================================================================--------
c.... Look for the beginning of the mantissa field for integers and
c.... floating point numbers. Find the first non-blank character.
do 115 nc = 1, nchar ! Loop over character string.
achar = asrce(isrce+nc-1)
if (achar .ne. ' ') go to 120
115 continue ! End of loop over character string.
cbugcbugc***DEBUG begins.
cbugcbug 9702 format ('asrce all blank.')
cbugcbug write ( 3, 9702)
cbugcbugc***DEBUG ends.
go to 210 ! All characters are blank.
c.... See if the first non-blank character is "+" or "-".
120 if (achar .eq. '-') then
nc = nc + 1
isign = -1
fsign = -1.0
elseif (achar .eq. '+') then
nc = nc + 1
isign = 1
fsign = 1.0
else
isign = 1
fsign = 1.0
endif
cbugcbugc***DEBUG begins.
cbugcbug 9703 format ('nc=',i3,' isign=',i3,' fsign=',1pe22.14)
cbugcbug write ( 3, 9703) nc, isign, fsign
cbugcbugc***DEBUG ends.
c.... See if the only non-blank character in string is "+" or "-".
if (nc .gt. nchar) go to 210 ! All characters are blank, "+" or "-".
c.... See if the first character after any sign and/or decimal point is not an
c.... integer. If so, word can not be an integer or a floating point number.
achar = asrce(isrce+nc-1)
if (achar .eq. '.') achar = asrce(isrce+nc)
do 121 idig = 1, 16
if (achar .eq. adigit(idig)) go to 122
if (achar .eq. bdigit(idig)) go to 122
121 continue
cbugcbugc***DEBUG begins.
cbugcbug 9704 format ('Unacceptable character after +-. =',a1)
cbugcbug write ( 3, 9704) achar
cbugcbugc***DEBUG ends.
go to 210
122 continue
c=======================================================================--------
c.... Found the beginning of the mantissa. Initialize counters.
intval = 0
ipt = -1000000
ndigall = 0
ndigit = 0
nzeros = 0
c.... Scan the remainder of the the mantissa and translate.
nbeg = nc
do 140 nc = nbeg, nchar ! Loop over rest of string.
achar = asrce(isrce+nc-1)
cbugcbugc***DEBUG begins.
cbugcbug 9705 format ('nc=',i3,' achar= ',a1)
cbugcbug write ( 3, 9705) nc, achar
cbugcbugc***DEBUG ends.
c.... Test for any trailing blanks after the mantissa.
if (achar .eq. ' ') go to 145 ! Blank ends mantissa.
c.... Scan for a digit or decimal point (which are part of mantissa).
do 125 idig = 1, 16 ! Loop over digits.
if (achar .eq. adigit(idig)) go to 130
if (achar .eq. bdigit(idig)) go to 130
125 continue ! End of loop over digits.
cbugcbugc***DEBUG begins.
cbugcbug 9706 format ('Not a digit. achar= ',a1)
cbugcbug write ( 3, 9706) achar
cbugcbugc***DEBUG ends.
c.... Not a digit. Test for first decimal point (only allow 1).
if ((ipt .ge. 0) .or. (achar .ne. '.')) go to 160 ! End of mantissa.
ipt = 0 ! Found first decimal point.
cbugcbugc***DEBUG begins.
cbugcbug 9707 format ('A decimal point. achar= ',a1)
cbugcbug write ( 3, 9707) achar
cbugcbugc***DEBUG ends.
go to 140
c.... Found a digit. See if zero or non-zero, if after a decimal point.
130 if (ipt .ge. 0) then ! String has a decimal point.
cbugcbugc***DEBUG begins.
cbugcbug 9708 format ('String has a decimal point.')
cbugcbug write ( 3, 9708)
cbugcbugc***DEBUG ends.
c.... Save number of zeros following the decimal point.
if (idig .eq. 1) then ! Save zeros.
nzeros = nzeros + 1
cbugcbugc***DEBUG begins.
cbugcbug 9709 format ('nzeros=',i3)
cbugcbug write ( 3, 9709) nzeros
cbugcbugc***DEBUG ends.
go to 140
endif
c.... Non-zero digit found. Include effect of zeros after decimal point.
135 if (nzeros .gt. 0) then ! String has zeros after decimal.
c.... Only allow exponents up to iemax.
if (ndigit .gt. (iemax + ipt)) then ! Exponent overflows.
nerr = 5
if (nchar .le. iamax) then
mtype = 1
else
mtype = 0
endif
go to 210
endif
c.... Only allow integers with up to idmax digits.
if (ndigit .lt. idmax) then
intval = 16 * intval
elseif (ndigit .eq. idmax) then
fintval = intval
fintval = 16.0 * fintval
else ! More than idmax digits.
fintval = 16.0 * fintval
endif
c.... Insert zeroes before next number.
ipt = ipt + 1
nzeros = nzeros - 1
ndigit = ndigit + 1
ndigall = ndigall + 1
cbugcbugc***DEBUG begins.
cbugcbug 9710 format ('ipt=',i3,' nzeros=',i3,' ndigit=',i3,' ndigall=',i3)
cbugcbug write ( 3, 9710) ipt, nzeros, ndigit, ndigall
cbugcbugc***DEBUG ends.
go to 135
endif ! Tested nzeros.
endif ! Tested ipt.
c.... Found a digit.
ndigall = ndigall + 1
c.... Ignore leading zeros.
if ((ndigit .eq. 0) .and. (ipt .lt. 0) .and.
& (idig .eq. 1)) go to 140
c.... Update the mantissa.
c.... Only allow exponents up to iemax.
if (ndigit .gt. (iemax + max (0, ipt))) then ! Exponent overflows.
nerr = 5
if (nchar .le. iamax) then
mtype = 1
else
mtype = 0
endif
go to 210
endif
c.... Only allow integers with up to idmax digits.
if (ndigit .lt. idmax) then
intval = 16 * intval + (idig - 1)
elseif (ndigit .eq. idmax) then ! Start floating point equivalent.
fintadd = idig - 1
fintval = intval
fintval = 16.0 * fintval + fintadd
else ! More than idmax digits.
fintadd = idig - 1
fintval = 16.0 * fintval + fintadd
endif
ipt = ipt + 1
ndigit = ndigit + 1
140 continue ! End of loop over rest of string.
go to 155
c=======================================================================--------
c.... The mantissa ended with a blank. Look for next non-blank character.
145 nbeg = nc
do 150 nc = nbeg, nchar ! Loop over rest of string.
achar = asrce(isrce+nc-1)
if (achar .ne. ' ') go to 160
150 continue ! End of loop over rest of string.
c=======================================================================--------
c.... Found the end of the mantissa, with no exponent field.
c.... Return a character string if no digits were found.
155 if ((ndigall .le. 0) .and. (nzeros .le. 0)) go to 210
c.... See if a decimal point was found.
if (ipt .lt. 0) then ! No decimal point.
c.... Assume floating point if over idmax digits.
if (ndigit .le. idmax) then ! Return integer and floating point.
mtype = 2 ! Type integer.
iword = isign * intval
fword = iword
else ! Return only floating point.
mtype = 3 ! Type integer, but too many digits.
fword = fsign * fintval
nerr = 4
endif
else ! A decimal point was found.
mtype = 3 ! Type floating point.
if (ndigit .le. idmax) then
fword = isign * intval
else ! Return only floating point.
fword = fsign * fintval
endif
158 if (ipt .gt. 80) then
fword = fword / 16.0**80.0
ipt = ipt - 80
go to 158
endif
if (ipt .gt. 0) then
fword = fword / 16.0**ipt
endif
endif ! Tested ipt.
go to 210
c=======================================================================--------
c.... Found the end of the mantissa. Look for the beginning of the exponent.
c.... The exponent may start with "h", "H", "+", or "-".
160 ksign = 0
if ((achar .eq. 'h') .or. (achar .eq. 'H')) then
nc = nc + 1
achar = asrce(isrce+nc-1)
ksign = 1 ! Assume positive exponent.
cbugcbugc***DEBUG begins.
cbugcbug 9711 format ('Exponent begins. nc=',i3,' achar= ',a1,' ksign=',i3)
cbugcbug write ( 3, 9711) nc, achar, ksign
cbugcbugc***DEBUG ends.
endif
if (achar .eq. '+') then ! Exponent is positive.
nc = nc + 1
ksign = 1
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9711) nc, achar, ksign
cbugcbugc***DEBUG ends.
elseif (achar .eq. '-') then ! Exponent is negative.
nc = nc + 1
ksign = -1
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9711) nc, achar, ksign
cbugcbugc***DEBUG ends.
endif
if ((nc .gt. nchar) .or. (ksign .eq. 0)) go to 210 ! Not an exponent.
c=======================================================================--------
c.... Found the beginning of the exponent. Find the next non-blank character.
nbeg = nc
do 165 nc = nbeg, nchar ! Loop over rest of string.
achar = asrce(isrce+nc-1)
if (achar .ne. ' ') go to 170
165 continue ! End of loop over rest of string.
go to 210 ! No digits in exponent.
170 kexp = 0
kdigit = 0
cbugcbugc***DEBUG begins.
cbugcbug 9712 format ('Exponent contents. nc=',i3,' achar= ',a1,' ksign=',i3)
cbugcbug write ( 3, 9712) nc, achar, ksign
cbugcbugc***DEBUG ends.
nbeg = nc
do 180 nc = nbeg, nchar ! Loop over rest of string.
achar = asrce(isrce+nc-1)
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9712) nc, achar, ksign
cbugcbugc***DEBUG ends.
if (achar .eq. ' ') go to 185 ! Imbedded blank ends exponent.
do 175 idig = 1, 16 ! Loop over digits.
if ((achar .eq. adigit(idig)) .or.
& (achar .eq. bdigit(idig))) then
kexp = 16 * kexp + (idig - 1)
kdigit = kdigit + 1
go to 180
endif
175 continue ! End of loop over digits.
go to 210 ! Not a digit. Return character string.
180 continue ! End of loop over rest of string.
go to 195
c=======================================================================--------
c.... Found imbedded blank in exponent. The rest of the string must be blank.
185 nbeg = nc
do 190 nc = nbeg, nchar ! Loop over rest of string.
achar = asrce(isrce+nc-1)
if (achar .ne. ' ') go to 210 ! Illegal character in exponent field.
190 continue ! End of loop over rest of string.
c=======================================================================--------
c.... Found the end of the exponent.
c.... Return a character string if no digits were found in exponent field.
195 if (kdigit .le. 0) go to 210
c.... Translate the mantissa to floating point.
mtype = 3 ! Type real, or integer > idmax.
if (ndigit .le. idmax) then
fword = isign * intval
else
fword = fsign * fintval
endif
c.... Find the exponent.
kexp = ksign * kexp
if (ipt .gt. 0) kexp = kexp - ipt
if (abs (kexp + ndigit - 1) .gt. iemax) then
nerr = 5 ! Exceeded maximum exponent.
if (nchar .le. iamax) then
mtype = 1
else
mtype = 0
endif
fword = 0.0
go to 210
endif
c.... Find the floating point result, including the exponent.
if (kexp .lt. 0) then ! Negative exponent.
kexp = -kexp
200 if (kexp .gt. 80) then
fword = fword / 16.0**80.0
kexp = kexp - 80
go to 200
endif
if (kexp .ne. 0) then
fword = fword / 16.0**kexp
endif
elseif (kexp .gt. 0) then ! Positive exponent.
205 if (kexp .gt. 80) then
fword = fword * 16.0**80.0
kexp = kexp - 80
go to 205
endif
if (kexp .ne. 0) then
fword = fword * 16.0**kexp
endif
endif ! Tested kexp.
210 continue
cbugc***DEBUG begins.
cbug 9903 format (/ 'apthexd results: mtype=',i3,' nerr=',i3)
cbug 9904 format (' aword=',80a1 / ' iword=',i16,' fword=',1pe22.14)
cbug write ( 3, 9903) mtype, nerr
cbug write ( 3, 9904) (aword(nc), nc = 1, 80), iword, fword
cbugc***DEBUG ends.
return
c.... End of subroutine apthexd. (+1 line.)
end
UCRL-WEB-209832