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