subroutine aptchin (nadd, asrce, isrce, nchar, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTCHIN
c
c     call aptchin (nadd, asrce, isrce, nchar, nerr)
c
c     Version:  aptchin  Updated    2003 June 30 16:00.
c               aptchin  Originated 1991 November 21 18:00.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To increment (nadd > 0) or decrement (nadd < 0) any numeric
c               or alphabetic (lower or upper case) characters in array asrce,
c               in the character string starting at character position isrce in
c               asrce, of length nchar.  The procedure begins at the rightmost
c               character of the string, and carries to the left, if necessary,
c               ignoring any blank, non-numeric, or non-alphabetic characters.
c               In any character positions, numbers remain numbers, and case
c               does not change.  Flag nerr indicates any input error, or
c               failure to properly alter the character string.
c
c     Examples: Incrementing "a9.9" results in "b0.0".  Decrementing "1.A"
c               results in "0.Z".  Incrementing "+++" fails, with nerr = 3.
c               Decrementing "3 A  " results in "2 Z  ".  Decrementing "aaa"
c               results in "zzz", with nerr = 4.
c
c     Input:    nadd, asrce, isrce, nchar.
c
c     Output:   asrce, nerr.
c
c     Glossary:
c
c     asrce     In/Out   An array containing a character string.
c
c     isrce     Input    The character position in array asrce of the first
c                          character of the string.  E. g., isrce = 1 means
c                          the leftmost character of asrce(1).
c                          Must be positive.
c
c     nadd      Input    Indicates the number of times (absolute value) the
c                          character string should be incremented (positive)
c                          or decremented (negative).  Zero for no change.
c
c     nchar     Input    The length of the character string. Must be positive.
c
c     nerr      Output   Indicates an input or result error, if not zero.
c                          1 if nchar is not positive.
c                          2 if isrce is not positive.
c                          3 if the character string can not be altered.
c                          4 if the leftmost required carry can not be done.
c                            Stops processing immediately, regardless of nadd.
c
c     Changes:  1993 March 16 15:40.  Corrected bug in decrementing, that
c               affected any decrement through "1", "b", or "B".
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

c.... Dimensioned arguments.

      dimension asrce   (1)           ! Array containing character string.
      character asrce*1               ! Array containing character string.

c.... Local variables.

      character*1 aschar  (65)        ! Array of ASCII numbers and letters.

c.... Note positions of 9, 0, z, a, Z, A, and repeat of 1, b, B.

      data aschar /
     &  '1', '2', '3', '4', '5', '6', '7', '8', '9', '0', '1',
     &  'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l',
     &  'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
     &  'x', 'y', 'z', 'a', 'b',
     &  'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L',
     &  'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
     &  'X', 'Y', 'Z', 'A', 'B' /

      common /laptchin/ idir          ! Incrementing (+1) or decrementing (-1).
      common /laptchin/ na            ! Count from 1 to nadda.
      common /laptchin/ nadda         ! Absolute value of nadd.
      common /laptchin/ nbeg          ! Starting index in aschar.
      common /laptchin/ nc            ! Index in character string.
      common /laptchin/ nd            ! Index in aschar.
      common /laptchin/ nd1           ! Initial search index.
      common /laptchin/ nd2           ! Final search index.
cbugc*** DEBUG begins.
cbugc.... Number of character of asrce to write.
cbug      common /laptchin/ nmaxa
cbug 9901 format (/ 'aptchin incrementing or decrementing ASCII.' /
cbug     &  '  nadd=',i3,'  isrce=',i6,'  nchar=',i6)
cbug 9902 format ('  asrce=',64a1)
cbug      write ( 3, 9901) nadd, isrce, nchar
cbug      nmaxa = 8 * (1 + (isrce + nchar - 2) / 8)
cbug      write ( 3, 9902) (asrce(nc), nc = 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.... Find out if incrementing or decrementing.

      if (nadd .eq. 0) then           ! No change required.
        go to 210
      elseif (nadd .gt. 0) then       ! Incrementing.
        nbeg  = 1
        idir  = 1
        nadda = nadd
        nd1 = nbeg
        nd2 = nbeg + 63
      else                            ! Decrementing.
        nbeg  = 2
        idir  = -1
        nadda = -nadd
        nd1 = nbeg + 63
        nd2 = nbeg
      endif

c.... Process the character string abs (nadd) times.

      do 130 na = 1, nadda            ! Loop over string processing.

        nerr = 3                      ! No change yet.

c....   Process (increment or decrement) character string from right to
c....     left (from asrce(isrce +nchar-1) to asrce(isrce)).

        do 120 nc = nchar, 1, -1      ! Loop over string characters.

c....     Test for match between string character and ASCII character.

          do 110 nd = nd1, nd2, idir  ! Loop over ASCII characters.

            if (asrce(isrce +nc-1) .eq. aschar(nd)) then ! Found match.
              nerr = 0                ! Changed character.
              asrce(isrce +nc-1) = aschar(nd+idir) ! Increment or decrement.
              if ((nd .eq. (nbeg +  8)) .or.
     &            (nd .eq. (nbeg + 35)) .or.
     &            (nd .eq. (nbeg + 62))) then
                nerr = 4              ! No carry yet.
                go to 120             ! Requires carry to left.
              endif
              go to 130               ! No carry required.
            endif                     ! Tested character.

  110     continue                    ! End of loop over ASCII characters.

  120   continue                      ! End of loop over string characters.

        if (nerr .ne. 0) go to 210    ! Process failed.

  130 continue                        ! End of loop over string processing.

  210 continue
cbugc*** DEBUG begins.
cbug 9905 format (/ 'aptchin results:  nerr=',i2)
cbug      write ( 3, 9905) nerr
cbug      write ( 3, 9902) (asrce(nc), nc = 1, nmaxa)
cbugc*** DEBUG ends.
      return

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

UCRL-WEB-209832