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