uncompact.F90

Go to the documentation of this file.

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

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

IMPLICIT NONE

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

REAL(KIND=JPRM) :: ZTMPBUF
INTEGER(KIND=4) :: ITMPBUF
INTEGER(KIND=8) :: ICMPBUF
INTEGER(KIND=4),ALLOCATABLE :: IBUF(:)
INTEGER(KIND=4) :: IPROMA,IPTRTAB,IPTRBIT,IENDBIT

REAL(KIND=JPRB) :: ZHOOK_HANDLE

equivalence(ztmpbuf,itmpbuf)

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

!SOLUTION 1
!IPTRBIT=0
!IPTRTAB=1
!DO IPROMA=1,KNELEM
!  ITMPBUF=KPACK(IPROMA)
!   PVALCO_COMPACT(IPROMA)=ZTMPBUF
!END DO

!SOLUTION 2
itmpbuf=ibits(kpack(1),0,32)
valmin=ztmpbuf
itmpbuf=ibits(kpack(1),32,32)
valmax=ztmpbuf
!PRINT*,VALMIN," ",VALMAX
IF (valmax-valmin<=0.0) THEN
   pvalco_compact(1:knelem)=valmin
ELSE
   iptrtab=2
   iptrbit=0
   zcoef=(2**kbitradical-1)
   DO iproma=2,knelem+1
      IF (iptrbit+kbitradical<64) THEN
         icmpbuf=ibits(kpack(iptrtab),iptrbit,kbitradical)
         iptrbit=iptrbit+kbitradical
      ELSE
         iendbit=64-iptrbit
         icmpbuf=ibits(kpack(iptrtab),iptrbit,iendbit)+ishft(ibits(kpack(iptrtab+1),0,kbitradical-iendbit),iendbit)
         iptrtab=iptrtab+1
         iptrbit=kbitradical-iendbit
         
      END IF
      
      pvalco_compact(iproma-1)=icmpbuf*(valmax-valmin)/zcoef+valmin
      !PRINT*,PVALCO_COMPACT(IPROMA-1)
   END DO
END IF


!SOLUTION 3 CA MARCHE PAS BIEN
!ALLOCATE(IBUF(KNELEM))
!DO IPROMA=1,KNELEM
!          IF (IPTRBIT+KBITRADICAL+2+KBITEXPONENT<64) THEN
!             IBUF(IPROMA)=IBITS(KPACK(IPTRTAB),IPTRBIT,KBITRADICAL+2+KBITEXPONENT)
!             IPTRBIT=IPTRBIT+KBITRADICAL+2+KBITEXPONENT
             
!          ELSE
!             IENDBIT=64-IPTRBIT
!             IBUF(IPROMA)=IBITS(KPACK(IPTRTAB),IPTRBIT,IENDBIT)
!             IPTRTAB=IPTRTAB+1
!             IBUF(IPROMA)=IBUF(IPROMA)+ISHFT(IBITS(KPACK(IPTRTAB),0,KBITRADICAL+2+KBITEXPONENT-IENDBIT),IENDBIT)
!             IPTRBIT=KBITRADICAL+2+KBITEXPONENT-IENDBIT
!          END IF
!       END DO
!WRITE(6,*) 'DEBUG UNCOMPACT',IBUF(1)
!DO IPROMA=1,KNELEM
!ITMPBUF=0
!ITMPBUF=ISHFT(IBITS(IBUF(IPROMA),0,KBITRADICAL),23-KBITRADICAL)+ISHFT(IBITS(IBUF(IPROMA),KBITRADICAL,KBITEXPONENT),23)&
!+ISHFT(2**(7-KBITEXPONENT)-1+IBITS(IBUF(IPROMA),KBITRADICAL+KBITEXPONENT,1),23+KBITEXPONENT)&
!&+ISHFT(IBITS(IBUF(IPROMA),KBITRADICAL+KBITEXPONENT+1,1),31)
!PVALCO_COMPACT(IPROMA)=ZTMPBUF
!END DO

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

END SUBROUTINE uncompact