subroutine aptchty (asrce, isrce, nchar, idmax, iemax, aword,
& iword, fword, mtype, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTCHTY (OBSOLETE, USE APTCHTP)
c
c call aptchty (asrce, isrce, nchar, idmax, iemax, aword,
c & iword, fword, mtype, nerr)
c
c Version: aptchty Updated 1997 July 8 16:10.
c aptchty Originated 1991 August 27 12:00.
c
c Authors: Dermott "Red" Cullen, LLNL, L-298, Telephone (925) 423-7359.
c 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 Character data in aword may have up to 8 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 An array containing a character string, compatible with
c a calling routine argument of type character*8,
c character*1, etc.
c
c aword Output A character array containing 8 characters, compatible
c with a calling routine argument of type character*8,
c or 8 words of type character*1, etc. Always filled
c with up to 8 characters of the character string, and
c right-filled with blanks as necessary.
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 number of
c 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 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 8 characters (nerr = 0),
c or a floating-point number whose exponent exceeds
c the limit iemax (nerr = 5). Returned in aword.
c 1: Not recognizable as an integer or floating-point
c number. String has 1-8 characters. Returned in
c aword, left-adjusted, right-filled with blanks,
c 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 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 6 if case conversion has made "d" = "D", "e" = "D".
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---- A single character in string.
common /captchty/ 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---- Floating-point idig - 1.
common /laptchty/ fintadd
c---- Floating-point mantissa value.
common /laptchty/ fintval
c---- Indicates sign of mantissa.
common /laptchty/ fsign
c---- Index in aword.
common /laptchty/ icharm
c---- Index in array adigit.
common /laptchty/ idig
c---- Integer mantissa value.
common /laptchty/ intval
c---- Indicates position of decimal point.
common /laptchty/ ipt
c---- Indicates sign of mantissa.
common /laptchty/ isign
c---- Number of exponent digits.
common /laptchty/ kdigit
c---- Integer exponent value.
common /laptchty/ kexp
c---- Indicates sign of exponent.
common /laptchty/ ksign
c---- Index in the string.
common /laptchty/ nbeg
c---- Index in the string.
common /laptchty/ nc
c---- Number of mantissa digits.
common /laptchty/ ndigall
c---- Number of significant digits.
common /laptchty/ ndigit
c---- Number of zeroes to insert.
common /laptchty/ nzeros
c---- Powers of 10, 1 to 30.
dimension tend(30)
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 /
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 /
c____ SINGLE PRECISION.
cbugc***DEBUG begins.
cbugc---- # of characters of asrce to write.
cbug common /laptchty/ nmaxa
cbug 9901 format (/ 'aptchty translating an ASCII word.' /
cbug & ' isrce=',i6,' nchar=',i6,' idmax=',i3,' iemax=',i6)
cbug 9902 format (' asrce=',64a1)
cbug write ( 3, 9901) isrce, nchar, 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---- Loop over output characters.
do 105 nc = 1, 8
aword(nc) = ' '
c---- End of loop over output characters.
105 continue
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 ((idmax .le. 0) .or. (iemax .le. 0)) then
nerr = 3
go to 210
endif
c.... Put up to 8 characters of string into aword.
icharm = nchar
if (icharm .gt. 8) then
c---- Type character (>8) or bad f-p.
mtype = 0
icharm = 8
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=======================================================================--------
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=======================================================================--------
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. 8) 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. 8) 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
if (ipt .gt. 0) fword = fword / tend(ipt)
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. 8) 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. 30) then
fword = fword / tend(30)
kexp = kexp - 30
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. 30) then
fword = fword * tend(30)
kexp = kexp - 30
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 (/ 'aptchty results: mtype=',i3,' nerr=',i3)
cbug 9904 format (' aword=',8a1,' iword=',i16,' fword=',1pe22.14)
cbug write ( 3, 9903) mtype, nerr
cbug write ( 3, 9904) (aword(nc), nc = 1, 8), iword, fword
cbugc***DEBUG ends.
return
c.... End of subroutine aptchty. (+1 line.)
end
UCRL-WEB-209832