compact.F90

Go to the documentation of this file.

SUBROUTINE compact(PVALCO_COMPACT,KNELEM,KBITEXPONENT,KBITRADICAL,KPACK)

USE parkind1 , ONLY : jprb
USE yomhook  , ONLY : lhook, dr_hook

IMPLICIT NONE

INTEGER(KIND=4) :: KNELEM
REAL(KIND=8) :: PVALCO_COMPACT(knelem)
REAL(KIND=8) :: ZCOEF,VALMIN,VALMAX
INTEGER(KIND=4) :: KBITEXPONENT,KBITRADICAL
INTEGER(KIND=8) :: KPACK(knelem)

REAL(KIND=4) :: ZTMPBUF
INTEGER(KIND=4) :: ITMPBUF
INTEGER(KIND=8) :: ICMPBUF,ILENGTH
INTEGER(KIND=4),ALLOCATABLE :: IBUF(:)
INTEGER(KIND=4) :: IPROMA,IPTRTAB,IPTRBIT,IENDBIT,I4B0,I4B1
INTEGER(KIND=2) :: I2B0,I2B1,I2B2,I2B3

REAL(KIND=JPRB) :: ZHOOK_HANDLE

equivalence(ztmpbuf,itmpbuf)

IF (lhook) CALL dr_hook('COMPACT',0,zhook_handle)

!SOLUTION 1 CA MARCHE MAIS CA COMPRESSE PAS TELLEMENT
!DO IPROMA=1,KNELEM
!   ZTMPBUF=PVALCO_COMPACT(IPROMA)
!   KPACK(IPROMA)=ITMPBUF
!END DO

!SOLUTION 2
kpack=0
valmin=minval(pvalco_compact(1:knelem))
ztmpbuf=valmin
i4b0=itmpbuf
valmax=maxval(pvalco_compact(1:knelem))
ztmpbuf=valmax
icmpbuf=itmpbuf
kpack(1)=ishft(icmpbuf,32)
kpack(1)=kpack(1)+i4b0
ilength=1
zcoef=(2**kbitradical-1)
iptrbit=0
iptrtab=2
IF (valmax-valmin<=0.0) THEN
!WRITE(6,*) 'DEBUG COMPACT VALMAX-VALMIN inf zero'
!WRITE(6,*) 'DEBUG COMPACT',VALMAX,VALMIN
!WRITE(6,*) 'DEBUG COMPACT',PVALCO_COMPACT(1:10)
!CALL ABORT('DIVISION PAR ZERO')
knelem=1
ELSE

DO iproma=1,knelem
icmpbuf=(pvalco_compact(iproma)-valmin)/(valmax-valmin)*zcoef
!PRINT*, ICMPBUF
!WRITE(*,"32I1") (IBITS(ICMPBUF,II,1),II=0,63)

IF (iptrbit+kbitradical<64) THEN
kpack(iptrtab)=kpack(iptrtab)+ishft(ibits(icmpbuf,0,kbitradical),iptrbit)
iptrbit=iptrbit+kbitradical
ELSE
iendbit=64-iptrbit
kpack(iptrtab)=kpack(iptrtab)+ishft(ibits(icmpbuf,0,iendbit),iptrbit)
iptrtab=iptrtab+1
iptrbit=0
kpack(iptrtab)=ibits(icmpbuf,iendbit,kbitradical-iendbit)
iptrbit=kbitradical-iendbit
END IF
END DO
!WRITE(*,"32I1") (IBITS(KPACK(2),II,1),II=0,63)
knelem=iptrtab+1
END IF

!SOLUTION 3 CA MARCHE PAS BIEN
!ALLOCATE(IBUF(KNELEM))
!IBUF=0

!DO IPROMA=1,KNELEM
!   ZTMPBUF=PVALCO_COMPACT(IPROMA)
!   IBUF(IPROMA)=IBITS(ITMPBUF,23-KBITRADICAL,KBITRADICAL)&
!        &+ISHFT(IBITS(ITMPBUF,23,KBITEXPONENT),KBITRADICAL)&
!        &+ISHFT(IBITS(ITMPBUF,30,2),KBITRADICAL+KBITEXPONENT)
!END DO

!WRITE(6,*) 'DEBUG COMPACT',IBUF(1)

!IPTRBIT=0
!IPTRTAB=1
!KPACK=0
!DO IPROMA=1,KNELEM
!!WRITE(6,*) 'DEBUG COMAPCT 4',IPROMA
!!CALL FLUSH(6)
!   IF (IPTRBIT+KBITRADICAL+2+KBITEXPONENT<64) THEN
!      ICMPBUF=IBUF(IPROMA)
!      KPACK(IPTRTAB)=KPACK(IPTRTAB)+ISHFT(IBITS(ICMPBUF,0,KBITRADICAL+2+KBITEXPONENT),(IPTRBIT))
!      IPTRBIT=IPTRBIT+KBITRADICAL+2+KBITEXPONENT
!      
!   ELSE
!      IENDBIT=64-IPTRBIT
!      ICMPBUF=IBUF(IPROMA)
      
!      KPACK(IPTRTAB)=KPACK(IPTRTAB)+ISHFT(IBITS(ICMPBUF,0,IENDBIT),(IPTRBIT))
!      IPTRBIT=0
!      IPTRTAB=IPTRTAB+1
!      KPACK(IPTRTAB)=IBITS(ICMPBUF,IENDBIT,KBITRADICAL+2+KBITEXPONENT-IENDBIT)
!      IPTRBIT=IPTRBIT+KBITRADICAL+2+KBITEXPONENT-IENDBIT
!   END IF
!   KNELEM=IPTRTAB
!END DO

IF (lhook) CALL dr_hook('COMPACT',1,zhook_handle)

END SUBROUTINE compact