subroutine aptbitb (abitop, worda, wordb, nbitw, wordc, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTBITB
c
c call aptbitb (abitop, worda, wordb, nbitw, wordc, nerr)
c
c Version: aptbitb Updated 2004 August 25 17:00.
c aptbitb Originated 1992 March 2 10:00.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To do the Boolean operation abitop ("comp", "xnor" = "eqv",
c "and" = "int", "or" = "un", "nand", "nor" or "xor" on the
c operands worda and wordb, each containing nbitw bits, and store
c the results in wordc.
c Flag nerr indicates any input error.
c
c Input: abitop, worda, wordb, nbitw.
c
c Output: wordc, nerr.
c
c Calls: aptbite, aptbitp
c
c
c Glossary:
c
c abitop Input A type character*8 ASCII word, indicating the Boolean
c operation to be performed on worda and wordb.
c The operation is done separately on each pair of
c corresponding bits of worda and wordb, and each
c result bit is stored in the corresponding bit of
c wordc. The options are:
c "comp" for the complement of worda (ignore wordb):
c 0 -> 1. 1 -> 0.
c "not" for the "not" of worda and wordb:
c (1, 0) -> 1, (0, 0), (0, 1) and (1, 1) -> 0.
c "and" or "int" for the intersection of worda and
c wordb (logical product):
c (1, 1) -> 1. (0, 0) and (0, 1) and (1, 0) -> 0.
c "nand" for the "nand" ofworda and wordb:
c (0, 0), (0, 1) and (1, 0) -> 1. (1, 1) -> 0.
c "or" or "un" for the union of worda and wordb
c (logical sum):
c (1, 1) and (0, 1) and (1, 0) -> 1. (0, 0) -> 0.
c "nor" for the "nor" of worda and wordb:
c (0, 0) -> 1, (0, 1), (1, 0) and (1, 1) -> 0.
c "xor" for the "exclusive or" of worda and wordb:
c (0, 1) and (1, 0) -> 1. (0, 0) and (1, 1) -> 0.
c "xnor" or "eqv" for the equivalence of worda and
c wordb:
c (1, 1) and (0, 0) -> 1 and (0, 1) and (1, 0) -> 0.
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 abitop is not "comp", "eqv", "int", "nor",
c "not", "un" or "xor".
c 2 if nbitw is not a positive multiple of 8, or
c exceeds 640.
c
c worda Input A word containing nbitw bits.
c
c wordb Input A word containing nbitw bits.
c Not used if abitop = "comp".
c
c wordc Output A word containing nbitw bits, the result of the
c Boolean operation abitop on worda and wordb.
c Zero if an input error is found.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Input argument specifications.
character*8 abitop ! ASCII word for Boolean operation.
c.... Local variables.
common /laptbitb/ ibita (640) ! Array of bits from worda, wordc.
integer*1 ibita ! Array of bits from worda, wordc.
common /laptbitb/ ibitb (640) ! Array of bits from wordb.
integer*1 ibitb ! Array of bits from wordb.
common /laptbitb/ n ! Index in arrays.
common /laptbitb/ nbitx ! A positive multiple of 8.
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptbitb doing Boolean operation on worda, wordb.',
cbug & ' abitop=',a8)
cbug 9902 format (' worda=',z16 / ' wordb=',z16)
cbug write ( 3, 9901) abitop
cbug write ( 3, 9902) worda, wordb
cbugc***DEBUG ends.
c.... Initialize.
nerr = 0
wordc = 0.0
c.... Test for input errors.
nbitx = 8 + 8 * ((nbitw - 1) / 8)
if ((nbitw .ne. nbitx) .or. (nbitw .gt. 640))then
nerr = 2
go to 210
endif
c.... Find the bit expansions of worda and, if needed, wordb.
call aptbite (worda, nbitw, nbitw, ibita, nerr)
if (abitop .ne. 'comp') then
call aptbite (wordb, nbitw, nbitw, ibitb, nerr)
endif
c.... Do the indicated Boolean operation.
c.... Find comp. worda.
if (abitop .eq. 'comp') then
do n = 1, nbitw
ibita(n) = 1 - ibita(n)
enddo
c.... Find worda .not. wordb.
elseif (abitop .eq. 'not') then
do n = 1, nbitw
if ((ibita(n) .eq. 1) .and. (ibitb(n) .eq. 0)) then
ibita(n) = 1
else
ibita(n) = 0
endif
enddo
c.... Find worda .and. wordb.
elseif ((abitop .eq. 'and') .or.
& (abitop .eq. 'int')) then
do n = 1, nbitw
ibita(n) = ibita(n) * ibitb(n)
enddo
c.... Find worda .nand. wordb.
elseif (abitop .eq. 'nand') then
do n = 1, nbitw
ibita(n) = 1 - ibita(n) * ibitb(n)
enddo
c.... Find worda .or. wordb.
elseif ((abitop .eq. 'or') .or.
& (abitop .eq. 'un')) then
do n = 1, nbitw
ibita(n) = ibita(n) + ibitb(n) - ibita(n) * ibitb(n)
enddo
c.... Find worda .nor. wordb.
elseif (abitop .eq. 'nor') then
do n = 1, nbitw
ibita(n) = 1 + ibita(n) * ibitb(n) - ibita(n) - ibitb(n)
enddo
c.... Find worda .xor. wordb.
elseif (abitop .eq. 'xor') then
do n = 1, nbitw
ibita(n) = (ibita(n) - ibitb(n))**2
enddo
c.... Find worda .xnor. wordb.
elseif ((abitop .eq. 'xnor') .or.
& (abitop .eq. 'eqv ')) then
do n = 1, nbitw
ibita(n) = 1 - (ibita(n) - ibitb(n))**2
enddo
else
c.... Input error.
nerr = 1
go to 210
endif ! Tested abitop.
c.... Repack result bit array into wordc.
call aptbitp (ibita, nbitw, nbitw, wordc, nerr)
210 continue
cbugc***DEBUG begins.
cbug 9903 format (/ 'aptbitb results: nerr=',i2)
cbug 9904 format (' wordc=',z16)
cbug write ( 3, 9903) nerr
cbug if (nerr .ne. 0) return
cbug write ( 3, 9904) wordc
cbugc***DEBUG ends.
return
c.... End of subroutine aptbitb. (+1 line.)
end
UCRL-WEB-209832