MODULE bpack
INTEGER, PARAMETER :: ip4 = SELECTED_INT_KIND ( 9 )
integer(ip4) imask (16) !! Feld fuer Bitmasken.
integer(ip4), dimension(:), allocatable :: feld, feldabw, packfeld
integer :: feldmax = 0, feldmin = 0, ampl = 0
integer :: npack = 0, nsize = 1, offset = 0, lbits = 0, size = 15
integer laenge
real :: faktor = 1.0
END MODULE bpack
subroutine bitpack
!****************************************************************
USE bpack
!
!----- Deklarationen
!
IMPLICIT NONE
!
!----- Interna.
!
INTEGER :: i,ii,dummy1,dummy2,anfpos,nfrei
INTEGER(ip4) :: mask
!
!----- Das Packen.
!
anfpos = 0
ii = 1
!
DO i=1,laenge
!
dummy1 = IAND(feld(i),imask(nsize))
!
nfrei = 32 - anfpos - nsize
IF (nfrei > 0) THEN ! Info in Wort ii anfuegen.
anfpos = anfpos + nsize
dummy2 = ISHFT(dummy1,nfrei)
packfeld(ii) = packfeld(ii) + dummy2
ELSE IF (nfrei .EQ. 0) THEN ! Mit neuem Info ist Wort ii voll!
packfeld(ii) = packfeld(ii) + dummy1
ii = ii+1
anfpos = 0
ELSE ! Info muss auf ii und ii+1 verteilt werden.
dummy2 = ISHFT(dummy1,nfrei)
packfeld(ii) = packfeld(ii) + dummy2
packfeld(ii+1) = ISHFT(dummy1, 32+nfrei)
ii = ii+1
anfpos = -nfrei
ENDIF
!
END DO
!
RETURN
!
!---- Ende von *bitpack*
!
END SUBROUTINE bitpack
|