subroutine aptchsq (asrce, isrce, nchar, chout, nout, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTCHSQ c c call aptchsq (asrce, isrce, nchar, chout, nout, nerr) c c Version: aptchsq Updated 1993 February 18 10:30. c aptchsq Originated 1991 December 10 17:00. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To modify characters in array asrce, in the character string c starting at character position isrce in asrce, of length nchar, c by removing any character chout and shifting the remaining c nout characters to the left, and right-filling with blanks. c Flag nerr indicates any input error. c c Input: asrce, isrce, nchar, chout. c c Output: asrce, nout, nerr. c c Glossary: c c asrce In/Out An array containing a character string of length nchar, c starting at the isrce'th character, counting from c left to right, beginning with 1. c Must contain at least isrce + nchar - 1 characters. c c chout Input Character to be squeezed out of the character string. c c isrce Input The character position in array asrce of the first c character to be tested. E. g., 1 for the leftmost c character of asrce(1). Must be positive. c c nchar Input The length of the character string to be squeezed. c Must be positive. c c nerr Output Indicates an input error, if not zero. c 1 if nchar is not positive. c 2 if isrce is not positive. c c nout Output The number of characters remaining, not counting the c blanks filled to the right. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Dimensioned arguments. c---- Array containing character string. dimension asrce (1) c---- Array containing character string. character asrce*1 c---- Character to be removed. character chout*1 c.... Local variables. c---- Index in character string. common /laptchsq/ n c---- Character position of end of string. common /laptchsq/ nmax cbugc***DEBUG begins. cbugc---- Number of character of asrce to write. cbug common /laptchsq/ nmaxa cbug 9901 format (/ 'aptchsq removing characters in a string.' / cbug & ' isrce=',i6,' nchar=',i6,' chout=',a1) cbug 9902 format (' asrce=',64a1) cbug write ( 3, 9901) isrce, nchar, chout cbug nmaxa = 8 * (1 + (isrce + nchar - 2) / 8) cbug write ( 3, 9902) (asrce(n), n = 1, nmaxa) cbugc***DEBUG ends. c.... initialize. nerr = 0 c.... Test for input errors. if (nchar .le. 0) then nerr = 1 go to 210 endif if (isrce .le. 0) then nerr = 2 go to 210 endif c.... Remove any characters chout in the character string. nmax = isrce + nchar - 1 nout = 0 do 110 n = isrce, nmax if (asrce(n) .ne. chout) then nout = nout + 1 asrce(isrce +nout-1) = asrce(n) endif 110 continue c.... Right-fill with blanks, if needed. if ((isrce + nout - 1) .eq. nmax) go to 210 do 120 n = isrce + nout, nmax asrce(n) = ' ' 120 continue 210 continue cbugc***DEBUG begins. cbug 9905 format (/ 'aptchsq results: nout=',i3,' nerr=',i2) cbug write ( 3, 9905) nout, nerr cbug write ( 3, 9902) (asrce(n), n = 1, nmaxa) cbugc***DEBUG ends. return c.... End of subroutine aptchsq. (+1 line.) end UCRL-WEB-209832