SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/LFI_COMPRESS/src/decompress.f90 Source File

Go to the documentation of this file.
00001 !-----------------------------------------------------------------
00002 !--------------- special set of characters for RCS information
00003 !-----------------------------------------------------------------
00004 ! $Source: /home/cvsroot/mesonh/libtools/lib/COMPRESS/src/decompress.f90,v $ $Revision: 1.1 $ $Date: 2005/04/12 15:06:20 $
00005 !-----------------------------------------------------------------
00006 SUBROUTINE GET_COMPHEADER(KTAB,SIZEKTAB,KNBELT,KTYPECOD)
00007 
00008 INTEGER, INTENT(IN) :: SIZEKTAB
00009 INTEGER(KIND=8), DIMENSION(SIZEKTAB), INTENT(IN) :: KTAB
00010 INTEGER, INTENT(OUT) :: KNBELT    ! size of decompressed array
00011 INTEGER, INTENT(OUT) :: KTYPECOD  ! code for compression type
00012 
00013 CHARACTER(LEN=8) :: STRKEY
00014 
00015 INTEGER :: INTCHAR
00016 INTEGER :: JI
00017 
00018 CALL SET_EXTRACTIDX(0,0)
00019 ! extract string header 
00020 DO JI=1,8
00021   CALL EXTRACT_BBUFF(KTAB,8,INTCHAR)
00022   STRKEY(JI:JI) = CHAR(INTCHAR)
00023 END DO
00024 
00025 ! Treat array if it is compressed
00026 IF (STRKEY == 'COMPRESS') THEN
00027   CALL EXTRACT_BBUFF(KTAB,32,KTYPECOD)
00028   CALL EXTRACT_BBUFF(KTAB,32,KNBELT)
00029 ELSE
00030   KNBELT    =-1
00031   KTYPECOD = 0
00032 END IF
00033 
00034 END SUBROUTINE GET_COMPHEADER
00035 
00036 SUBROUTINE DECOMPRESS_FIELD(XTAB,NBELT,COMPTAB,NBCOMPELT,CODINGTYPE)
00037 USE MODD_COMPPAR
00038 USE MODE_SEARCHGRP
00039 
00040 IMPLICIT NONE 
00041 INTEGER,                                INTENT(IN)  :: NBELT 
00042 INTEGER,                                INTENT(IN)  :: NBCOMPELT 
00043 REAL   (KIND=8),DIMENSION(NBELT),TARGET,INTENT(OUT) :: XTAB
00044 INTEGER(KIND=8),DIMENSION(NBCOMPELT),   INTENT(IN)  :: COMPTAB
00045 INTEGER,                                INTENT(IN)  :: CODINGTYPE
00046 
00047 INTEGER,DIMENSION(:), ALLOCATABLE  :: ITAB
00048 LOGICAL,DIMENSION(:), ALLOCATABLE  :: GMASK
00049 
00050 REAL :: XREF, XCOEFF
00051 INTEGER :: INBLEV
00052 INTEGER :: ILEVNBELT
00053 INTEGER :: JI
00054 INTEGER :: IND1, IND2
00055 INTEGER :: IDIMX,IDIMY
00056 INTEGER :: IEXTCOD
00057 REAL(KIND=8),DIMENSION(:),POINTER  :: XPTRTAB
00058 REAL :: XMIN,XMAX
00059 
00060 SELECT CASE (CODINGTYPE)
00061 CASE (JPCSTENCOD)
00062   CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
00063   XTAB(:) = XREF
00064 
00065 CASE (JPSOPENCOD)
00066   CALL EXTRACT_BBUFF(COMPTAB,32,IDIMX)
00067   CALL EXTRACT_BBUFF(COMPTAB,32,IDIMY)
00068   ILEVNBELT = IDIMX * IDIMY
00069   INBLEV = NBELT/(ILEVNBELT)
00070   ALLOCATE(ITAB(ILEVNBELT))
00071   DO JI=1,INBLEV
00072     IND1=(JI-1)*ILEVNBELT+1
00073     IND2=JI*ILEVNBELT
00074     XPTRTAB=>XTAB(IND1:IND2)
00075     IF (LPDEBUG) PRINT *,'######   Decompress(SOPENCOD) LEVEL ',JI,'######'
00076     CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
00077     CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
00078     CALL EXTRACTINTARRAY(ITAB)
00079     CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF)
00080   END DO
00081   
00082 CASE (JPEXTENCOD)
00083   CALL EXTRACT_BBUFF(COMPTAB,32,IDIMX)
00084   CALL EXTRACT_BBUFF(COMPTAB,32,IDIMY)
00085   ILEVNBELT = IDIMX * IDIMY
00086   INBLEV = NBELT/(ILEVNBELT)
00087   ALLOCATE(ITAB(ILEVNBELT))
00088   ALLOCATE(GMASK(ILEVNBELT))
00089   DO JI=1,INBLEV
00090 
00091     IF (LPDEBUG) PRINT *,'###### Decompress(EXTENCOD) LEVEL ',JI,'######'
00092     IND1=(JI-1)*ILEVNBELT+1
00093     IND2=JI*ILEVNBELT
00094     XPTRTAB=>XTAB(IND1:IND2)
00095     !
00096     CALL EXTRACT_BBUFF(COMPTAB,3,IEXTCOD)
00097     IF (IEXTCOD == JPOTHER) THEN
00098       CALL EXTRACT_BBUFF(COMPTAB,3,IEXTCOD)
00099       IEXTCOD = IEXTCOD + 8
00100     END IF
00101     IF (LPDEBUG) PRINT *, "IEXTCOD = ",IEXTCOD
00102     SELECT CASE(IEXTCOD)
00103     CASE(JPLOG)
00104       ! Conversion to log values of original data 0<=x<1
00105       CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
00106       CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
00107       CALL EXTRACTINTARRAY(ITAB)
00108       GMASK(:) = .TRUE.
00109       WHERE (ITAB == 0)
00110         GMASK = .FALSE.
00111         XPTRTAB = 0.0
00112       END WHERE
00113       CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF,GMASK,1)
00114       WHERE(GMASK)
00115         XPTRTAB = EXP(XPTRTAB)
00116       END WHERE
00117       
00118     CASE(JPCONST)
00119       ! constant value array
00120       CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
00121       XPTRTAB(:) = XREF
00122       IF (LPDEBUG) PRINT *,"  CONST value=",XREF
00123 
00124     CASE(JP2VAL)
00125       ! 2 different values in array
00126       CALL EXTRACT_BBUFF(COMPTAB,32,XMIN)
00127       CALL EXTRACT_BBUFF(COMPTAB,32,XMAX)
00128       CALL EXTRACTINTARRAY(ITAB)
00129       WHERE (ITAB == 0)
00130         XPTRTAB = XMIN
00131       ELSEWHERE
00132         XPTRTAB = XMAX
00133       END WHERE
00134       IF (LPDEBUG) PRINT *,"  2 values:",XMIN,XMAX
00135       
00136     CASE(JP3VAL)
00137       ! 3 different values in array
00138       CALL EXTRACT_BBUFF(COMPTAB,32,XMIN)
00139       CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
00140       CALL EXTRACT_BBUFF(COMPTAB,32,XMAX)
00141       CALL EXTRACTINTARRAY(ITAB)
00142       WHERE (ITAB == 0)
00143         XPTRTAB = XMIN
00144       ELSEWHERE
00145         XPTRTAB = XREF
00146       END WHERE
00147       WHERE (ITAB == 2) XPTRTAB = XMAX
00148       IF (LPDEBUG) PRINT *,"  3 values:",XMIN,XREF,XMAX
00149 
00150     CASE(JPNORM)
00151       ! same as JPSOPENCOD
00152       CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
00153       CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
00154       CALL EXTRACTINTARRAY(ITAB)
00155       CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF)
00156       IF (LPDEBUG) PRINT *,"  normal, XREF/XCOEFF = ",XREF,XCOEFF 
00157 
00158     CASE(JPMINEXCL)
00159       ! Min value is isolated
00160       CALL EXTRACT_BBUFF(COMPTAB,32,XMIN)
00161       CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
00162       CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
00163       CALL EXTRACTINTARRAY(ITAB)
00164       GMASK(:) = .TRUE.
00165       WHERE (ITAB == 0)
00166         GMASK = .FALSE.
00167         XPTRTAB = XMIN
00168       END WHERE
00169       CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF,GMASK,1)
00170       IF (LPDEBUG) PRINT *,"  Min exclus, MIN/XREF/XCOEFF = ",XMIN,XREF,XCOEFF
00171 
00172     CASE(JPMAXEXCL)
00173       ! Max value is isolated
00174       CALL EXTRACT_BBUFF(COMPTAB,32,XMAX)
00175       CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
00176       CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
00177       CALL EXTRACTINTARRAY(ITAB)
00178       GMASK(:) = .TRUE.
00179       WHERE (ITAB == 65535)
00180         GMASK = .FALSE.
00181         XPTRTAB = XMAX
00182       END WHERE
00183       CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF,GMASK,0)   
00184       IF (LPDEBUG) PRINT *,"  Max exclus, MAX/XREF/XCOEFF = ",XMAX,XREF,XCOEFF
00185 
00186     CASE(JPMINMAXEXCL)
00187       ! Min&Max value are isolated
00188       CALL EXTRACT_BBUFF(COMPTAB,32,XMIN)        
00189       CALL EXTRACT_BBUFF(COMPTAB,32,XMAX)
00190       CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
00191       CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
00192       CALL EXTRACTINTARRAY(ITAB)
00193       GMASK(:) = .TRUE.
00194       WHERE (ITAB == 0)
00195         GMASK = .FALSE.
00196         XPTRTAB = XMIN
00197       END WHERE
00198       WHERE (ITAB == 65535)
00199         GMASK = .FALSE.
00200         XPTRTAB = XMAX
00201       END WHERE
00202       CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF,GMASK,1)
00203       IF (LPDEBUG) PRINT *,"  Min et Max exclus, MIN/MAX/XREF/XCOEFF = ",&
00204            &XMIN,XMAX,XREF,XCOEFF
00205     END SELECT
00206   END DO
00207   
00208 CASE DEFAULT
00209   PRINT *,'Error in CODINGTYPE : program aborted'
00210   STOP
00211 END SELECT
00212 
00213 CONTAINS 
00214 
00215 SUBROUTINE DECOMP_FOP(PTAB,KTAB,PREF,PCOEFF,OMASK,KINDCOR)
00216 REAL(KIND=8), DIMENSION(:), INTENT(INOUT) :: PTAB 
00217 ! Attention: avec le compilateur PGF, utiliser INTENT(OUT) provoque une recopie
00218 ! complete du tableau dans PTAB (avec ecrasement possible des valeurs 
00219 ! presentes a l'appel de la procedure). Le phenomene est genant lorsque
00220 ! DECOMP_FOP ne calcule que sur une portion de PTAB (valeurs min et/ou max 
00221 ! sont presentes). En declarant PTAB en INOUT, les valeurs en entree de la routine
00222 ! sont conservees si elles n'ont pas ete modifiees.
00223 
00224 INTEGER,      DIMENSION(:), INTENT(IN) :: KTAB 
00225 REAL, INTENT(IN) :: PREF
00226 REAL, INTENT(IN) :: PCOEFF
00227 LOGICAL, DIMENSION(:),INTENT(IN),OPTIONAL :: OMASK
00228 INTEGER,INTENT(IN),OPTIONAL  :: KINDCOR ! 1 if Min value is isolated, 0 otherwise
00229 
00230 INTEGER :: INDCOR
00231 
00232 IF (.NOT. PRESENT(KINDCOR)) THEN
00233   INDCOR = 0
00234 ELSE
00235   INDCOR = KINDCOR
00236 END IF
00237   
00238 IF (PRESENT(OMASK)) THEN
00239   WHERE (OMASK)
00240     PTAB(:) = PCOEFF*(KTAB(:)-INDCOR)+PREF
00241   END WHERE
00242 ELSE
00243   IF (PCOEFF == 0.0) THEN
00244     PTAB(:) = PREF
00245   ELSE
00246     PTAB(:) = PCOEFF*KTAB(:)+PREF
00247   END IF
00248 END IF
00249 
00250 END SUBROUTINE DECOMP_FOP
00251 
00252 SUBROUTINE EXTRACTINTARRAY(KTAB)
00253 INTEGER,DIMENSION(:),INTENT(OUT) :: KTAB
00254 !
00255 ! COMPTAB, IDIMX and IDIMY  are defined in the calling routine
00256 !
00257 INTEGER :: NBGRP
00258 INTEGER :: IBE
00259 INTEGER :: CPT
00260 INTEGER :: JJ
00261 INTEGER :: ALONE
00262 INTEGER :: NBITCOD,IMIN
00263 INTEGER :: GELT
00264 INTEGER :: JELT
00265 INTEGER :: IEPS
00266 
00267 CALL EXTRACT_BBUFF(COMPTAB,32,NBGRP)
00268 !      PRINT *,'Nbre de groupes =',NBGRP
00269 CALL EXTRACT_BBUFF(COMPTAB,5,IBE)
00270 !      PRINT *,'Nbre de bits pour coder le nombre d''elements:',IBE
00271 CPT = 1
00272 DO JJ=1,NBGRP
00273   !      PRINT *,'Groupe ',JJ,' : '
00274   CALL EXTRACT_BBUFF(COMPTAB,1,ALONE)
00275   CALL EXTRACT_BBUFF(COMPTAB,16,IMIN)
00276   !      PRINT *,'IREF=',IMIN
00277   
00278   IF (ALONE == 1) THEN
00279     ! 1 seul elt dans le groupe
00280     !        PRINT *,'--> un seul element dans le groupe'
00281     KTAB(CPT)=IMIN
00282     CPT=CPT+1
00283   ELSE
00284     CALL EXTRACT_BBUFF(COMPTAB,4,NBITCOD)
00285     CALL EXTRACT_BBUFF(COMPTAB,IBE,GELT)
00286     !        PRINT *,'--> ',GELT,' elts, codage ecart sur ',nbitcod,'bits'
00287     IF (NBITCOD > 0) THEN
00288       DO JELT=1,GELT
00289         CALL EXTRACT_BBUFF(COMPTAB,NBITCOD,IEPS)
00290         KTAB(CPT) = IMIN+IEPS
00291         CPT=CPT+1
00292       END DO
00293     ELSE
00294       KTAB(CPT:CPT+GELT-1) = IMIN
00295       CPT = CPT+GELT
00296     END IF
00297   END IF
00298 END DO
00299 CALL INVERTCOL(KTAB,IDIMX,IDIMY)        
00300 END SUBROUTINE EXTRACTINTARRAY
00301 
00302 END SUBROUTINE DECOMPRESS_FIELD
00303