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

Go to the documentation of this file.
00001       SUBROUTINE SBYTES_MF(KD,KS,KSKIP1,KBSIZ,KSKIP2,KBYTES)
00002       USE PARKIND1, ONLY : JPRB
00003       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00004 C
00005 C REVERSES THE ACTION OF GBYTES, TAKING FIELDS FROM KS AND
00006 C INSERTING THEM INTO A BIT STRING IN KD. SEE GBYTES.
00007 C AUTHOR D. ROBERTSON  AUG,1981
00008 C*
00009 C*    Modified by Mats HAMRUD, ECMWF, 1988, to have a constant number
00010 C*    number af arguments , as within the GRIB package calls,
00011 C*    and to make some cleanings.
00012 C*
00013 C*    Modifications by Jean CLOCHARD, French DMN, January 1990,
00014 C*    essentially to get a vectorising code on CRAY (no recurrences),
00015 C*    and to make some cleanings.
00016 C
00017 #include "precision.h"
00018 C
00019       INTEGER KSKIP1, KBSIZ, KSKIP2, KBYTES
00020 C
00021       INTEGER (KIND=JPDBLE) KD(*), KS(KBYTES)
00022 C
00023       INTEGER INBPW, ISTEP, JBYTE, IAUXIL, ID, ISKIP, ISH1, ISH2, ISH3
00024 C
00025 C     LOGICAL LLSTOP
00026 C
00027       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00028       IF (LHOOK) CALL DR_HOOK('SBYTES_MF',0,ZHOOK_HANDLE)
00029       INBPW=64
00030       ISTEP = KSKIP2+KBSIZ
00031 C
00032       DO 75 JBYTE = 1 , KBYTES
00033 C
00034 C WITH THE STARTING WORD AND BIT POSITION KNOWN, THE
00035 C DESIRED INSERTION CAN BE DONE BY
00036 C**      CALL SBYTE(KD(ID),KS(JBYTE),ISKIP,KBSIZ)
00037 C BUT THE CODE IS SHORT ENOUGH TO GO IN-LINE.
00038 C
00039       IAUXIL=KSKIP1+(JBYTE-1)*ISTEP
00040       ID=1+IAUXIL/INBPW
00041       ISKIP=IAUXIL-(ID-1)*INBPW
00042       ISH1=ISKIP+KBSIZ-INBPW
00043 C     LLSTOP=ISH1.GT.0
00044 C
00045       IF(ISH1.LE.0) THEN
00046 C*
00047 C BYTE GOES INTO 1 WORD OF KD.
00048 C
00049 C        PRINT '(''a'',2(TR1,B64))', KD(ID),KS(JBYTE)
00050          KD(ID) = ISHFTC(IOR(ISHFT(ISHFTC(KD(ID),ISKIP,BIT_SIZE(KD(ID)))
00051      s            ,KBSIZ),IBITS (KS(JBYTE),0,KBSIZ)),-ISH1,
00052      s            BIT_SIZE(IOR(ISHFT( ISHFTC(KD(ID),ISKIP,
00053      s            BIT_SIZE(KD(ID))),KBSIZ),IBITS (KS(JBYTE),0,KBSIZ))))  
00054 C        PRINT '(''a'',TR1,B64))', KD(ID)
00055       ELSE
00056 C*
00057 C BYTE GOES INTO 2 WORDS OF KD.
00058 C
00059 C        PRINT *, JBYTE, INBPW, KSKIP1, KBSIZ, ISTEP, ID, ISKIP, ISH1
00060 C        PRINT '(''b1 KD(ID  ) ='',B64.64))', KD(ID)
00061 C        PRINT '(''b1 KD(ID+1) ='',B64.64))', KD(ID+1)
00062 C        PRINT '(''b1 KS(JBYTE)='',B64.64))', KS(JBYTE)
00063          KD(ID)=IOR(ISHFTC(ISHFT(KD(ID),ISKIP-INBPW), INBPW-ISKIP,
00064      s          BIT_SIZE(ISHFT(KD(ID),ISKIP-INBPW))),
00065      s          ISHFT(IBITS(KS(JBYTE),0,KBSIZ),-ISH1))
00066          KD(ID+1)=ISHFTC(IOR(ISHFT(KD(ID+1),ISH1),
00067      s            IBITS(KS(JBYTE),0,ISH1)),-ISH1,
00068      s            BIT_SIZE(IOR(ISHFT(KD(ID+1),ISH1),
00069      s            IBITS(KS(JBYTE),0,ISH1))))
00070 C        PRINT '(''b2 KD(ID  ) ='',B64.64))', KD(ID)
00071 C        PRINT '(''b2 KD(ID+1) ='',B64.64))', KD(ID+1)
00072 C        IF (JBYTE.GT.10) STOP 'provisoire b'
00073       ENDIF
00074 C
00075    75 CONTINUE
00076 C
00077 C     IF (LLSTOP) STOP 'provisoire'
00078 C
00079       IF (LHOOK) CALL DR_HOOK('SBYTES_MF',1,ZHOOK_HANDLE)
00080       END