subroutine aptblsq (asrce, isrce, nchar, asink, isink,
     &           lsink, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTBLSQ
c
c     call aptblsq (asrce, isrce, nchar, asink, isink, lsink, nerr)
c
c     Version:  aptblsq  Updated    2006 January 9 16:20.
c               aptblsq  Originated 2005 December 20 16:30.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To remove extra blank characters from a character string.
c               The string starts at the isrce'th character of asrce, has length
c               nchar, and will be moved into asink, starting at the isink'th
c               character of asink.  Up to 1024 characters will be moved
c               correctly if the source and sink locations of the character
c               string overlap.  Flag nerr indicates any input error.
c
c     Input:    asrce, isrce, nchar, asink, isink.
c
c     Output:   asink, lsink, nerr.
c
c     Glossary:
c
c     asrce     Input    The array containing a character string, starting at
c                          the isrce'th character, with length nchar, to have
c                          multiple blanks reduced to single blanks, and be
c                          moved into array asink.  Size must be at least
c                          isrce + nchar - 1.
c
c     asink     In/Out   The array receiving the character string, starting at
c                          the isink'th character.  Size must be at least
c                          isink + nchar - 1.
c
c     isrce     Input    The character position in array asrce of the first
c                          character to be tested and moved.  E. g., 1 for the
c                          leftmost character of asrce(1).  Must be positive.
c
c     isink     Input    The character position in array asink receiving the
c                          first character to be moved.  Must be positive.
c
c     lsink     Output   The number of characters put into asink, starting a
c                          the isink'th character.
c
c     nchar     Input    The length of the character string to be tested and
c                          moved.  Must be positive.  If more than 1024, overlap
c                          of arrays asrce and asink may result in error.
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                          3 if isink is not positive.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

c.... Dimensioned arguments.

      character*1 asrce(1)            ! Input string.     
      character*1 asink(1)            ! Output string.    

c.... Local variables.

      integer n                       ! Index in character string.

      character*1 abuff(1024)
      character*1 aquote

cbugc***DEBUG begins.
cbug      integer ncharm
cbug      integer nmaxa
cbug      integer nmaxb
cbug 9901 format (/ 'aptblsq removing multiple blanks from a',
cbug     & ' character string.' /
cbug     &  '  isrce=',i6,'  nchar=',i6,'  isink=',i6)
cbug 9902 format ('  asrce = ',1002a1)
cbug      aquote = '"'
cbug      nmaxa = isrce + nchar - 1
cbug      write ( 3, 9901) isrce, nchar, isink
cbug      write ( 3, 9902) aquote, (asrce(n), n = isrce, nmaxa), aquote
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

      if (isink .le. 0) then
        nerr = 3
        go to 210
      endif

c.... Move the character string from asrce to asink.

c.... Use abuff to prevent overstoring.

      if (nchar .le. 1024) then

        do n = 1, nchar
          abuff(n) = ' '
          asink(n) = ' '
        enddo

        nout = 1
        abuff(nout) = asrce(isrce)
        do 110 n = 2, nchar
          if ((asrce(isrce+n-1) .eq. ' ') .and.
     &        (asrce(isrce+n-2) .eq. ' ')) go to 110
          nout = nout + 1
          abuff(nout) = asrce(isrce+n-1)
  110   continue

        if (abuff(nout) .eq. ' ') then
          nout = nout - 1
        endif

        lsink = nout

        do n = 1, lsink
          asink(isink+n-1) = abuff(n)
        enddo

      else                            ! Make no check for overstoring.

cbugcbugc***DEBUG begins.
cbugcbug        nout = 1
cbugcbug        abuff(nout) = asrce(isrce)
cbugcbug        do 120 n = 2, 1024
cbugcbug          if ((asrce(isrce+n-1) .eq. ' ') .and.
cbugcbug     &        (asrce(isrce+n-2) .eq. ' ')) go to 120
cbugcbug          nout = nout + 1
cbugcbug          abuff(nout) = asrce(isrce+n-1)
cbugcbug  120   continue
cbugcbug        lsink = nout
cbugcbug
cbugcbug        if (abuff(nout) .eq. ' ') then
cbugcbug          nout = nout - 1
cbugcbug        endif
cbugcbug
cbugcbugc***DEBUG ends.

        nout = 1
        asink(isink+nout-1) = asrce(isrce)
        do 130 n = 2, 1024
          if ((asrce(isrce+n-1) .eq. ' ') .and.
     &        (asrce(isrce+n-2) .eq. ' ')) go to 130
          nout = nout + 1
          asink(isink+nout-1) = asrce(isrce+n-1)
  130   continue

        if (asink(isink+nout-1) .eq. ' ') then
          nout = nout - 1
        endif

        lsink = nout

      endif                           ! Tested nchar.

cbugc***DEBUG begins.
cbug 9904 format (/ 'aptblsq results:  lsink =',i5,'.')
cbug 9905 format ('  abuff = ',1024a1)
cbug 9906 format ('  asink = ',1024a1)
cbug      write ( 3, 9904) lsink
cbug      ncharm = min (nchar, 1024)
cbug      nmaxb = isink + lsink - 1
cbug      write ( 3, 9905) aquote, (abuff(n), n = 1, ncharm), aquote
cbug      write ( 3, 9906) aquote, (asink(n), n = isink, nmaxb), aquote
cbugc***DEBUG ends.
  210 return

c.... End of subroutine aptblsq.      (+1 line.)
      end

UCRL-WEB-209832