subroutine aptbite (srce, nbits, nbitw, ibit, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTBITE
c
c call aptbite (srce, nbits, nbitw, ibit, nerr)
c
c Version: aptbite Updated 1997 July 28 17:00.
c aptbite Originated 1992 February 28 11:20.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To do a bit expansion of srce, moving the first nbits bits from
c srce, which has nbitw bits per machine word, into type integer*1
c array ibit, where each bit will be right-adjusted, left-filled
c with zeros. Each bit will be stored in a single element of
c array ibit. Flag nerr indicates any input error.
c
c Input: srce, nbits, nbitw.
c
c Output: ibit, nerr.
c
c Calls: None
c
c Glossary:
c
c ibit Output An array of type integer*1 machine words, each
c containing one bit from srce, right-adjusted and
c left-filled with zeros. Size must be at least nbits.
c If nerr is not zero, ibit will be filled with -1.
c
c nbits Input The number of bits to be expanded from srce to ibit.
c Must be in the range from 1 to 640.
c The minimum size of output array ibit.
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 a positive multiple of 8.
c 2 if nbitw is not a positive multiple of 8.
c
c srce Input An array containing at least nbits bits.
c
c Changes: 1992 May 22 14:20. Deleted "equivalence (asrce, srce)"
c and "character*1 srce".
c
c 1997 July 22 17:30. Completely revised method, to use
c an internal record for mode conversion to hex, followed
c by direct conversion from hex to binary.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
dimension srce (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 /laptbite/ atemp ! Temporary string for mode conversion.
character*160 atemp ! Temporary string for mode conversion.
common /laptbite/ achar(160) ! Temporory array for mode conversion.
character*1 achar ! Temporary array for mode conversion.
common /laptbite/ ibitx(640) ! Unpacked bits from srce.
integer*1 ibitx ! Unpacked bits from srce.
common /laptbite/ n ! Index in achar, srce, ibit, ibitx.
common /laptbite/ nn ! Index in ibit.
common /laptbite/ nbitx ! Number of bits in whole words of srce.
common /laptbite/ ncharh ! Number of hex digits in srce, achar.
common /laptbite/ nchars ! Number of ASCII characters in srce.
cbugc***DEBUG begins.
cbug common /laptbite/ nwords ! Number of words in srce.
cbug 9901 format (/ 'aptbite expanding machine words into bits.',
cbug & ' nbits=',i5,' nbitw=',i3)
cbug 9902 format (' srce="',z16,'"')
cbug 9903 format (' nwords=',i3)
cbug write ( 3, 9901) nbits, nbitw
cbug nwords = 1 + (nbits - 1) / nbitw
cbug write ( 3, 9903) nwords
cbug write ( 3, 9902) (srce(n), n = 1, nwords)
cbugc***DEBUG ends.
c.... Initialize.
nerr = 0
atemp = ' '
nbitx = nbits
if (nbitx .lt. 1) nbitx = 1
if (nbitx .gt. 640) nbitx = 640
do 110 n = 1, nbitx
ibit(n) = -1
110 continue
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.... Put srce into atemp in hex format.
8110 format (10z16)
nwords = 1 + (nbits - 1) / nbitw
nbitx = nbitw * nwords
write (atemp, 8110) (srce(n), n = 1, nwords)
c.... Put atemp into achar in single character format.
8120 format (160a1)
ncharh = 1 + (nbitx - 1) / 4
read (atemp, 8120) (achar(n), n = 1, ncharh)
c.... Convert the characters in achar into the bit array ibitx.
nn = 0
do 130 n = 1, ncharh
if (achar(n) .eq. '0') then
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
elseif (achar(n) .eq. '1') then
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
elseif (achar(n) .eq. '2') then
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
elseif (achar(n) .eq. '3') then
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
elseif (achar(n) .eq. '4') then
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
elseif (achar(n) .eq. '5') then
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
elseif (achar(n) .eq. '6') then
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
elseif (achar(n) .eq. '7') then
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
elseif (achar(n) .eq. '8') then
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
elseif (achar(n) .eq. '9') then
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
elseif ((achar(n) .eq. 'A') .or. (achar(n) .eq. 'a')) then
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
elseif ((achar(n) .eq. 'B') .or. (achar(n) .eq. 'b')) then
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
elseif ((achar(n) .eq. 'C') .or. (achar(n) .eq. 'c')) then
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
elseif ((achar(n) .eq. 'D') .or. (achar(n) .eq. 'd')) then
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 1
elseif ((achar(n) .eq. 'E') .or. (achar(n) .eq. 'e')) then
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 0
elseif ((achar(n) .eq. 'F') .or. (achar(n) .eq. 'f')) then
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
nn = nn + 1
ibitx(nn) = 1
else ! Leading zeros shown as blanks in hex.
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
nn = nn + 1
ibitx(nn) = 0
endif
130 continue
c.... Store nbits values if ibitx into ibit.
do 140 n = 1, nbits
ibit(n) = ibitx(n)
140 continue
210 continue
cbugc***DEBUG begins.
cbug 9904 format (/ 'aptbite results: nerr=',i2)
cbug 9905 format (' atemp=',a)
cbug 9906 format (' achar=',160a1)
cbug 9907 format (' ibit=' / 16(1x,4i1))
cbug write ( 3, 9904) nerr
cbug if (nerr .ne. 0) return
cbug write ( 3, 9905) atemp
cbug write ( 3, 9906) (achar(n), n = 1, ncharh)
cbug write ( 3, 9907) (ibit(n), n = 1, nbits)
cbugc***DEBUG ends.
return
c.... End of subroutine aptbite. (+1 line.)
end
UCRL-WEB-209832