SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/FA/uncompact.F90 Source File

Go to the documentation of this file.
00001 SUBROUTINE UNCOMPACT(PVALCO_COMPACT,KNELEM,KBITEXPONENT,KBITRADICAL,KPACK)
00002 
00003 USE PARKIND1 , ONLY : JPRB
00004 USE YOMHOOK  , ONLY : LHOOK, DR_HOOK
00005 
00006 IMPLICIT NONE
00007 
00008 REAL(KIND=8) :: PVALCO_COMPACT(1:KNELEM)
00009 REAL(KIND=8) :: ZCOEF,VALMIN,VALMAX
00010 INTEGER(KIND=4) :: KNELEM
00011 INTEGER(KIND=4) :: KBITEXPONENT,KBITRADICAL
00012 INTEGER(KIND=8) :: KPACK(1:KNELEM)
00013 
00014 REAL(KIND=4) :: ZTMPBUF
00015 INTEGER(KIND=4) :: ITMPBUF
00016 INTEGER(KIND=8) :: ICMPBUF
00017 INTEGER(KIND=4),ALLOCATABLE :: IBUF(:)
00018 INTEGER(KIND=4) :: IPROMA,IPTRTAB,IPTRBIT,IENDBIT
00019 
00020 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00021 
00022 EQUIVALENCE(ZTMPBUF,ITMPBUF)
00023 
00024 IF (LHOOK) CALL DR_HOOK('UNCOMPACT',0,ZHOOK_HANDLE)
00025 
00026 !SOLUTION 1
00027 !IPTRBIT=0
00028 !IPTRTAB=1
00029 !DO IPROMA=1,KNELEM
00030 !  ITMPBUF=KPACK(IPROMA)
00031 !   PVALCO_COMPACT(IPROMA)=ZTMPBUF
00032 !END DO
00033 
00034 !SOLUTION 2
00035 ITMPBUF=IBITS(KPACK(1),0,32)
00036 VALMIN=ZTMPBUF
00037 ITMPBUF=IBITS(KPACK(1),32,32)
00038 VALMAX=ZTMPBUF
00039 !PRINT*,VALMIN," ",VALMAX
00040 IF (VALMAX-VALMIN<=0.0) THEN
00041    PVALCO_COMPACT(1:KNELEM)=VALMIN
00042 ELSE
00043    IPTRTAB=2
00044    IPTRBIT=0
00045    ZCOEF=(2**KBITRADICAL-1)
00046    DO IPROMA=2,KNELEM+1
00047       IF (IPTRBIT+KBITRADICAL<64) THEN
00048          ICMPBUF=IBITS(KPACK(IPTRTAB),IPTRBIT,KBITRADICAL)
00049          IPTRBIT=IPTRBIT+KBITRADICAL
00050       ELSE
00051          IENDBIT=64-IPTRBIT
00052          ICMPBUF=IBITS(KPACK(IPTRTAB),IPTRBIT,IENDBIT)+ISHFT(IBITS(KPACK(IPTRTAB+1),0,KBITRADICAL-IENDBIT),IENDBIT)
00053          IPTRTAB=IPTRTAB+1
00054          IPTRBIT=KBITRADICAL-IENDBIT
00055          
00056       END IF
00057       
00058       PVALCO_COMPACT(IPROMA-1)=ICMPBUF*(VALMAX-VALMIN)/ZCOEF+VALMIN
00059       !PRINT*,PVALCO_COMPACT(IPROMA-1)
00060    END DO
00061 END IF
00062 
00063 
00064 !SOLUTION 3 CA MARCHE PAS BIEN
00065 !ALLOCATE(IBUF(KNELEM))
00066 !DO IPROMA=1,KNELEM
00067 !          IF (IPTRBIT+KBITRADICAL+2+KBITEXPONENT<64) THEN
00068 !             IBUF(IPROMA)=IBITS(KPACK(IPTRTAB),IPTRBIT,KBITRADICAL+2+KBITEXPONENT)
00069 !             IPTRBIT=IPTRBIT+KBITRADICAL+2+KBITEXPONENT
00070              
00071 !          ELSE
00072 !             IENDBIT=64-IPTRBIT
00073 !             IBUF(IPROMA)=IBITS(KPACK(IPTRTAB),IPTRBIT,IENDBIT)
00074 !             IPTRTAB=IPTRTAB+1
00075 !             IBUF(IPROMA)=IBUF(IPROMA)+ISHFT(IBITS(KPACK(IPTRTAB),0,KBITRADICAL+2+KBITEXPONENT-IENDBIT),IENDBIT)
00076 !             IPTRBIT=KBITRADICAL+2+KBITEXPONENT-IENDBIT
00077 !          END IF
00078 !       END DO
00079 !WRITE(6,*) 'DEBUG UNCOMPACT',IBUF(1)
00080 !DO IPROMA=1,KNELEM
00081 !ITMPBUF=0
00082 !ITMPBUF=ISHFT(IBITS(IBUF(IPROMA),0,KBITRADICAL),23-KBITRADICAL)+ISHFT(IBITS(IBUF(IPROMA),KBITRADICAL,KBITEXPONENT),23)&
00083 !+ISHFT(2**(7-KBITEXPONENT)-1+IBITS(IBUF(IPROMA),KBITRADICAL+KBITEXPONENT,1),23+KBITEXPONENT)&
00084 !&+ISHFT(IBITS(IBUF(IPROMA),KBITRADICAL+KBITEXPONENT+1,1),31)
00085 !PVALCO_COMPACT(IPROMA)=ZTMPBUF
00086 !END DO
00087 
00088 IF (LHOOK) CALL DR_HOOK('UNCOMPACT',1,ZHOOK_HANDLE)
00089 
00090 END SUBROUTINE UNCOMPACT