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