subroutine aptsubs (asrce, isrce, nchar, iamax, idmax, iemax,
& astem, istem, fstem, mstem, lstem,
& asub, isub, fsub, msub, lsub, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTSUBS
c
c call aptsubs (asrce, isrce, nchar, iamax, idmax, iemax,
c & astem, istem, fstem, mstem, lstem,
c & asub, isub, fsub, msub, lsub, nerr)
c
c Version: aptsubs Updated 2004 January 25 16:00.
c aptsubs Originated 2004 January 25 16:00.
c
c Authors: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To translate the character string in asrce, starting at
c character position isrce, and with length nchar, into no more
c than two data fields, a stem astem of length lstem, preceding
c the first character "(", if any, and a subscript asub of length
c lsub, delimited by the first character "(" and the last
c character ")". Leading and trailing blanks are ignored.
c Flag nerr indicates any input error.
c
c Input: asrce, isrce, nchar, iamax, idmax, iemax,
c
c Output: astem, istem, fstem, mstem, lstem,
c asub, isub, fsub, msub, lsub, nerr.
c
c Calls: aptchtp (in ~/work/apt/src on gps01, toofast18llnlgov)
c
c Glossary:
c
c asrce Input A character array, containing a character string of
c length nchar, starting in character position isrce,
c to be separated into a string astem preceding the
c first character "(", if any, and a string asub,
c delimited by the first character "(", if any, and
c the last character ")", if any.
c Size must be at least isrce + nchar -1.
c
c astem Output A character string of type character, with a length of
c iamax. The first iamax characters are initially
c filled with blanks, and then the first lstem
c (<= nchar) characters are replaced.
c Leading and trailing blanks are ignored.
c
c asub Output A character string of type character, with a length of
c iamax. The first iamax characters are initially
c filled with blanks, and then the first lsub
c (<= nchar) characters are replaced.
c Leading and trailing blanks are ignored.
c
c fstem Output The floating point equivalent of string astem, if any.
c Initialized to zero.
c The maximum allowable exponent is iemax.
c If string astem is translated into an integer
c (mstem = 2) or into a floating point number
c (mstem = 3), its floating point value will be
c returned in fstem. If the field 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 fstem.
c The first non-blank character may be a "+" or "-".
c The mantissa may contain any number of digits, but no
c more than one decimal point. If an exponent follows,
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 istem to fstem.
c Note: the largest 64-bit floating point value
c possible on DEC machines is approximately 1.e+308.
c
c fsub Output The floating point equivalent of string asub, if any.
c Initialized to zero.
c The maximum allowable exponent is iemax.
c If string asub is translated into an integer
c (msub = 2) or into a floating point number
c (msub = 3), its floating point value will be
c returned in fsub. If the field 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 fsub.
c The first non-blank character may be a "+" or "-".
c The mantissa may contain any number of digits, but no
c more than one decimal point. If an exponent follows,
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 isub to fsub.
c Note: the largest 64-bit floating point value
c possible on DEC machines is approximately 1.e+308.
c
c iamax Input Number of characters in strings astem and asub.
c Maximum value of nchar. May not exceed 240.
c
c idmax Input Maximum number of digits in an integer. Depends on
c the machine.
c
c iemax Input Maximum size (positive or negative) of the exponent
c of a floating point number. Depends on the machine.
c
c isrce Input The character position in array asrce of the first
c character of the string to be translated. E. g.,
c isrce = 1 means the leftmost character of asrce.
c Must be positive (isrce + nchar - 1 <= iamax).
c
c istem Output The integer equivalent of string astem, if any.
c Initialized to zero. If string astem
c is translated into an integer (mstem = 2), its
c integer value will be stored in istem, and its
c floating point value stored in fstem. The maximum
c number of digits is idmax. String astem 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 Note: do not equivalence istem to fstem.
c
c isub Output The integer equivalent of string asub, if any.
c Initialized to zero. If string asub
c is translated into an integer (msub = 2), its
c integer value will be stored in isub, and its
c floating point value stored in fsub. The maximum
c number of digits is idmax. String asub 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 Note: do not equivalence isub to fsub.
c
c lstem Output The actual number of characters in string astem.
c May not exceed iamax. Zero if no stem.
c
c lsub Output The actual number of characters in string asub.
c May not exceed iamax. Zero if no subscript.
c
c mstem Output An integer, indicating the data type of string astem:
c -1: No string astem found. A blank word is returned
c in astem. Zeros are returned in istem and fstem.
c 0: Not recognizable as an integer or floating point
c number, and longer than iamax characters
c (nerr = 5), or a floating point number whose
c exponent exceeds the limit iemax (nerr = 6).
c Returned in astem.
c 1: Not recognizable as an integer or floating point
c number. Sting astem has from 1 to iamax
c characters. Returned in astem, left-adjusted,
c right-filled with blanks, as necessary.
c 2: String astem translated into integer mode.
c The integer value is returned in istem, and the
c floating point value is returned in fstem.
c Also returned in astem, as for mstem = 1.
c 3: String astem translated into floating point
c mode, and returned in fstem. The integer value
c can not be stored in istem, because of the
c possibility of overflow of numbers with large
c exponents. If nerr = 5, the data field was
c an integer with more than idmax digits.
c Also returned in astem, as for mstem = 1.
c
c msub Output An integer, indicating the data type of string asub:
c -1: No string asub found. A blank word is returned
c in asub. Zeros are returned in isub and fsub.
c 0: Not recognizable as an integer or floating point
c number, and longer than iamax characters
c (nerr = 5), or a floating point number whose
c exponent exceeds the limit iemax (nerr = 6).
c Returned in asub.
c 1: Not recognizable as an integer or floating point
c number. Sting asub has from 1 to iamax
c characters. Returned in asub, left-adjusted,
c right-filled with blanks, as necessary.
c 2: String asub translated into integer mode.
c The integer value is returned in isub, and the
c floating point value is returned in fsub.
c Also returned in asub, as for msub = 1.
c 3: String asub translated into floating point
c mode, and returned in fsub. The integer value
c can not be stored in isub, because of the
c possibility of overflow of numbers with large
c exponents. If nerr = 5, the data field was
c an integer with more than idmax digits.
c Also returned in asub, as for msub = 1.
c
c nchar Input The number of characters in the input string
c (isrce + nchar - 1 <= iamax).
c
c nerr Output Indicates an input error, if not zero. The last error
c found is indicated by:
c 1 if isrce is not positive.
c 2 if nchar is not positive.
c 3 if iamax is not positive.
c 4 if isrce + nchar - 1 exceeds iamax.
c 5 if asub is floating point, with an exponent
c greater than iemax.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Declarations for arguments.
dimension asrce (1) ! String containing input string.
character*1 asrce ! String containing input string.
dimension astem (1) ! String preceding subscript.
character*1 astem ! String preceding subscript.
dimension asub (1) ! Subscript string.
character*1 asub ! Subscript string.
c.... Local variables.
character*1 asubx(240) ! Same as asub.
character*1 astemx(240) ! Same as astem.
character*1 aquote ! A quotation mark.
cbugc***DEBUG begins.
cbug aquote = '"'
cbug 9901 format (/ 'aptsubs finding a stem and a subscript.' /
cbug & ' isrce =',i3,' nchar =',i3,' iamax =',i3)
cbug 9902 format (' asrce =',2x,82a1)
cbug write ( 3, 9901) isrce, nchar, iamax
cbug if ((nchar .ge. 1) .and. (isrce .ge. 1)) then
cbug ibeg = isrce
cbug iend = isrce + nchar - 1
cbug if (ibeg .gt. iamax) ibeg = iamax
cbug if (iend .gt. iamax) iend = iamax
cbug write ( 3, 9902) aquote,
cbug & (asrce(n), n = ibeg, iend), aquote
cbug endif
cbugc***DEBUG ends.
c.... Initialize.
fstem = 0.0
istem = 0
lstem = 0
mstem = -1
fsub = 0.0
isub = 0
lsub = 0
msub = -1
do 110 n = 1, iamax
astem(n) = ' '
asub(n) = ' '
110 continue
do 115 n = 1, 240
asubx(n) = ' '
astemx(n) = ' '
115 continue
c.... Test for input errors.
nerr = 0
if (isrce .le. 0) then
nerr = 1
go to 210
endif
if (nchar .le. 0) then
nerr = 2
go to 210
endif
if (iamax .le. 0) then
nerr = 3
go to 210
endif
if ((isrce + nchar - 1) .gt. iamax) then
nerr = 4
go to 210
endif
c.... Find the indices of the first and last non-blank characters of the string.
ibeg1 = isrce
iend1 = isrce + nchar - 1
do 120 n = ibeg1, iend1
if (asrce(n) .ne. ' ') then
ibeg = n
go to 130
endif
120 continue
ibeg = iend1 + 1
130 do 140 n = iend1, ibeg, -1
if (asrce(n) .ne. ' ') then
iend = n
go to 150
endif
140 continue
iend = ibeg - 1
150 continue
cbugcbugc***DEBUG begins.
cbugcbug 9701 format (' ibeg1 =',i3,' iend1 =',i3,' ibeg =',i3,' iend =',i3)
cbugcbug write ( 3, 9701) ibeg1, iend1, ibeg, iend
cbugcbug write ( 3, 9902) aquote,
cbugcbug & (asrce(n), n = ibeg, iend), aquote
cbugcbugc***DEBUG ends.
if (iend .lt. ibeg) then
go to 210
endif
c.... Find the stem, if any.
if (asrce(iend) .ne. ')') then
istem1 = ibeg
istem2 = iend
go to 170
endif
if (asrce(ibeg) .eq. '(') then
istem1 = ibeg - 1
istem2 = ibeg - 1
go to 190
endif
istem1 = ibeg
do 160 n = ibeg, iend
if (asrce(n) .eq. '(') then
istem2 = n - 1
go to 170
endif
160 continue
istem2 = iend
c.... Store the stem in astem and remove any trailing blanks.
170 lstem = istem2 - istem1 + 1
nn = 0
do 180 n = istem1, istem2
nn = nn + 1
astem(nn) = asrce(n)
if (astem(nn) .ne. ' ') then
lstem = nn
endif
180 continue
c.... Translate the stem into integer and/or floating point,
c.... if possible.
call aptchtp (astem, 1, lstem, iamax, idmax, iemax,
& astemx, istem, fstem, mstem, nerrl)
if (nerrl .eq. 5) then
nerr = 5
endif
c.... Find the subscript, if any.
190 continue
cbugcbugc***DEBUG begins.
cbugcbug 9702 format (' istem1 =',i3,' istem2 =',i3)
cbugcbug write ( 3, 9702) istem1, istem2
cbugcbugc***DEBUG ends.
if (istem2 .eq. iend) then
go to 210
endif
isubs1 = istem2 + 2
isubs2 = iend - 1
cbugcbugc***DEBUG begins.
cbugcbug 9703 format (' isubs1 =',i3,' isubs2 =',i3)
cbugcbug write ( 3, 9703) isubs1, isubs2
cbugcbugc***DEBUG ends.
if (isubs2 .lt. isubs1) then
go to 210
endif
c.... Find the indices of the first and last non-blank characters of asub.
ibeg1 = isubs1
iend1 = isubs2
do 192 n = ibeg1, iend1
if (asrce(n) .ne. ' ') then
isubs1 = n
go to 194
endif
192 continue
isubs1 = iend1 + 1
194 do 196 n = iend1, isubs1, -1
if (asrce(n) .ne. ' ') then
isubs2 = n
go to 198
endif
196 continue
isubs2 = isubs1 - 1
198 continue
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9703) isubs1, isubs2
cbugcbugc***DEBUG ends.
if (isubs2 .lt. isubs1) then
go to 210
endif
c.... Store the subscript in asub.
lsub = isubs2 - isubs1 + 1
nn = 0
do 200 n = isubs1, isubs2
nn = nn + 1
asub(nn) = asrce(n)
200 continue
c.... Translate the subscript into integer and/or floating point,
c.... if possible.
call aptchtp (asub, 1, lsub, iamax, idmax, iemax,
& asubx, isub, fsub, msub, nerrl)
if (nerrl .eq. 5) then
nerr = 5
endif
210 continue
cbugc***DEBUG begins.
cbug 9903 format (/ 'aptsubs results: nerr =',i2)
cbug 9904 format (' lstem =',i2,' astem =',2x,82a1)
cbug 9905 format (' astemx =',2x,240a1 )
cbug 9906 format (' istem =',i22 / ' fstem =',1pe22.14 / ' mstem =',i3 )
cbug 9907 format (' lsub =',i2,' asub =',2x,82a1)
cbug 9908 format (' asubx =',2x,240a1 )
cbug 9909 format (' isub =',i22 / ' fsub =',1pe22.14 / ' msub =',i3 )
cbug
cbug aquote = '"'
cbug write ( 3, 9903) nerr
cbug if (lstem .gt. 0) then
cbug write ( 3, 9904) lstem, aquote, (astem(nn), nn = 1, lstem),
cbug & aquote
cbug write ( 3, 9905) aquote, (astemx(n), n = 1, lstem), aquote
cbug write ( 3, 9906) istem, fstem, mstem
cbug endif
cbug if (lsub .gt. 0) then
cbug write ( 3, 9907) lsub, aquote, (asub(nn), nn = 1, lsub),
cbug & aquote
cbug write ( 3, 9908) aquote, (asubx(n), n = 1, lsub), aquote
cbug write ( 3, 9909) isub, fsub, msub
cbug endif
cbugc***DEBUG ends.
return
c.... End of subroutine aptsubs. (+1 line.)
end
UCRL-WEB-209832