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