SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/grib_mf/gsbite

Go to the documentation of this file.
00001       SUBROUTINE GSBITE_MF(KS,KD,KSKST,KSIZE,KSKBTW,K,KBPW,KMASK,YADIR)
00002       USE PARKIND1, ONLY : JPRB
00003       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00004 C
00005 C     GSBITE: VECTORISING EXTRACTION/INSERTION OF BITS FROM/TO BITSTREAM
00006 C
00007 C INPUT:
00008 C     KS:     IF YADIR='D', INPUT BIT STREAM, ELSE OUTPUT BIT STREAM
00009 C     KD:     IF YADIR='D', OUTPUT WORDS, ELSE INPUT WORDS
00010 C     KSKST:  NUMBER OF BITS SKIPPED AT BEGINNING OF KS
00011 C     KSIZE:  NUMBER OF BITS TO BE EXTRACTED TO ONE WORD OF KD
00012 C     KSKBTW: NUMBER OF BITS SKIPPED BETWEEN TWO WORDS TO BE EXTRACTED
00013 C     K:      NUMBER OF WORDS TO BE EXTRACTED INTO KD (IF .LE.0, ONLY
00014 C             CALCULATE KBPW AND KMASK
00015 C     KBPW:   NUMBER OF BITS PER WORD IN KS, CALCULATED IF 0
00016 C     KMASK:  MASKS FOR BIT PATTERNS, CALCULATED IF KMASK(2).EQ.0
00017 C     YADIR:  DIRECTION OF CONVERSION: 'D' FOR DECODING, I.E.
00018 C             EXTRACT WORDS KD(1...K)  FROM BITS KS(KSKST+1....)
00019 C             IF NOT 'D', ENCODE, I.E. PACK WORDS KD(1....K) INTO BITS
00020 C             KS(KSKST+1.....KSKST+K*(KSIZE+KSKBTW))
00021 C
00022 C OUTPUT:
00023 C     KS,KD:  SEE ABOVE
00024 C     KSKST:  UPDATED TO NR OF BITS USED, I.E. TO KSKST+K*(KSIZE+KSKBTW)
00025 C     KBPW:   (IF 0 ON INPUT): NUMBER OF BITS IN EACH WORD OF KS
00026 C     KMASK:  (IF (KMASK(2) WAS 0 ON INPUT): BIT PATTERN MASKS
00027 C
00028 C                                                     G.J.CATS 08 DEC 87
00029 C
00030 #include "precision.h"
00031       INTEGER (KIND=JPDBLE) KS(*) , KD(*) , KMASK(*)
00032       INTEGER (KIND=JPDBLE) IS , ISHFT, ISH, IMASK
00033       CHARACTER*1 YADIR
00034 C
00035 C     STATEMENT FUNCTIONS TO MANIPULATE BITS IN WORDS OF 64 BITS
00036 C
00037 C     DATA ONES/7777777777777777B/
00038 C     DATA OOOS/0B/
00039 C
00040 C     1.  SINGLE BIT MANIPULATIONS
00041 C
00042 C     1.1 SET BIT KBIT IN WORD PW
00043 C
00044 CCRAY  IBSET(KW,KBIT)=OR(KW,SHIFT(1B,KBIT))
00045 C
00046 C     2.  WORD MANIPULATIONS, BIT BY BIT
00047 C
00048 C     2.1 ARE WORDS PW1 AND PW2 EQUAL?
00049 C
00050 C      LOGICAL NLEQAL
00051 C     NLEQAL(PW1,PW2)=(PW1.XOR.PW2).EQ.0B
00052 C
00053 C     2.2 BITWISE AND AND OR
00054 C
00055 CCRAY  IAND(K1,K2)=AND(K1,K2)
00056 CCRAY  IOR (K1,K2)= OR(K1,K2)
00057 C
00058 C     2.3 BITWISE NEGATION
00059 C
00060 CCRAY  NOT(K)=COMPL(K)
00061 C
00062 C     2.4 SHIFT (LEFT FOR KSH POSITIVE, RIGHT FOR KSH NEGATIVE)
00063 C
00064 CCRAY  ISHFT(K,KSH)=CVMGP(SHIFTL(K,KSH),SHIFTR(K,-KSH),KSH)
00065 C
00066 C     3.  SPECIAL PURPOSE
00067 C
00068 C     3.1 TAKE 4 LAST BITS OF KW, PUT THEM IN PW AT POS K*4-1
00069 C
00070 C     SETLEV(PW,KW,K)=OR(AND(PW,SHIFT(0B.EQV.17B,K*4-4)),
00071 C    +SHIFT(AND(17B,KW),K*4-4))
00072 C
00073 C     3.2 EXTRACT FIELD [K*4-1:4] FROM PW
00074 C
00075 C     MGTLEV(PW,K)=AND(17B,SHIFT(PW,68-K*4))
00076 C
00077 C     1.  COMPLETE KBPW AND KMASK, RETURN IF 0 WORDS ARE TO BE EXTRACTED
00078 C
00079       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00080       IF (LHOOK) CALL DR_HOOK('GSBITE_MF',0,ZHOOK_HANDLE)
00081       IF(KBPW.EQ.0)THEN
00082          IS=KS(1)
00083          KS(1)=1
00084  1101    CONTINUE
00085          IF(KS(1).NE.0)THEN
00086             KBPW=KBPW+1
00087             KS(1)=ISHFT(KS(1),1)
00088             GOTO 1101
00089          ENDIF
00090          KS(1)=IS
00091       ENDIF
00092       IF(KMASK(2).EQ.0)THEN
00093          KMASK(KBPW+1)=0
00094          DO 1110 J=KBPW,1,-1
00095          KMASK(J)=IBSET(KMASK(J+1),KBPW-J)
00096  1110    CONTINUE
00097       ENDIF
00098       IF(K.LE.0) THEN 
00099         IF (LHOOK) CALL DR_HOOK('GSBITE_MF',1,ZHOOK_HANDLE)
00100         RETURN
00101       ENDIF
00102 C
00103 C     2.  PRESET KD TO 0 IF KD IS OUTPUT I.E. WHEN DECODING
00104 C
00105       IF(YADIR.EQ.'D')THEN
00106          DO 2101 J=1,K
00107          KD(J)=0
00108  2101    CONTINUE
00109       ENDIF
00110 C
00111 C     3.  CALCULATE SEVERAL PARAMETERS FOR LOOPING (FOR EFFICIENCY, THE
00112 C         CODE OF SECTIONS 3.3 AND 3.4 FOR K=1 IS SEPARATED INTO 3.2)
00113 C
00114 C     3.1 NUMBER OF BITS USED PER WORD, INITIAL NR OF SKIPPED BITS
00115 C
00116       ISTEP=KSIZE+KSKBTW
00117       ISKWS=KSKST
00118 C
00119 C     3.2 VECTOR LOOP LENGTH AND STEP SIZE IN KD IF K=1;KS STEP IRRELVNT
00120 C
00121       IF(K.EQ.1)THEN
00122          ILL=1
00123          IBDL=2
00124          ISTD=1
00125       ELSE
00126 C
00127 C     3.3 STEP SIZES IN KS,KD: INVERSE OF LARGEST FACTOR OF ISTEP,KBPW
00128 C
00129          ILCF=KBPW
00130          ISHF=ISTEP
00131  331     CONTINUE
00132          IF(ILCF.EQ.ISHF)GOTO 332
00133          IF(ILCF.EQ.1)GOTO 332
00134          IF(ILCF.GT.ISHF)THEN
00135             ILCF=ILCF-ISHF
00136          ELSE
00137             ISHF=ISHF-ILCF
00138          ENDIF
00139          GOTO 331
00140  332     CONTINUE
00141          ISTD=KBPW/ILCF
00142          ISTS=ISTEP/ILCF
00143 C
00144 C     3.4 VECTOR LOOP LENGTH AND SWITCH-OVER POINT FOR SMALLER LOOP
00145 C
00146          ILL=(K-1)/ISTD+1
00147          IBDL=K-(ILL-1)*ISTD
00148       ENDIF
00149 C
00150 C     3.5 SWAP BYTES ON VAX WHEN DECODING
00151 C
00152 C
00153 C     4.  LOOP OVER FIRST ISTD WORDS OF KD (TRAILS THE VECTOR LOOP)
00154 C
00155       DO 790 JBD=1,ISTD
00156 C
00157 C     4.1 LAST BIT IN KS TO BE TREATED
00158 C
00159       IENBS=ISKWS+KSIZE
00160 C
00161 C     4.2 NR OF WORDS OF KS TO BE SKIPPED, NR OF BITS IN THOSE AND THIS
00162 C
00163       ISKW=ISKWS/KBPW
00164       ISTA=ISKW*KBPW
00165       ISKB=ISKWS-ISTA
00166 C
00167 C     4.3 MASK AND LEFT SHIFT FOR THE REMAINING BITS
00168 C
00169       IMASK=KMASK(ISKB+1)
00170       ISH=KSIZE+ISKB
00171 C
00172 C     4.4 POSITION OF CURRENT WORD OF KS
00173 C
00174       IBS=ISKW+1
00175 C
00176 C     5.  LOOP OVER WORDS OF KS CONTRIBUTING TO ONE WORD OF KD
00177 C
00178  500  CONTINUE
00179 C
00180 C     5.1 UPDATE SHIFT AND LAST BIT IN CURRENT WORD
00181 C
00182       ISH=ISH-KBPW
00183       IEND=ISTA+KBPW
00184 C
00185 C     5.2 IS LAST BIT OF CURRENT WORD OUTSIDE RANGE TO BE EXTRACTED
00186 C
00187       IF(IEND.GT.IENBS)THEN
00188          ISH=IENBS-IEND
00189          IMASK=IAND(IMASK,NOT(KMASK(KBPW+ISH+1)))
00190       ENDIF
00191 C
00192 C     5.3 INITIAL OFFSETS FOR VECTOR ELEMENTS IN VECTOR LOOP
00193 C
00194       IOS=0
00195       IOD=0
00196 C
00197 C     6.  VECTOR LOOP IS OVER REPEATEDLY OCCURRING BITPATTERNS/MASKS
00198 C
00199       IF(YADIR.EQ.'D')THEN
00200 CDIR$ IVDEP
00201          DO 611 JI=1,ILL
00202          KD(JBD+IOD)=IOR(KD(JBD+IOD),ISHFT(IAND(IMASK,KS(IBS+IOS)),ISH))
00203          IOD=IOD+ISTD
00204          IOS=IOS+ISTS
00205  611     CONTINUE
00206       ELSE
00207 CDIR$ IVDEP
00208          DO 612 JI=1,ILL
00209          KS(IBS+IOS)=IOR(
00210      +   IAND(      KS(IBS+IOS),      NOT(IMASK)),
00211      +   IAND(ISHFT(KD(JBD+IOD),-ISH),    IMASK ))
00212          IOD=IOD+ISTD
00213          IOS=IOS+ISTS
00214  612     CONTINUE
00215       ENDIF
00216 C
00217 C     7.  END LOOPS
00218 C
00219 C     7.1 PREPARE FOR END OF LOOP OVER WORDS OF KS WITIHN ONE KD WORD
00220 C
00221       ISTA=ISTA+KBPW
00222 C
00223 C     7.2 NEXT WORD OF KD IF EXTRACTION NOT COMPLETED
00224 C
00225       IF(ISTA.LT.IENBS)THEN
00226          IMASK=KMASK(1)
00227          IBS=IBS+1
00228          GOTO 500
00229       ENDIF
00230 C
00231 C     7.8 PREPARE FOR END OF LOOP OVER FIRST WORDS OF KD
00232 C
00233       IF(JBD.EQ.IBDL)ILL=ILL-1
00234       ISKWS=ISKWS+ISTEP
00235 C
00236 C     7.9 END LOOP OVER FIRST WORDS OF KD
00237 C
00238  790  CONTINUE
00239 C
00240 C     8.  FINISHED: UPDATE KSKST AND RETURN
00241 C
00242       KSKST=KSKST+K*ISTEP
00243 C
00244 C     8.5 SWAP BYTES ON VAX
00245 C
00246       IF (LHOOK) CALL DR_HOOK('GSBITE_MF',1,ZHOOK_HANDLE)
00247       END