subroutine aptbitp (ibit, nbits, nbitw, sink, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTBITP
c
c     call aptbitp (ibit, nbits, nbitw, sink, nerr)
c
c     Version:  aptbitp  Updated    1997 July 28 16:00.
c               aptbitp  Originated 1992 February 28 12:00.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To do a bit contraction of ibit, packing the rightmost bit of
c               the first nbits words of type integer*1 array ibit, into 
c               sink, which has nbitw bits per machine word.
c               Flag nerr indicates any input error.
c
c     Input:    ibit, nbits, nbitw.
c
c     Output:   sink, nerr.
c
c     Calls: aptbite 
c
c     Glossary:
c
c     ibit      Input    An array of type integer*1, each word containing only
c                          bit strings "00000000" or "00000001".
c                          Size must be at least nbits.
c
c     nbits     Input    The number of bits to be packed from ibit into sink.
c                          Must be in the range from 1 to 640.
c
c     nbitw     Input    The number of bits in a machine word.
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 between 1 and 640.
c                          2 if nbitw is not a positive multiple of 8.
c                          3 if array ibit contains anything other than
c                          bit strings "00000000" or "00000001".
c
c     sink      Output   An array of packed bits from ibit, plus any original
c                          bits of sink not written over.
c                          Size must be at least nbits / nbitw words.
c
c     Changes:  1992 May 22 14:20.  Deleted "equivalence (asink, sink)"
c               and "character*1 sink".
c
c               1997 July 25 14:50.  Completely revised method, to use direct
c               conversion from binary to hex, followed by use of an internal
c               record for mode conversion from hex to machine configuration.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

c.... Dimensioned arguments.

      dimension sink    (1)           ! Array of machine words.
      dimension ibit    (1)           ! Unpacked bits, 1 per machine word.
      integer*1 ibit                  ! Unpacked bits, 1 per machine word.

c.... Local variables.

      common /laptbitp/ atemp         ! Temporary string for mode conversion.
      character*160     atemp         ! Temporary string for mode conversion.
      common /laptbitp/ achar(160)    ! Temporary array for mode conversion.
      character*1       achar         ! Temporary array for mode conversion.

      common/laptbitp/  ibitx(640)    ! Unpacked bits from sink.
      integer*1 ibitx                 ! Unpacked bits from sink.

      common /laptbitp/ n             ! Index in ibit, ibitx, achar, sink.
      common /laptbitp/ nn            ! Index in achar.
      common /laptbitp/ nbitx         ! Number of bits in whole words of sink.
      common /laptbitp/ ncharh        ! Number of hex digits in sink, achar.
      common /laptbitp/ nchars        ! Number of ASCII characters in sink.
      common /laptbitp/ nwords        ! Number of words in sink.

      dimension   ahex(0:15)          ! Hex digits.
      character*1 ahex                ! Hex digits.
      data ahex / '0', '1', '2', '3', '4', '5', '6', '7',
     &            '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' /

cbugC***DEBUG begins.
cbug 9901 format (/ 'aptbitp packing bits into machine words.',
cbug     &  '  nbits=',i5,'  nbitw=',i3)
cbug 9902 format ('  ibit=' / 16(1x,4i1))
cbug 9903 format ('  nwords=',i3)
cbug 9904 format ('  sink=',z16)
cbug      write ( 3, 9901) nbits, nbitw
cbug      write ( 3, 9902) (ibit(n), n = 1, nbits)
cbug      nwords = 1 + (nbits - 1) / nbitw
cbug      write ( 3, 9903) nwords
cbug      write ( 3, 9904) (sink(n), n = 1, nwords)
cbugc***DEBUG ends.

c.... Initialize.

      nerr   = 0
      atemp  = ' '

c.... Test for input errors.

      if ((nbits .lt. 1) .or. (nbits .gt. 640)) then
        nerr = 1
        go to 210
      endif

      if (mod (nbitw, 8) .ne. 0) then
        nerr = 2
        go to 210
      endif

c.... Find bits from sink.

      nwords = 1 + (nbits - 1) / nbitw
      nbitx  = nbitw * nwords

      call aptbite (sink, nbitx, nbitw, ibitx, nerr)

      if (nerr .ne. 0) go to 210

c.... Replace original bits in sink with new bits.

      do 100 n = 1, nbits
        ibitx(n) = ibit(n)
  100 continue

c.... Convert groups of 4 bits from ibitx into single hex digits in achar.

      nn = 0

      do 130 n = 1, nbitx, 4          ! Loop over groups of 4 bits.

        nn = nn + 1

        isum = 8 * ibitx(n)   + 4 * ibitx(n+1) +
     &         2 * ibitx(n+2) +     ibitx(n+3)

        if ((isum .ge. 0) .and. (isum .le. 15)) then  ! Good hex digit.

          achar(nn) = ahex(isum) 

        else                          ! Not a hex digit.

          nerr = 3
          go to 210

        endif                         ! Tested isum.

  130 continue                        ! End of loop over groups of 4 bits.

      ncharh = 1 + (nbitx - 1) / 4

c.... Put the single hex digits in achar into the single hex string atemp.

 8120 format (160a1)

      write (atemp, 8120) (achar(n), n = 1, ncharh)

c.... Put the single hex string in atemp into the machine word sink.

 8110 format (10z16)

      read (atemp, 8110) (sink(n), n = 1, nwords)

  210 continue
cbugc***DEBUG begins.
cbug 9905 format (/ 'aptbitp results:  nerr=',i2)
cbug 9906 format ('  atemp=',a)
cbug 9907 format ('  achar=',160a1)
cbug      write ( 3, 9905) nerr
cbug      if (nerr .ne. 0) return
cbug      nwords = 1 + (nbitx - 1) / nbitw
cbug      write ( 3, 9907) (achar(n), n = 1, ncharh)
cbug      write ( 3, 9906) atemp
cbug      write ( 3, 9904) (sink(n), n = 1, nwords)
cbugc***DEBUG ends.
      return

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

UCRL-WEB-209832