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