subroutine aptsubm (asrce, isrce, nchar, iamax, idmax, iemax,
& al, as, ar, nsubm,
& astem, istem, fstem, mstem, lstem,
& nsub, asub, isub, fsub, msub, lsub, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTSUBM
c
c call aptsubm (asrce, isrce, nchar, iamax, idmax, iemax,
c & al, as, ar, nsubm,
c & astem, istem, fstem, mstem, lstem,
c & nsub, asub, isub, fsub, msub, lsub, nerr)
c
c Version: aptsubm Updated 2004 October 1 13:20.
c aptsubm Originated 2004 October 1 13:20.
c
c Authors: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To separate the character string in asrce, starting at position
c isrce and with length nchar, into character strings representing
c the stem, to the left of the character al, and the subscripts,
c to the right of the character al, and to the left of the
c character ar, and if more than one, separated by the character
c as. The separator characters al, as and ar may be any desired
c characters, such as "(", "," and ")", or "[", ":" and "]".
c
c For example, the character string "var(isub,jsub,ksub,...)"
c would be separated into the stem "var", and the subscripts
c "isub", "jsub", "ksub", ... The subscripts may themselves
c include the characters al and ar, in any position.
c
c The stem is returned in string astem, with length lstem, and the
c subscripts are returned in strings asub(n), with lengths
c lsub(n), n = 1, nsub.
c
c In addition, the stem is interpreted as an integer value istem
c and/or a floating value fstem if possible, and the type
c returned as mstem.
c
c In addition, each subscript is interpreted as an integer value
c isub(n) and/or a floating value fsub(n) if possible, and the
c type returned as msub(n).
c
c Leading and trailing blanks in stems and subscripts are removed.
c
c The maximum allowed value of nchar, lstem or lsub is iamax.
c The maximum number of digits in an integer is idmax.
c The maximum exponent of a floating point number is iemax.
c The maximum allowed value of nsub is nsubm.
c
c Flag nerr indicates any input error.
c
c Input: asrce, isrce, nchar, iamax, al, as, ar, nsubm.
c
c Output: astem, lstem, nsub, asub, lsub, nerr.
c
c Calls: aptchtp (in ~/work/apt/src on gps01, toofast18llnlgov)
c
c Glossary:
c
c al Input The character separating the stem from the first
c subcript, if any. May not be blank.
c
c ar Input The character following the last subcript, if any,
c and if present, the last non-blank character of
c the input string. May not be blank.
c
c as Input The character separating subscripts from each other,
c if there is more than one subscript. May not be
c blank.
c
c asrce Input A character array, containing a character string of
c length nchar, starting in character position isrce.
c Memory size must be at least isrce + nchar - 1.
c
c astem Output A character string of type character, with length
c lstem <= iamax. The first iamax characters are
c initially filled with blanks, and then the first
c lstem (<= nchar) characters are replaced by the
c initial characters of asrce preceding any character
c "al", after removing any leading or trailing blanks.
c Memory space must be iamax characters, e.g.
c character*M astem M = iamax
c character*1 astem(M) M = iamax
c
c asub(n) Output A character string of type character, with a length of
c lsub(n) <= iamax. The first iamax characters are
c initially filled with blanks, and then the first
c lsub(n) (<= nchar) characters are replaced by the
c subscript, after removing any leading or trailing
c blanks. The first asub string must be preceded by
c "al" and followed by "as" or "ar". The last asub
c string must be preceded by "al" or "as" and followed
c by "ar". All other asub strings must be preceded and
c followed by "as".
c Memory space must be nsubm*iamax, e.g.
c character*M asub(N) M = iamax, N = nsubm
c character*1 asub(M,N) M = iamax, N = nsubm
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 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 "-".
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(n) Output The floating point equivalent of string asub(n),
c if any. Initialized to zero.
c The maximum allowable exponent is iemax.
c If string asub(n) is translated into an integer
c (msub(n) = 2) or into a floating point number
c (msub(n) = 3), its floating point value will be
c returned in fsub(n). 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 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 "-".
c Note: do not equivalence isub(n) to fsub(n).
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 the memory space for strings
c astem and asub. Maximum value of nchar, lstem and
c lsub. Must be positive. 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, of length nchar, to be
c analysed. E. g., isrce = 1 means the leftmost
c character of asrce. Must be positive.
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. The first
c character may be a "+" or "-". All other characters
c must be digits, with no more than idmax digits.
c Note: do not equivalence istem to fstem.
c
c isub(n) Output The integer equivalent of string asub(n), if any.
c Initialized to zero. If string asub(n)
c is translated into an integer (msub(n) = 2), its
c integer value will be stored in isub(n), and its
c floating point value stored in fsub(n). The maximum
c number of digits is idmax. The first
c character may be a "+" or "-". All other characters
c must be digits, with no more than idmax digits.
c Note: do not equivalence isub(n) to fsub(n).
c
c lstem Output The actual number of characters in string astem.
c Will not exceed iamax. Zero if no stem is found,
c or if nerr is not zero.
c
c lsub(n) Output The actual number of characters in string asub(n),
c n = 1, nsub. Zero if no subscript is found.
c Memory space must be nsubm*iamax, e.g.
c character*M asub(N) M = iamax, N = nsubm
c character*1 asub(M,N) M = iamax, N = nsubm
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 = 14), or a floating point number whose
c exponent exceeds the limit iemax (nerr = 14).
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 = 14, 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 = 13), or a floating point number whose
c exponent exceeds the limit iemax (nerr = 13).
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 = 13, 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 asrce
c to be analysed, beginning at character isrce and
c ending at character isrce + nchar - 1 <= iamax.
c Must be positive.
c
c nerr Output Indicates an input error, if not zero.
c The last error 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 al, as or ar is blank.
c 6 if the input string asrce is blank.
c 7 if a blank character is within a stem or subscript.
c 8 if the first separator is not "al".
c 9 if separators, but last character not "ar".
c 10 if unequal numbers of separators "al" and "ar".
c 11 if any subscript is null (has zero length).
c 12 if nsub exceeds nsubm.
c 13 if the stem cannot be interpreted.
c 14 if a subscript cannot be interpreted.
c
c nsub Output The number of subscript strings asub(n) and lengths
c lsub(n), n = 1, nsub <= nsubm. Zero if none are
c found, or if nerr is not zero.
c
c nsubm Input Maximum value of nsub.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Declarations for arguments.
character*1 al ! Character to left of first subscript.
character*1 ar ! Character to right of last subscript.
character*1 as ! Character separating subscripts.
character*1 asrce(1) ! String containing input string.
character*1 astem(iamax) ! String preceding subscript.
character*1 asub(iamax,1) ! Subscript string.
integer iamax ! Maximum size of asrce, astem, asub.
integer idmax ! Maximum size of istem, isub.
integer iemax ! Maximum size of fstem, fsub.
integer isrce ! Number of initial character in asrce.
integer istem ! Integer interpretation of astem.
integer isub(1) ! Integer interpretation of asub.
integer lstem ! Length of stem astem, <= iamax.
integer lsub(1) ! Length of subscript string, <= iamax.
integer mstem ! Data type of asub.
integer msub(1) ! Data type of asub.
integer nchar ! Length of input string, part of asrce.
integer nerr ! Error flag.
integer nsub ! Number of subscripts, <= nsubm.
integer nsubm ! Maximum value of nsub.
real fstem ! Floating point interpretation of astem.
real fsub(1) ! Floating point interpretation of asub.
c.... Local variables.
character*1 asep(240) ! Separator characters.
character*1 asrcex(240) ! Input string with blanks removed.
character*1 asubx(240) ! Same as asub.
character*1 astemx(240) ! Same as astem.
character*1 aquote ! A quotation mark.
integer isep(240) ! Index of separator character in asrcex.
cbugc***DEBUG begins.
cbug aquote = '"'
cbug 9901 format (/ 'aptsubm finding a stem and subscripts.' /
cbug & ' isrce =',i4,' nchar =',i4,' iamax =',i4,' nsubm=',i4)
cbug 9902 format (' ibeg1 =',i4,' iend1 =',i4)
cbug 9903 format (' asrce =',2x,82a1)
cbug 9904 format (' al = ',a1,' as = ',a1,' ar = ',a1)
cbug
cbug write ( 3, 9901) isrce, nchar, iamax, nsubm
cbug ibeg1 = isrce
cbug iend1 = isrce + nchar - 1
cbug write ( 3, 9902) ibeg1, iend1
cbug if ((nchar .ge. 1) .and. (nchar .le. iamax) .and.
cbug & (isrce .ge. 1)) then
cbug write ( 3, 9903) aquote, (asrce(n), n = ibeg1, iend1), aquote
cbug endif
cbug write ( 3, 9904) al, as, ar
cbugc***DEBUG ends.
c.... Initialize.
nerr = 0
ibeg = 0
iend = 0
do n = 1, 240
asep(n) = ' '
asrcex(n) = ' '
isep(n) = 0
enddo
lstem = 0
istem = 0
fstem = 0.0
mstem = 1
nsub = 0
do ns = 1, nsubm
isub(ns) = 0
fsub(ns) = 0.0
msub(ns) = 1
lsub(ns) = 0
enddo
c.... Test for input errors.
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) .or. (idmax .le. 0) .or. (iemax .le. 0))then
nerr = 3
go to 210
endif
if ((isrce + nchar - 1) .gt. iamax) then
nerr = 4
go to 210
endif
if ((al .eq. ' ') .or. (as .eq. ' ') .or. (ar .eq. ' ')) then
nerr = 5
go to 210
endif
c.... Finish initializing.
do n = 1, iamax
astem(n) = ' '
do ns = 1, nsubm
asub(n,ns) = ' '
enddo
enddo
c.... Remove leading and trailing blanks.
ibeg1 = isrce
iend1 = isrce + nchar - 1
ibeg = iend1 + 1
iend = 0
do 110 n = ibeg1, iend1 ! Loop over original input string.
if (asrce(n) .ne. ' ') then ! Non-blank character.
ibeg = min (ibeg, n)
iend = max (iend, n)
endif
110 continue ! End of loop over original input string.
c.... Test for a blank input string.
if (iend .lt. ibeg) then ! The input string is blank.
cbugcbugc***DEBUG begins.
cbugcbug 9905 format (' The input string is blank.')
cbugcbug write (3, 9905)
cbugcbugc***DEBUG ends.
nerr = 6
go to 210
endif
c.... Remove any internal blanks next to separators. Store input in asrcx.
ibeg1 = ibeg
iend1 = iend
ibeg = iend
iend = 0
nsep = 0 ! Number of separator characters.
nal = 0 ! Number of characters al.
nas = 0 ! Number of characters as.
nar = 0 ! Number of characters ar.
do 120 n = ibeg1, iend1 ! Loop over original input string.
if (asrce(n) .ne. ' ') then ! Non-blank character.
ibeg = 1
iend = iend + 1
asrcex(iend) = asrce(n)
if (asrcex(iend) .eq. al) then
nal = nal + 1
nsep = nsep + 1
asep(nsep) = al
isep(nsep) = iend
elseif (asrcex(iend) .eq. as) then
nas = nas + 1
nsep = nsep + 1
asep(nsep) = as
isep(nsep) = iend
elseif (asrcex(iend) .eq. ar) then
nar = nar + 1
nsep = nsep + 1
asep(nsep) = ar
isep(nsep) = iend
endif
else ! Blank character.
if ((asrcex(iend) .eq. al) .or.
& (asrcex(iend) .eq. as) .or.
& (asrcex(iend) .eq. ar)) then
go to 120
endif
if ((asrce(n+1) .eq. ' ') .or.
& (asrce(n+1) .eq. al) .or.
& (asrce(n+1) .eq. as) .or.
& (asrce(n+1) .eq. ar)) then
go to 120
endif
cbugcbugc***DEBUG begins.
cbugcbug 9906 format (' Blank character in stem or subscript: ',i3)
cbugcbug write (3, 9906) n
cbugcbugc***DEBUG ends.
nerr = 7 ! Blank character in stem or subscript.
go to 210
endif ! Tested for blank character.
120 continue ! End of loop over original input string.
cbugcbugc***DEBUG begins.
cbugcbug 9909 format (' ibeg =',i3,' iend =',i3)
cbugcbug 9910 format (' asrcex =',2x,82a1)
cbugcbug write ( 3, 9909) ibeg, iend
cbugcbug write ( 3, 9910) aquote, (asrcex(n), n = ibeg, iend), aquote
cbugcbugc***DEBUG ends.
c.... See if stem is unsubscripted.
if (nsep .eq. 0) then
lstem = iend
do n = 1, lstem
astem(n) = asrcex(n)
enddo
cbugcbugc***DEBUG begins.
cbugcbug 9911 format (' astem =',2x,82a1)
cbugcbug write ( 3, 9911) aquote, (astem(n), n = 1, lstem), aquote
cbugcbugc***DEBUG ends.
go to 210
endif
cbugcbugc***DEBUG begins.
cbugcbug 9912 format (' Separator ',i3,' at character ',i3,' = ',a1)
cbugcbug write ( 3, 9912) (n, isep(n), asep(n), n = 1, nsep)
cbugcbugc***DEBUG ends.
c.... Test number and positions of separators.
if (asep(1) .ne. al) then
cbugcbugc***DEBUG begins.
cbugcbug 9913 format (' First separator not al: ',a1)
cbugcbug write ( 3, 9913) asep(1)
cbugcbugc***DEBUG ends.
nerr = 8
go to 210
endif
if (asrcex(iend) .ne. ar) then
cbugcbugc***DEBUG begins.
cbugcbug 9914 format (' Separators, but final character not ar: ',a1)
cbugcbug write ( 3, 9914) asrcex(iend)
cbugcbugc***DEBUG ends.
nerr = 9
go to 210
endif
if (nal .ne. nar) then
cbugcbugc***DEBUG begins.
cbugcbug 9915 format (' Unequal numbers of separators al and ar: ',2i3)
cbugcbug write ( 3, 9915) nal, nar
cbugcbugc***DEBUG ends.
nerr = 10
go to 210
endif
c.... Store stem.
if (asrcex(1) .eq. al) then ! No stem.
lstem = 0
else
lstem = isep(1) - 1
do n = 1, lstem
astem(n) = asrcex(n)
enddo
endif
c.... Store subscripts.
nsub = 1
nn = 0
do n = isep(1) + 1, iend - 1
if (asrcex(n) .ne. as) then
nn = nn + 1
asub(nn,nsub) = asrcex(n)
cbugcbugc***DEBUG begins.
cbugcbug 9918 format (' n=',i3,' asrcex(n)=',a1,' nn=',i3,' nsub=',i3,
cbugcbug & ' asub(nn,nsub)=',a1)
cbugcbug write ( 3, 9918) n, asrcex(n), nn, nsub, asub(nn,nsub)
cbugcbugc***DEBUG ends.
else
lsub(nsub) = nn
nsub = nsub + 1
if (nsub .gt. nsubm) then
cbugcbugc***DEBUG begins.
cbugcbug 9917 format (' Number of subscripts exceeds nsubm: ',2i5)
cbugcbug write ( 3, 9917) nsub, nsubm
cbugcbugc***DEBUG ends.
nerr = 12
go to 210
endif
nn = 0
endif
enddo
lsub(nsub) = nn
c.... See if any subscript is null.
do ns = 1, nsub
if (lsub(ns) .eq. 0) then
cbugcbugc***DEBUG begins.
cbugcbug 9916 format (' A subscript is null: ',i5)
cbugcbug write ( 3, 9916) ns
cbugcbugc***DEBUG ends.
nerr = 11
go to 210
endif
enddo
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 .ne. 0) then
nerr = 13
go to 210
endif
c.... Translate the subscripts into integer and/or floating point,
c.... if possible.
do ns = 1, nsub
call aptchtp (asub(1,ns), 1, lsub(ns), iamax, idmax, iemax,
& asubx(ns), isub(ns), fsub(ns), msub(ns), nerrl)
if (nerrl .ne. 0) then
nerr = 14
endif
enddo
210 continue
if (nerr .ne. 0) then
istem = 0
fstem = 0.0
mstem = 1
lstem = 0
do n = 1, iamax
astem(n) = ' '
enddo
nsub = 0
do ns = 1, nsubm
lsub(ns) = 0
isub(ns) = 0
fsub(ns) = 0.0
msub(ns) = 1
do n = 1, iamax
asub(n,ns) = ' '
enddo
enddo
endif
cbugc***DEBUG begins.
cbug
cbug 9921 format (/ 'aptsubm results: lstem =',i4,' nsub =',i4,
cbug & ' nerr =',i3)
cbug 9922 format (' asrcex =',2x,82a1)
cbug 9923 format (' astem =',2x,82a1)
cbug 9924 format (' lstem =',i4,' mstem =',i2)
cbug 9925 format (' istem =',i20,' fstem =',1pe20.12)
cbug 9928 format (' asub =',2x,82a1)
cbug 9929 format (' ns =',i4,' lsub(ns) =',i4,' msub(ns) =',i2)
cbug 9930 format (' isub(ns) =',i20,' fsub(ns) =',1pe20.12)
cbug
cbug write ( 3, 9921) lstem, nsub, nerr
cbug write ( 3, 9922) aquote, (asrcex(n), n = ibeg, iend), aquote
cbug
cbug if (lstem .gt. 0) then
cbug write ( 3, 9924) lstem, mstem
cbug write ( 3, 9923) aquote, (astem(n), n = 1, lstem), aquote
cbug write ( 3, 9925) istem, fstem
cbug endif
cbug
cbug if (nsub .gt. 0) then
cbug do ns = 1, nsub
cbug write ( 3, 9929) ns, lsub(ns), msub(ns)
cbug write ( 3, 9928) aquote, (asub(n,ns), n = 1, lsub(ns)), aquote
cbug if (msub(ns) .ne. 1) then
cbug write ( 3, 9930) isub(ns), fsub(ns)
cbug endif
cbug enddo
cbug endif
cbug
cbugc***DEBUG ends.
return
c.... End of subroutine aptsubm. (+1 line.)
end
UCRL-WEB-209832