subroutine aptrmbl (nopt, asrce, isrce, nchar, iamax,
     &                    asink, isink, lsink, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTRMBL
c
c     call aptrmbl (nopt, asrce, isrce, nchar, iamax,
c                   asink, isink, lsink, nerr)
c
c     Version:  aptrmbl  Updated    2002 October 25 17:30.
c               aptrmbl  Originated 2002 October 25 17:00.
c
c     Authors:  Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To remove leading and/or trailing blanks from the input
c               character string of length nchar, starting at character
c               position isrce in character string asrce, and return the
c               result in character string asink.
c               Flag nerr indicates any input error.
c
c     Input:    asrce, isrce, nchar, iamax.
c
c     Output:   asink, isink, lsink, nerr.
c
c     Calls: (none) 
c
c     Glossary:
c
c     asrce     Input    A character array of type character, containing an
c                          input string of length nchar, starting in character
c                          position isrce.
c
c     asink     Output   A character string of type character, of length
c                          lsink (<= iamax), resulting from removal of leading
c                          and/or trailing blanks from the input string.
c                          Initialized to blank characters.
c
c     iamax     Input    Maximum number of characters for asrce, the input
c                          string and asink.
c
c     isink     Output   The character position in array asrce of the first
c                          character of the output string asink.
c
c     isrce     Input    The character position in array asrce of the first
c                          character of the input string.  E. g., isrce = 1
c                          means the leftmost character of asrce.
c                          Must be positive.
c
c     lsink     Output   The actual number of characters in string asink.
c                          May not exceed iamax.
c                          Zero if no non-blank characters.
c
c     nchar     Input    The number of characters in the input string.
c                          Must be positive.
c
c     nerr      Output   Indicates an input error, if not zero.  The last error
c                          found is indicated by:
c                          1 if isrce is not positive.
c                          2 if nchar is not positive.
c                          3 if isrce + nchar - 1 exceeds iamax.
c                          4 if iamax is not positive.
c                          5 if nopt is < 0 or > 3.
c
c     nopt      Input    Indicates option:
c                          0 to remove no blanks.                    Binary 00.
c                          1 to remove trailing blanks only.         Binary 01.
c                          2 to remove leading blanks only.          Binary 10.
c                          3 to remove leading and trailing blanks.  Binary 11.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

c.... Declarations for arguments.

      dimension    asrce(1)           ! String containing input string.
      character*1  asrce              ! String containing input string.

      dimension    asink(1)           ! Output string.
      character*1  asink              ! Output string.

c***DEBUG begins.
      character*1  aquote
      aquote = '"'
 9901 format (/ 'aptrmbl removing leading and/or trailing blanks.' /
     &  '  nopt =',i2,'  isrce =',i3,'  nchar =',i3,'  iamax =',i3 )
 9902 format ('  asrce =',2x,82a1)
      write ( 3, 9901) nopt, isrce, nchar, iamax
      if ((nchar .ge. 1) .and. (isrce .ge. 1)) then
        isink = isrce
        iend = isrce + nchar - 1
        if (isink .gt. iamax) isink = iamax
        if (iend .gt. iamax) iend = iamax
        write ( 3, 9902) aquote, (asrce(n), n = isink, iend), aquote
      endif
c***DEBUG ends.

c.... Initialize.

      isink = 0
      lsink = 0

      do 110 n = 1, iamax
        asink(n) = ' '
  110 continue

c.... Test for input errors.

      nerr  = 0

      if (isrce .le. 0) then
        nerr = 1
        go to 210
      endif

      if (nchar .le. 0) then
        nerr = 2
        go to 210
      endif

      if ((isrce + nchar - 1) .gt. iamax) then
        nerr = 3
        go to 210
      endif

      if (iamax .le. 0) then
        nerr = 4
        go to 210
      endif

      if ((nopt .lt. 0) .or. (nopt .gt. 3)) then
        nerr = 5
        go to 210
      endif

c.... Find the index of the first non-blank character of the string.

      ibeg1 = isrce
      iend1 = isrce + nchar - 1
      isink = ibeg1
      iend  = iend1

      if ((nopt .eq. 2) .or. (nopt .eq. 3)) then
        do 115 n = ibeg1, iend1
          if (asrce(n) .ne. ' ') then
            isink = n
            go to 120
          endif
  115   continue
        isink = iend1 + 1
      endif

c.... Find the index of the last non-blank character of the string.

  120 if ((nopt .eq. 1) .or. (nopt .eq. 3)) then
        do 125 n = iend1, isink, -1
          if (asrce(n) .ne. ' ') then
            iend = n
            go to 130
          endif
  125   continue
        iend = isink - 1
      endif

  130 continue
cbugc***DEBUG begins.
cbug 9701 format ('  ibeg1 =',i3,'  iend1 =',i3,'  isink =',i3,'  iend =',i3)
cbug      write ( 3, 9701) ibeg1, iend1, isink, iend
cbug      write ( 3, 9902) aquote,
cbug     &  (asrce(n), n = isink, iend), aquote
cbugc***DEBUG ends.

      if (iend .lt. isink) then
        go to 210
      endif

c.... Store the result in asink.

      nn = 0
      do 140 n = isink, iend
        nn        = nn + 1
        asink(nn) = asrce(n)
  140 continue
      lsink = iend - isink + 1

  210 continue
c***DEBUG begins.
 9903 format (/ 'aptrmbl results:  isink =',i3,'  lsink =',i3,
     &        '  nerr =',i2)
 9904 format ('  asink =',2x,82a1)
      write ( 3, 9903) isink, lsink, nerr
      if (lsink .gt. 0) then
        write ( 3, 9904) aquote, (asink(nn), nn = 1, lsink),
     &    aquote
      endif
c***DEBUG ends.
      return

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

UCRL-WEB-209832