subroutine aptbits (worda, wrap, nshift, nbitw, wordb, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTBITS
c
c     call aptbits (worda, wrap, nshift, nbitw, wordb, nerr)
c
c     Version:  aptbits  Updated    1997 July 30 12:50.
c               aptbits  Originated 1992 March 2 10:00.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To shift the bits in worda, with bits pulled in from wrap,
c               a total of nshift bits right (positive) or left (negative).
c               The number of bits per machine word is nbitw.  The result will
c               be stored in wordb, which may be worda.
c               Flag nerr indicates any input error.
c
c     Input:    worda, wrap, nshift, nbitw.
c
c     Output:   wordb, nerr.
c
c     Calls: aptbite, aptbitp 
c               
c
c     Glossary:
c
c     nshift    Input    The number of bits to shift the bits in worda to form
c                          wordb.  Positive to shift right, negative to shift
c                          left.  Bits will be pulled in from wrap.
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 error, if not zero.
c                          1 if nshift is not between -nbitw and nbitw.
c                          2 if nbitw is not a positive multiple of 8, or
c                            exceeds 640.
c
c     worda     Input    A word containing nbitw bits, to be shifted right or
c                          left, with bits pulled in from wrap.
c
c     wordb     Output   A word containing nbitw bits, the result of shifting
c                          the bits in (wrap, worda, wrap) right or left, and
c                          keeping the central set of nbitw bits.  May be worda.
c                          Zero if an input error is found.
c
c     wrap      Input    A word containing nbitw bits.  The result of the shift
c                          will be as if the bits of wrap were concatenated to
c                          the left and to the right of the bits of worda before
c                          the shift, and all of the bits were shifted.
c                          For a wrap-around shift, make wrap = worda.
c                          To pull in zeros, make wrap = 0.
c
c     Changes:  1992 October 5.  Changed to allow wordb to be worda.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

c.... Local variables.

      common /laptbitb/ ibit  (1280)  ! Array of bits from worda, wrap.
      integer*1         ibit          ! Array of bits from worda, wrap.
      common /laptbits/ idiff         ! Offset in ibit.
      common /laptbits/ nbitx         ! A positive multiple of 8.
      common /laptbits/ wordc         ! Initial value of worda.
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptbits shifting the bits in worda.',
cbug     &  '  nshift=',i5)
cbug 9902 format ('  worda=',z16 / '  wrap =',z16)
cbug      write ( 3, 9901) nshift
cbug      write ( 3, 9902) worda, wrap
cbugc***DEBUG ends.

c.... Initialize.

      nerr  = 0
      wordc = worda
      wordb = 0.0

c.... Test for input errors.

      if ((nshift .lt. -nbitw) .or. (nshift .gt. nbitw)) then
        nerr = 1
        go to 210
      endif

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

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

c.... Expand wordc and wrap into a bit array of length 2 * nbitw,
c....   then find offset and repack into wordb.

c---- Shift left.
      if (nshift .lt. 0) then

        call aptbite (wordc, nbitw, nbitw, ibit, nerr)

        call aptbite (wrap, nbitw, nbitw, ibit(nbitw+1), nerr)

        call aptbitp (ibit(1-nshift), nbitw, nbitw, wordb, nerr)

c---- No shift.
      elseif (nshift .eq. 0) then

        wordb = wordc

c---- Shift right.
      else

        call aptbite (wrap, nbitw, nbitw, ibit, nerr)

        call aptbite (wordc, nbitw, nbitw, ibit(nbitw+1), nerr)

        call aptbitp (ibit(1+nbitw-nshift), nbitw, nbitw, wordb, nerr)

      endif

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

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

UCRL-WEB-209832