subroutine aptchtp (asrce, isrce, nchar, iamax, idmax, iemax,
& aword, iword, fword, mtype, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTCHTP
c
c call aptchtp (asrce, isrce, nchar, iamax, idmax, iemax,
c & aword, iword, fword, mtype, nerr)
c
c Version: aptchtp Updated 1997 August 4 11:20.
c aptchtp 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 character string to characters, an integer,
c or a floating-point number. The string is in array asrce,
c starting at character position isrce, and has a length of
c nchar characters. Integers may have up to idmax digits.
c Floating-point numbers may have exponents up to iemax.
c The word length in character array aword is iamax characters.
c The results are stored in the character array aword, the
c integer word iword, and/or the floating point word fword,
c 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 string to be
c 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. Do not make aword = asrce.
c
c fword Output A 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 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 "e", "E", "d", "D", "+" or "-".
c An initial "e", "E", "d" or "D" 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. At least 13 on a Cray.
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 2465 on a Cray. 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 integer value, and fword will contain its
c floating-point value. Note: do not equivalence
c fword and iword. The character string may have
c leading or trailing blanks. The first non-blank
c character may be a "+" or "-". All other characters
c must be digits, with no more than idmax digits
c following any leading 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 an integer or floating-point
c number, and longer than iamax characters
c (nerr = 0), or a floating-point number whose
c exponent exceeds the limit iemax (nerr = 5).
c Returned in aword.
c 1: Not recognizable as an integer or floating-point
c number. String has 1 to iamax characters.
c Returned in aword, left-adjusted, right-filled
c with blanks, as necessary.
c 2: Character string translated into integer mode.
c The integer value is returned in iword, and the
c floating-point value is returned in fword.
c Also returned in aword, as for mtype = 1.
c 3: Character string translated into floating-point
c mode, and returned in fword. The integer value
c can not be stored in iword, because of the
c possibility of overflow of numbers with large
c exponents. If nerr = 4, the character string was
c an integer with more than idmax 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.
c---- Array of characters.
dimension asrce (1)
c---- Array of characters.
character*1 asrce
c---- Character interpretation of string.
dimension aword (1)
c---- Character interpretation of string.
character*1 aword
c.... Local variables.
c---- Floating-point idig - 1.
common /laptchtp/ fintadd
c---- Floating-point mantissa value.
common /laptchtp/ fintval
c---- Indicates sign of mantissa.
common /laptchtp/ fsign
c---- Index in aword.
common /laptchtp/ icharm
c---- Index in array adigit.
common /laptchtp/ idig
c---- Integer mantissa value.
common /laptchtp/ intval
c---- Indicates position of decimal point.
common /laptchtp/ ipt
c---- Indicates sign of mantissa.
common /laptchtp/ isign
c---- Number of exponent digits.
common /laptchtp/ kdigit
c---- Integer exponent value.
common /laptchtp/ kexp
c---- Indicates sign of exponent.
common /laptchtp/ ksign
c---- Index in the string.
common /laptchtp/ nbeg
c---- Index in the string.
common /laptchtp/ nc
c---- Number of mantissa digits.
common /laptchtp/ ndigall
c---- Number of significant digits.
common /laptchtp/ ndigit
c---- Number of zeroes to insert.
common /laptchtp/ nzeros
c---- A single character in string.
common /captchtp/ achar
character*1 achar
c---- Integer digits from 0 to 9.
dimension adigit(10)
character*1 adigit
data adigit / '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' /
c---- Powers of 10, 1 to 80.
dimension tend(80)
c---- DOUBLE PRECISION.
c double precision tend
c data tend / 1.d+01, 1.d+02, 1.d+03, 1.d+04, 1.d+05, 1.d+06,
c & 1.d+07, 1.d+08, 1.d+09, 1.d+10, 1.d+11, 1.d+12, 1.d+13,
c & 1.d+14, 1.d+15, 1.d+16, 1.d+17, 1.d+18, 1.d+19, 1.d+20,
c & 1.d+21, 1.d+22, 1.d+23, 1.d+24, 1.d+25, 1.d+26, 1.d+27,
c & 1.d+28, 1.d+29, 1.d+30, 1.d+31, 1.d+32, 1.d+33, 1.d+34,
c & 1.d+35, 1.d+36, 1.d+37, 1.d+38, 1.d+39, 1.d+40, 1.d+41,
c & 1.d+42, 1.d+43, 1.d+44, 1.d+45, 1.d+46, 1.d+47, 1.d+48,
c & 1.d+49, 1.d+50, 1.d+51, 1.d+52, 1.d+53, 1.d+54, 1.d+55,
c & 1.d+56, 1.d+57, 1.d+58, 1.d+59, 1.d+60, 1.d+61, 1.d+62,
c & 1.d+63, 1.d+64, 1.d+65, 1.d+66, 1.d+67, 1.d+68, 1.d+69,
c & 1.d+70, 1.d+71, 1.d+72, 1.d+73, 1.d+74, 1.d+75, 1.d+76,
c & 1.d+77, 1.d+78, 1.d+79, 1.d+80 /
c /
c____ DOUBLE PRECISION.
c____ SINGLE PRECISION.
data tend / 1.e+01, 1.e+02, 1.e+03, 1.e+04, 1.e+05, 1.e+06,
& 1.e+07, 1.e+08, 1.e+09, 1.e+10, 1.e+11, 1.e+12, 1.e+13,
& 1.e+14, 1.e+15, 1.e+16, 1.e+17, 1.e+18, 1.e+19, 1.e+20,
& 1.e+21, 1.e+22, 1.e+23, 1.e+24, 1.e+25, 1.e+26, 1.e+27,
& 1.e+28, 1.e+29, 1.e+30, 1.e+31, 1.e+32, 1.e+33, 1.e+34,
& 1.e+35, 1.e+36, 1.e+37, 1.e+38, 1.e+39, 1.e+40, 1.e+41,
& 1.e+42, 1.e+43, 1.e+44, 1.e+45, 1.e+46, 1.e+47, 1.e+48,
& 1.e+49, 1.e+50, 1.e+51, 1.e+52, 1.e+53, 1.e+54, 1.e+55,
& 1.e+56, 1.e+57, 1.e+58, 1.e+59, 1.e+60, 1.e+61, 1.e+62,
& 1.e+63, 1.e+64, 1.e+65, 1.e+66, 1.e+67, 1.e+68, 1.e+69,
& 1.e+70, 1.e+71, 1.e+72, 1.e+73, 1.e+74, 1.e+75, 1.e+76,
& 1.e+77, 1.e+78, 1.e+79, 1.e+80 /
c____ SINGLE PRECISION.
cbugc***DEBUG begins.
cbugc---- # of characters of asrce to write.
cbug common /laptchtp/ nmaxa
cbug 9901 format (/ 'aptchtp 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
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
c---- Type character (>iamax) or bad f-p.
mtype = 0
icharm = iamax
endif
c---- Loop over output characters.
do 110 nc = 1, icharm
aword(nc) = asrce(isrce +nc-1)
c---- End of loop over output characters.
110 continue
c.... Right-fill aword with blanks.
nbeg = icharm + 1
if (nbeg .le. iamax) then
do 105 nc = nbeg, iamax ! Loop over output characters.
aword(nc) = ' '
105 continue ! End of loop over output characters.
endif
c=======================================================================--------
c.... Look for the beginning of the mantissa field for integers and
c.... floating-point numbers. Find the first non-blank character.
c---- Loop over character string.
do 115 nc = 1, nchar
achar = asrce(isrce +nc-1)
if (achar .ne. ' ') go to 120
c---- End of loop over character string.
115 continue
c---- All characters are blank.
go to 210
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
c.... See if the only non-blank character in string is "+" or "-".
c---- All characters are blank, "+" or "-".
if (nc .gt. nchar) go to 210
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, 10
if (achar .eq. adigit(idig)) go to 122
121 continue
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
c---- Loop over rest of string.
do 140 nc = nbeg, nchar
achar = asrce(isrce +nc-1)
c.... Test for any trailing blanks after the mantissa.
c++++ Blank ends mantissa.
if (achar .eq. ' ') go to 145
c.... Scan for a digit or decimal point (which are part of mantissa).
c---- Loop over digits.
do 125 idig = 1, 10
if (achar .eq. adigit(idig)) go to 130
c---- End of loop over digits.
125 continue
c.... Not a digit. Test for first decimal point (only allow 1).
c++++ End of mantissa.
if ((ipt .ge. 0) .or. (achar .ne. '.')) go to 160
c---- Found first decimal point.
ipt = 0
go to 140
c.... Found a digit. See if zero or non-zero, if after a decimal point.
c---- String has a decimal point.
130 if (ipt .ge. 0) then
c.... Save number of zeros following the decimal point.
c---- Save zeros.
if (idig .eq. 1) then
nzeros = nzeros + 1
go to 140
endif
c.... Non-zero digit found. Include effect of zeros after decimal point.
c---- String has zeros after decimal.
135 if (nzeros .gt. 0) then
c.... Only allow exponents up to iemax.
c++++ Exponent overflows.
if (ndigit .gt. (iemax + ipt)) then
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 = 10 * intval
elseif (ndigit .eq. idmax) then
fintval = intval
fintval = tend(1) * fintval
c---- More than idmax digits.
else
fintval = tend(1) * fintval
endif
c.... Insert zeroes before next number.
ipt = ipt + 1
nzeros = nzeros - 1
ndigit = ndigit + 1
ndigall = ndigall + 1
go to 135
c---- Tested nzeros.
endif
c---- Tested ipt.
endif
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.
c++++ Exponent overflows.
if (ndigit .gt. (iemax + max (0, ipt))) then
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 = 10 * intval + (idig - 1)
c++++ Start floating-point equivalent.
elseif (ndigit .eq. idmax) then
fintadd = idig - 1
fintval = intval
fintval = tend(1) * fintval + fintadd
c---- More than idmax digits.
else
fintadd = idig - 1
fintval = tend(1) * fintval + fintadd
endif
ipt = ipt + 1
ndigit = ndigit + 1
c---- End of loop over rest of string.
140 continue
go to 155
c=======================================================================--------
c.... The mantissa ended with a blank. Look for next non-blank character.
145 nbeg = nc
c---- Loop over rest of string.
do 150 nc = nbeg, nchar
achar = asrce(isrce +nc-1)
if (achar .ne. ' ') go to 160
c---- End of loop over rest of string.
150 continue
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.
c---- No decimal point.
if (ipt .lt. 0) then
c.... Assume floating-point if over idmax digits.
c---- Return integer and floating-point.
if (ndigit .le. idmax) then
c---- Type integer.
mtype = 2
iword = isign * intval
fword = iword
c---- Return only floating-point.
else
c---- Type integer, but too many digits.
mtype = 3
fword = fsign * fintval
nerr = 4
endif
c---- A decimal point was found.
else
c---- Type floating-point.
mtype = 3
if (ndigit .le. idmax) then
fword = isign * intval
c---- Return only floating-point.
else
fword = fsign * fintval
endif
158 if (ipt .gt. 80) then
fword = fword / tend(80)
ipt = ipt - 80
go to 158
endif
if (ipt .gt. 0) then
fword = fword / tend(ipt)
endif
c---- Tested ipt.
endif
go to 210
c=======================================================================--------
c.... Found the end of the mantissa. Look for the beginning of the exponent.
c.... The exponent may start with "e", "E", "d", "D", "+", or "-".
160 ksign = 0
if ((achar .eq. 'e') .or. (achar .eq. 'd') .or.
& (achar .eq. 'E') .or. (achar .eq. 'D')) then
nc = nc + 1
achar = asrce(isrce +nc-1)
c---- Assume positive exponent.
ksign = 1
endif
c---- Exponent is positive.
if (achar .eq. '+') then
nc = nc + 1
ksign = 1
c---- Exponent is negative.
elseif (achar .eq. '-') then
nc = nc + 1
ksign = -1
endif
c++++ Not an exponent.
if ((nc .gt. nchar) .or. (ksign .eq. 0)) go to 210
c=======================================================================--------
c.... Found the beginning of the exponent. Find the next non-blank character.
nbeg = nc
c---- Loop over rest of string.
do 165 nc = nbeg, nchar
achar = asrce(isrce +nc-1)
if (achar .ne. ' ') go to 170
c---- End of loop over rest of string.
165 continue
c---- No digits in exponent.
go to 210
170 kexp = 0
kdigit = 0
nbeg = nc
c---- Loop over rest of string.
do 180 nc = nbeg, nchar
achar = asrce(isrce +nc-1)
c++++ Imbedded blank ends exponent.
if (achar .eq. ' ') go to 185
c---- Loop over digits.
do 175 idig = 1, 10
c++++ Found digit.
if (achar .eq. adigit(idig)) then
kexp = 10 * kexp + (idig - 1)
kdigit = kdigit + 1
go to 180
endif
c---- End of loop over digits.
175 continue
c---- Not a digit. Return character string.
go to 210
c---- End of loop over rest of string.
180 continue
go to 195
c=======================================================================--------
c.... Found imbedded blank in exponent. The rest of the string must be blank.
185 nbeg = nc
c---- Loop over rest of string.
do 190 nc = nbeg, nchar
achar = asrce(isrce +nc-1)
c++++ Illegal character in exponent field.
if (achar .ne. ' ') go to 210
c---- End of loop over rest of string.
190 continue
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.
c---- Type real, or integer > idmax.
mtype = 3
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
c---- Exceeded maximum exponent.
nerr = 5
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.
c---- Negative exponent.
if (kexp .lt. 0) then
kexp = -kexp
200 if (kexp .gt. 80) then
fword = fword / tend(80)
kexp = kexp - 80
go to 200
endif
if (kexp .ne. 0) then
fword = fword / tend(kexp)
endif
c---- Positive exponent.
elseif (kexp .gt. 0) then
205 if (kexp .gt. 80) then
fword = fword * tend(80)
kexp = kexp - 80
go to 205
endif
if (kexp .ne. 0) then
fword = fword * tend(kexp)
endif
c---- Tested kexp.
endif
210 continue
cbugc***DEBUG begins.
cbug 9903 format (/ 'aptchtp 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 aptchtp. (+1 line.)
end
UCRL-WEB-209832