subroutine aptquot (asrce, isrce, nchar, aq,
& aword, iword1, iword2, lword, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTQUOT
c
c call aptquot (asrce, isrce, nchar, aq,
c aword, iword1, iword2, lword, nerr)
c
c Version: aptquot Updated 2004 May 10 14:00.
c aptquot Originated 2004 May 10 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 delimited by the
c single character aq, normally a single quote (') or double
c quote ("), and to return any such string as aword, with initial
c starting and ending positions iword1 and iword2 in asrce and
c final length lword. Any pairs of the character aq found after
c the first aq are ignored as delimiters, and are then reduced to
c a single character aq in aword. If this happens, lword will be
c less than iword2 - iword1 + 1 by the number of such pairs.
c Flag nerr indicates any input error, or failure to find aword.
c
c Input: asrce, isrce, nchar, aq.
c
c Output: aword, iword1, iword2, lword, nerr.
c
c Calls: (none)
c
c Glossary:
c
c aq Input The character delimiting aword on the left and right.
c This character is ignored as a delimiter if it
c is found as a pair after its first occurrence.
c Any such pairs are reduced to a single aq in aword.
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 asrce, delimited by the character
c aq. Null if delimiter aq first occurs as a pair.
c Any internal pairs of aq within aword are
c ignored as delimiters and reduced to a single aq.
c Returned as blank if null, with nerr = -1.
c Returned as blank if none found, with 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 aq if aword
c is null. Zero if aword is not found.
c
c iword2 Output The character position in asrce at which aword ended,
c before reducing any internal pairs of the delimiter
c within aword to single characters.
c The character position before the second aq 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 reducing any internal pairs of the delimiter
c within aword to single characters.
c Zero if aword is null or not found.
c
c nchar Input The length of the string in character array asrce to be
c searched. Must be positive.
c
c nerr Output Indicates an input error, if positive, or no result if
c negative.
c -2 if no string aword delimited by aq 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 ! Position of beginning of aword in asrce.
integer iword2 ! Position of end of aword in asrce.
integer lword ! Final number of characters in aword.
integer nchar ! Number of characters to search in asrce.
integer nerr ! Error flag.
character*1 aq ! Delimiter character.
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 n ! Position of character in aword.
cbugc***DEBUG begins.
cbug character*1 abrack ! Character bracketing output display.
cbug if (aq .eq. '"') then
cbug abrack = ''''
cbug else
cbug abrack = '"'
cbug endif
cbug 9901 format (/ 'aptquot finding a delimited character string.' )
cbug 9902 format (' isrce=',i3,' nchar=',i3,' iend= ',i3,' aq=',a1)
cbug 9900 format (10x,
cbug & '12345678(1)2345678(2)2345678(3)2345678(4)2345678(5)2345678(6)')
cbug 9903 format (' asrce= ',70a1)
cbug 9904 format (' aptquot ERROR. nchar < 1.')
cbug write ( 3, 9901)
cbug iend = isrce + nchar - 1
cbug write ( 3, 9902) isrce, nchar, iend, aq
cbug if (nchar .ge. 1) then
cbug write ( 3, 9900)
cbug write ( 3, 9903) abrack, (asrce(n), n = 1, iend), abrack
cbug write ( 3, 9903) abrack, (asrce(n), n = isrce, iend), abrack
cbug else
cbug write ( 3, 9904)
cbug endif
cbugc***DEBUG ends.
c=======================================================================********
c.... initialize.
iend = nchar - 2
do 100 n = 1, iend
aword(n) = ' '
100 continue
iword1 = 0
iword2 = 0
lword = 0
nerr = 0
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 quote mark.
ibeg = isrce
iend = isrce + nchar - 2
cbugcbugc***DEBUG begins.
cbugcbug 9701 format ('Search for left delimiter in characters ',2i3)
cbugcbug write ( 3, 9701) ibeg, iend
cbugcbugc***DEBUG ends.
do 140 i = ibeg, iend
if (asrce(i) .eq. aq) then
iword1 = i + 1
cbugcbugc***DEBUG begins.
cbugcbug 9703 format ('Found first character of aword at character ',i3)
cbugcbug write ( 3, 9703) iword1
cbugcbugc***DEBUG ends.
go to 145
endif
140 continue
c.... No left delimiter was found.
iword1 = 0
iword2 = 0
nerr = -2
cbugcbugc***DEBUG begins.
cbugcbug 9704 format ('No left delimiter was found.')
cbugcbug write ( 3, 9704)
cbugcbugc***DEBUG ends.
go to 210
c.... Search for the right delimiter of aword, the first unpaired quote mark.
145 iend = isrce + nchar - 1
cbugcbugc***DEBUG begins.
cbugcbug 9712 format ('Search for right delimiter in characters ',2i3)
cbugcbug write ( 3, 9712) iword1, iend
cbugcbugc***DEBUG ends.
n = 0
i = iword1
150 if ((i .lt. iend) .and.
& (asrce(i) .eq. aq) .and.
& (asrce(i+1) .eq. aq)) then
cbugcbugc***DEBUG begins.
cbugcbug 9715 format ('Found pair of quotes in character i=',i3)
cbugcbug write ( 3, 9715) i
cbugcbugc***DEBUG ends.
n = n + 1
aword(n) = aq
i = i + 2
go to 150
endif
if (asrce(i) .eq. aq) then
iword2 = i - 1
cbugcbugc***DEBUG begins.
cbugcbug 9713 format ('Found end of aword in character i=',i3)
cbugcbug write ( 3, 9713) iword2
cbugcbugc***DEBUG ends.
go to 190
else
if ((n .eq. (nchar - 2)) .or. (i .eq. iend)) then
iword1 = 0
iword2 = 0
nerr = -2
cbugcbugc***DEBUG begins.
cbugcbug 9705 format ('No right delimiter was found.')
cbugcbug write ( 3, 9705)
cbugcbugc***DEBUG ends.
go to 210
else
n = n + 1
aword(n) = asrce(i)
i = i + 1
go to 150
endif
endif
c.... Found end of aword. See if null.
190 lword = n
if (lword .eq. 0) then ! Null aword.
nerr = -1
cbugcbugc***DEBUG begins.
cbugcbug 9714 format ('Found null aword.')
cbugcbug write ( 3, 9714)
cbugcbugc***DEBUG ends.
go to 210
endif
c=======================================================================********
210 continue
if (nerr .lt. 0) then
ibeg = 1
iend = nchar - 2
do 220 n = ibeg, iend
aword(n) = ' '
220 continue
endif
cbugc***DEBUG begins.
cbug 9906 format (/ 'aptquot results: iword1=',i3,' iword2=',i3,
cbug & ' lword=',i3,' nerr=',i2)
cbug 9907 format (/ 'aword = ',70a1)
cbug 9908 format (' aptquot ERROR. lword = 0.')
cbug write ( 3, 9906) iword1, iword2, lword, nerr
cbug if (lword .gt. 0) then
cbug write ( 3, 9907) abrack, (aword(n), n = 1, lword), abrack
cbug else
cbug write ( 3, 9908)
cbug endif
cbugc***DEBUG ends.
return
c.... End of subroutine aptquot. (+1 line.)
end
UCRL-WEB-209832