subroutine aptbitm (worda, ia, nbits, nbitw, wordb, ib, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTBITM
c
c     call aptbitm (worda, ia, nbits, nbitw, wordb, ib, nerr)
c
c     Version:  aptbitm  Updated    1997 July 30 12:50.
c               aptbitm  Originated 1992 February 28 14:40.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To move a bit string of length nbits from worda, starting at
c               bit ia, to wordb, starting at bit ib.  The number of bits per
c               machine word is nbitw.  Bits are counted from left to right,
c               starting with 1, and ending with nbitw.
c               Flag nerr indicates any input error.
c
c     Input:    worda, ia, nbits, nbitw.
c
c     Output:   wordb, ib, nerr.
c
c     Calls: aptbite, aptbitp 
c               
c
c     Glossary:
c
c     ia        Input    The bit position in worda of the first bit in the
c                          bit string to be moved to wordb.  Counted from the
c                          left, beginning with 1.
c                          May not exceed 1 + nbitw - nbits.
c
c     ib        Input    The bit position in wordb of the first bit in the
c                          bit string to be moved from worda.  Counted from the
c                          left, beginning with 1.
c                          May not exceed 1 + nbitw - nbits.
c
c     nbits     Input    The number of bits to be moved from worda to wordb.
c                          Must be positive.  May not exceed nbitw.
c
c     nbitw     Input    The number of bits in a machine word.  Limit is 640.
c                          Must be a positive multiple of 8.
c
c     nerr      Output   Indicates an input or result error, if not zero.
c                          1 if nbits is not positive.
c                          2 if nbitw is not a positive multiple of 8, or
c                            exceeds 640.
c                          3 if ia is not between 1 and 1 + nbitw - nbits.
c                          4 if ib is not between 1 and 1 + nbitw - nbits.
c
c     worda     Input    A word containing nbitw bits, including the bit string
c                          to be moved.
c
c     wordb     Output   A word containing nbitw bits, including the bit string
c                          moved from worda.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

c.... Local variables.

      common /laptbitm/ ibita  (640)  ! Array of bits from worda.
      integer*1         ibita         ! Array of bits from worda.
      common /laptbitm/ ibitb  (640)  ! Array of bits from wordb.
      integer*1         ibitb         ! Array of bits from wordb.
      common /laptbitm/ n             ! Index in bit string.
      common /laptbitm/ nbitx         ! A multiple of 8.  
      common /laptbitm/ ncharw        ! Number of 8-bit bytes per word.
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptbitm moving a bit string from worda to wordb.',
cbug     &  '  nbits=',i5)
cbug 9902 format ('  worda=',z16,'  ia=',i3)
cbug 9903 format ('  wordb=',z16,'  ib=',i3)
cbug      write ( 3, 9901) nbits
cbug      write ( 3, 9902) worda, ia
cbug      write ( 3, 9903) wordb, ib
cbugc***DEBUG ends.

c.... Test for input errors.

      nerr   = 0

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

      ncharw = 1 + (nbitw - 1) / 8
      nbitx  = 8 * ncharw

      if ((nbitw .ne. nbitx) .or. (nbitw .gt. 640))then
        nerr = 2
        go to 210
      endif

      if ((ia .lt. 1) .or. (ia .gt. (1 + nbitw - nbits))) then
        nerr = 3
        go to 210
      endif

      if ((ib .lt. 1) .or. (ib .gt. (1 + nbitw - nbits))) then
        nerr = 4
        go to 210
      endif

c.... Expand each word into bit arrays.

      call aptbite (worda, nbitw, nbitw, ibita, nerr)

      call aptbite (wordb, nbitw, nbitw, ibitb, nerr)

c.... Move bits from worda bit array to wordb bit array.

      do 110 n = 1, nbits
        ibitb(n+ib-1) = ibita(n+ia-1)
  110 continue

c.... Repack the wordb bit array back into wordb.

      call aptbitp (ibitb, nbitw, nbitw, wordb, nerr)

  210 continue
cbugc***DEBUG begins.
cbug 9904 format (/ 'aptbitm results:  nerr=',i2)
cbug      write ( 3, 9904) nerr
cbug      if (nerr .ne. 0) return
cbug      write ( 3, 9903) wordb, ib
cbugc***DEBUG ends.
      return

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

UCRL-WEB-209832