subroutine aptfbrk (asrce, isrce, nchar, al, ar, aesc,
& aword, iword1, iword2, lword, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTFRBK
c
c call aptfbrk (asrce, isrce, nchar, al, ar, aesc,
c aword, iword1, iword2, lword, nerr)
c
c Version: aptfbrk Updated 2004 May 14 15:40.
c aptfbrk Originated 2004 April 23 14:00
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To search character array asrce from character position isrce,
c over nchar characters, for the first string with left and right
c delimiters specified by al (if not preceded by non-blank escape
c character aesc) and ar (if not preceded by aesc), and return it
c as aword, with its initial starting and ending positions iword1
c and iword2 in asrce and its length lword.
c See aptffip, aptchap, aptchfp, aptchfs for related functions.
c Flag nerr indicates any input error, or an odd result.
c
c Input: asrce, isrce, nchar, al, ar, aesc.
c
c Output: aword, iword1, iword2, lword, nerr.
c
c Calls: (none)
c
c Glossary:
c
c aesc Input The escape character, if not blank. An escape
c character preceding a delimiting character causes the
c latter not to be recognized as a delimiter, and that
c escape character is removed from aword. For example,
c the escape character might be a backslash, \.
c
c al Input The character delimiting aword on the left, if not
c preceded by escape character aesc.
c For example, al and ar may be one of the following
c pairs of characters: ( ), < >, [ ], { }.
c For al = ar = ' or ", with occurrences within aword
c replaced by '' or "", respectively, use aptquot.
c
c ar Input The character delimiting aword on the right, if not
c preceded by escape character aesc.
c
c asrce Input A character array. Memory size must be at least
c isrce + nchar - 1 characters.
c
c aword Output The first character string, if any, found in character
c array asrce, in the nchar characters starting at
c position isrce of asrc, delimited on the left by the
c character al, and on the right by the character ar.
c Delimiters al and ar are ignored if preceded by the
c escape character aescs, which is the removed from
c aword.
c Returned as blank if null, wth nerr = -1.
c Returned as blank if none found, wth nerr = -2.
c
c Memory size must be at least nchar - 2 characters.
c If aword is not completely blanked out before
c calling this subroutine, any characters beyond
c nchar - 2 characters may not be blank.
c
c isrce Input The character position in character array asrce at
c which to begin the search for aword.
c Must be positive.
c
c iword1 Output The character position in asrce at which aword begins.
c The character position after the first al if aword
c is null. Zero if aword is not found.
c
c iword2 Output The character position in asrce at which aword ends,
c before removing any escape characters preceding
c ar within aword.
c The character position before the first ar if aword
c is null. Zero if aword is not found.
c
c lword Output The number of characters in character string aword,
c after removing any escape characters within aword
c that precede ar. Before removing escape characters,
c the length of aword is iword2 - iword1 + 1.
c Zero if aword is null or not found.
c
c nchar Input The length of the string in character array asrce
c to be searched. Must be positive.
c
c nerr Output Indicates an input error, if positive, or an odd
c result if negative.
c -2 if no delimited string aword is found.
c -1 if a null delimited string aword is found.
c 0 if a non-null delimited string aword is found.
c 1 if isrce is not positive.
c 2 if nchar is not positive.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
implicit none
c.... Arguments.
integer isrce ! Beginning position of search in asrce.
integer iword1 ! Beginning position of aword in asrce.
integer iword2 ! End position of aword in asrce.
integer lword ! Number of characters in aword.
integer nchar ! Number of characters to search in asrce.
integer nerr ! Error flag. Zero if none.
character*1 aesc ! Escape character, if not blank.
character*1 al ! Character delimiting aword on left.
character*1 ar ! Character delimiting aword on right.
character*1 asrce (1) ! A character array.
character*1 aword (1) ! A delimited character string in asrce.
c.... Local variables.
integer i ! Position of character in asrce.
integer ibeg ! Position in asrce to begin search.
integer iend ! Position in asrce to end search.
integer imin ! Maximum of i - 1, ibeg.
integer n ! Position of character in aword.
cbugc***DEBUG begins.
cbug character*1 aquote
cbug aquote = '$'
cbug 9901 format (/ 'aptfbrk finding a delimited character string.' )
cbug 9902 format (' isrce=',i3,' nchar=',i3,' iend= ',i3)
cbug 9900 format (11x,
cbug & '12345678(1)2345678(2)2345678(3)2345678(4)2345678(5)2345678(6)')
cbug 9903 format (' asrce = ',70a1)
cbug 9905 format (' al = ',3a1 / ' ar = ',3a1 / ' aesc = ',3a1 )
cbug 9904 format (' aptfbrk ERROR. nchar < 1.')
cbug write ( 3, 9901)
cbug iend = isrce + nchar - 1
cbug write ( 3, 9902) isrce, nchar, iend
cbug if (nchar .ge. 1) then
cbug write ( 3, 9900)
cbug write ( 3, 9903) aquote, (asrce(n), n = 1, iend), aquote
cbug write ( 3, 9903) aquote, (asrce(n), n = isrce, iend), aquote
cbug else
cbug write ( 3, 9904)
cbug endif
cbug write ( 3, 9905) aquote, al, aquote, aquote, ar, aquote,
cbug & aquote, aesc, aquote
cbugc***DEBUG ends.
c=======================================================================********
c.... initialize.
iword1 = 0
lword = 0
nerr = 0
do 100 n = 1, nchar
aword(n) = ' '
100 continue
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
c=======================================================================********
c.... Search for the left delimiter of aword, the first occurrence of al.
ibeg = isrce
iend = isrce + nchar - 2
cbugcbugc***DEBUG begins.
cbugcbug 9701 format (' Search for first character in characters ',2i3)
cbugcbug write ( 3, 9701) ibeg, iend
cbugcbugc***DEBUG ends.
c.... A single character cannot have both delimiters.
if (ibeg .eq. iend) then
nerr = -2
go to 210
endif
c.... Accept an initial delimiter.
if (asrce(isrce) .eq. al) then
iword1 = isrce + 1
cbugcbugc***DEBUG begins.
cbugcbug 9703 format (' Found first character of aword at character i=',i3,
cbugcbug & 2x,3a1)
cbugcbug write ( 3, 9703) iword1, aquote, asrce(iword1), aquote
cbugcbugc***DEBUG ends.
go to 175
endif
do 170 i = ibeg, iend ! Loop over all characters.
imin = i - 1
if (imin .lt. ibeg) imin = ibeg
if ((asrce(i) .eq. al ) .and.
& ((aesc .eq. ' ' ) .or.
& (asrce(imin) .ne. aesc))) then
iword1 = i + 1
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9703) iword1, aquote, asrce(iword1), aquote
cbugcbugc***DEBUG ends.
go to 175
endif
170 continue
c.... No left delimiter was found.
cbugcbugc***DEBUG begins.
cbugcbug 9704 format (' aptfbrk ERROR. No left delimiter.')
cbugcbug write ( 3, 9704)
cbugcbugc***DEBUG ends.
nerr = -2
go to 210
c.... Search for the first right delimiter not preceded by aesc.
175 ibeg = iword1
iend = isrce + nchar - 1
cbugcbugc***DEBUG begins.
cbugcbug 9712 format (' Search for right delimiter in characters ',2i3)
cbugcbug write ( 3, 9712) ibeg, iend
cbugcbugc***DEBUG ends.
do 180 i = ibeg, iend
imin = i - 1
if (imin .lt. ibeg) imin = ibeg
if ((asrce(i) .eq. ar ) .and.
& ((aesc .eq. ' ' ) .or.
& (asrce(imin) .ne. aesc))) then
iword2 = i - 1
cbugcbugc***DEBUG begins.
cbugcbug 9713 format (' Found end of aword in character i=',i3,2x,3a1)
cbugcbug write ( 3, 9713) iword2, aquote, asrce(iword2), aquote
cbugcbugc***DEBUG ends.
go to 185
endif
180 continue
c.... No right delimiter was found.
nerr = -2
cbugcbugc***DEBUG begins.
cbugcbug 9714 format (' aptfbrk ERROR. No right delimiter.')
cbugcbug write ( 3, 9714)
cbugcbugc***DEBUG ends.
go to 210
c.... Store the string in aword, removing escape characters before al and ar.
185 lword = iword2 - iword1 + 1
if (lword .le. 0) then
nerr = -1
cbugcbugc***DEBUG begins.
cbugcbug 9715 format (' aptfbrk ERROR. Null word.')
cbugcbug write ( 3, 9715)
cbugcbugc***DEBUG ends.
go to 210
endif
ibeg = iword1
iend = iword2 - 1
n = 0
do 190 i = ibeg, iend
if (aesc .ne. ' ') then
if ((asrce(i) .eq. aesc) .and.
& ((asrce(i+1) .eq. al ) .or.
& (asrce(i+1) .eq. ar ))) then
go to 190
endif
endif
n = n + 1
aword(n) = asrce(i)
190 continue
n = n + 1
aword(n) = asrce(iword2)
lword = n
go to 210
c=======================================================================********
210 continue
cbugc***DEBUG begins.
cbug 9906 format (/ 'aptfbrk results: iword1=',i3,' lword=',i3,
cbug & ' nerr=',i3)
cbug 9907 format (/ 'aword = ',70a1)
cbug 9908 format (' aptfbrk ERROR. lword = 0.')
cbug write ( 3, 9906) iword1, lword, nerr
cbug if (lword .gt. 0) then
cbug write ( 3, 9907) aquote, (aword(n), n = 1, lword), aquote
cbug else
cbug write ( 3, 9908)
cbug endif
cbugc***DEBUG ends.
return
c.... End of subroutine aptfbrk. (+1 line.)
end
UCRL-WEB-209832