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

Go to the documentation of this file.
00001 SUBROUTINE COMPACT(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,ILENGTH
00017 INTEGER(KIND=4),ALLOCATABLE :: IBUF(:)
00018 INTEGER(KIND=4) :: IPROMA,IPTRTAB,IPTRBIT,IENDBIT,I4B0,I4B1
00019 INTEGER(KIND=2) :: I2B0,I2B1,I2B2,I2B3
00020 
00021 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00022 
00023 EQUIVALENCE(ZTMPBUF,ITMPBUF)
00024 
00025 IF (LHOOK) CALL DR_HOOK('COMPACT',0,ZHOOK_HANDLE)
00026 
00027 !SOLUTION 1 CA MARCHE MAIS CA COMPRESSE PAS TELLEMENT
00028 !DO IPROMA=1,KNELEM
00029 !   ZTMPBUF=PVALCO_COMPACT(IPROMA)
00030 !   KPACK(IPROMA)=ITMPBUF
00031 !END DO
00032 
00033 !SOLUTION 2
00034 KPACK=0
00035 VALMIN=MINVAL(PVALCO_COMPACT(1:KNELEM))
00036 ZTMPBUF=VALMIN
00037 I4B0=ITMPBUF
00038 VALMAX=MAXVAL(PVALCO_COMPACT(1:KNELEM))
00039 ZTMPBUF=VALMAX
00040 ICMPBUF=ITMPBUF
00041 KPACK(1)=ISHFT(ICMPBUF,32)
00042 KPACK(1)=KPACK(1)+I4B0
00043 ILENGTH=1
00044 ZCOEF=(2**KBITRADICAL-1)
00045 IPTRBIT=0
00046 IPTRTAB=2
00047 IF (VALMAX-VALMIN<=0.0) THEN
00048 !WRITE(6,*) 'DEBUG COMPACT VALMAX-VALMIN inf zero'
00049 !WRITE(6,*) 'DEBUG COMPACT',VALMAX,VALMIN
00050 !WRITE(6,*) 'DEBUG COMPACT',PVALCO_COMPACT(1:10)
00051 !CALL ABORT('DIVISION PAR ZERO')
00052 KNELEM=1
00053 ELSE
00054 
00055 DO IPROMA=1,KNELEM
00056 ICMPBUF=(PVALCO_COMPACT(IPROMA)-VALMIN)/(VALMAX-VALMIN)*ZCOEF
00057 !PRINT*, ICMPBUF
00058 !WRITE(*,"32I1") (IBITS(ICMPBUF,II,1),II=0,63)
00059 
00060 IF (IPTRBIT+KBITRADICAL<64) THEN
00061 KPACK(IPTRTAB)=KPACK(IPTRTAB)+ISHFT(IBITS(ICMPBUF,0,KBITRADICAL),IPTRBIT)
00062 IPTRBIT=IPTRBIT+KBITRADICAL
00063 ELSE
00064 IENDBIT=64-IPTRBIT
00065 KPACK(IPTRTAB)=KPACK(IPTRTAB)+ISHFT(IBITS(ICMPBUF,0,IENDBIT),IPTRBIT)
00066 IPTRTAB=IPTRTAB+1
00067 IPTRBIT=0
00068 KPACK(IPTRTAB)=IBITS(ICMPBUF,IENDBIT,KBITRADICAL-IENDBIT)
00069 IPTRBIT=KBITRADICAL-IENDBIT
00070 END IF
00071 END DO
00072 !WRITE(*,"32I1") (IBITS(KPACK(2),II,1),II=0,63)
00073 KNELEM=IPTRTAB+1
00074 END IF
00075 
00076 !SOLUTION 3 CA MARCHE PAS BIEN
00077 !ALLOCATE(IBUF(KNELEM))
00078 !IBUF=0
00079 
00080 !DO IPROMA=1,KNELEM
00081 !   ZTMPBUF=PVALCO_COMPACT(IPROMA)
00082 !   IBUF(IPROMA)=IBITS(ITMPBUF,23-KBITRADICAL,KBITRADICAL)&
00083 !        &+ISHFT(IBITS(ITMPBUF,23,KBITEXPONENT),KBITRADICAL)&
00084 !        &+ISHFT(IBITS(ITMPBUF,30,2),KBITRADICAL+KBITEXPONENT)
00085 !END DO
00086 
00087 !WRITE(6,*) 'DEBUG COMPACT',IBUF(1)
00088 
00089 !IPTRBIT=0
00090 !IPTRTAB=1
00091 !KPACK=0
00092 !DO IPROMA=1,KNELEM
00093 !!WRITE(6,*) 'DEBUG COMAPCT 4',IPROMA
00094 !!CALL FLUSH(6)
00095 !   IF (IPTRBIT+KBITRADICAL+2+KBITEXPONENT<64) THEN
00096 !      ICMPBUF=IBUF(IPROMA)
00097 !      KPACK(IPTRTAB)=KPACK(IPTRTAB)+ISHFT(IBITS(ICMPBUF,0,KBITRADICAL+2+KBITEXPONENT),(IPTRBIT))
00098 !      IPTRBIT=IPTRBIT+KBITRADICAL+2+KBITEXPONENT
00099 !      
00100 !   ELSE
00101 !      IENDBIT=64-IPTRBIT
00102 !      ICMPBUF=IBUF(IPROMA)
00103       
00104 !      KPACK(IPTRTAB)=KPACK(IPTRTAB)+ISHFT(IBITS(ICMPBUF,0,IENDBIT),(IPTRBIT))
00105 !      IPTRBIT=0
00106 !      IPTRTAB=IPTRTAB+1
00107 !      KPACK(IPTRTAB)=IBITS(ICMPBUF,IENDBIT,KBITRADICAL+2+KBITEXPONENT-IENDBIT)
00108 !      IPTRBIT=IPTRBIT+KBITRADICAL+2+KBITEXPONENT-IENDBIT
00109 !   END IF
00110 !   KNELEM=IPTRTAB
00111 !END DO
00112 
00113 IF (LHOOK) CALL DR_HOOK('COMPACT',1,ZHOOK_HANDLE)
00114 
00115 END SUBROUTINE COMPACT