subroutine aptsubr (asrce, isrce, nchar, iamax, astem, lstem,
& asub, lsub, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTSUBR
c
c call aptsubr (asrce, isrce, nchar, iamax, astem, lstem,
c asub, lsub, nerr)
c
c Version: aptsubr Updated 2004 January 27 14:00.
c aptsubr Originated 2004 January 26 15: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 "(", if any, and the last
c character ")", if any. Leading and trailing blanks are ignored.
c Flag nerr indicates any input error.
c
c Input: asrce, isrce, nchar, iamax.
c
c Output: astem, lstem, asub, 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 iamax Input Number of characters in strings astem and asub.
c Maximum value of nchar. May not exceed 240.
c
c isrce Input The character position in array asrce of the first
c character of the string, of length nchar, to be
c translated. E. g., isrce = 1 means the leftmost
c character of asrce. Must be positive.
c
c lstem Output The actual number of characters in string astem.
c Zero if no stem is found.
c
c lsub Output The actual number of characters in string asub.
c Zero if no subscript is found.
c
c nchar Input The number of characters in the input string
c beginning at character isrce of asrce.
c (isrce + nchar - 1 <= iamax).
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
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Declarations for arguments.
character*1 asrce(1) ! String containing input string.
character*1 astem(1) ! String preceding subscript.
character*1 asub(1) ! Subscript string.
cbugc***DEBUG begins.
cbug character*1 aquote ! A quotation mark.
cbug aquote = '"'
cbug 9901 format (/ 'aptsubr 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 write ( 3, 9902) aquote,
cbug & (asrce(n), n = ibeg, iend), aquote
cbug endif
cbugc***DEBUG ends.
c.... Initialize.
lstem = 0
lsub = 0
do 110 n = 1, iamax
astem(n) = ' '
asub(n) = ' '
110 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 ! The input string is blank.
130 do 140 n = iend1, ibeg, -1
if (asrce(n) .ne. ' ') then
iend = n
go to 150
endif
140 continue
iend = ibeg - 1 ! All remaining characters are blank.
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 ! The input string is blank.
go to 210
endif
c.... Find the stem, if any.
if (asrce(iend) .ne. ')') then ! No subscript.
istem1 = ibeg
istem2 = iend
go to 170
endif
if (asrce(ibeg) .eq. '(') then ! No stem.
istem1 = ibeg - 1
istem2 = ibeg - 1
go to 190
endif
c.... A stem exists. Find the indices of the first and last characters.
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.... 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 ! No subscript.
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 ! No subscript.
go to 210
endif
c.... A subscript exists.
c.... Find the indices of the first and last non-blank characters.
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
210 continue
cbugc***DEBUG begins.
cbug 9903 format (/ 'aptsubr results: lstem =',i3,' lsub =',i3,
cbug $ ' nerr =',i2,'.')
cbug 9904 format (' astem =',2x,82a1)
cbug 9907 format (' asub =',2x,82a1)
cbug
cbug aquote = '"'
cbug write ( 3, 9903) lstem, lsub, nerr
cbug write ( 3, 9904) aquote, (astem(nn), nn = 1, lstem),
cbug & aquote
cbug write ( 3, 9907) aquote, (asub(nn), nn = 1, lsub),
cbug & aquote
cbugc***DEBUG ends.
return
c.... End of subroutine aptsubr. (+1 line.)
end
UCRL-WEB-209832