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

Go to the documentation of this file.
00001       SUBROUTINE SBYTE_MF(KDEST,KSOURC,KOFSET,KBYTSZ)
00002       USE PARKIND1, ONLY : JPRB
00003       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00004 C*****
00005 C*
00006 C*    FUNCTION: STORE A SINGLE BIT FIELD FROM KSOURC INTO KDEST
00007 C*
00008 C*    INPUT   : KSOURC   = WORD CONTAINING  BIT FIELD RIGHT JUSTIFIED
00009 C*              KDEST(1) = 1ST TARGET WORD
00010 C*              KOFSET   = OFFSET IN BITS FOR START OF THE FIELD
00011 C*              KBYTSZ   = LENGTH OF FIELD IN BITS ; .LE.WORD SIZE .....
00012 C*
00013 C*    OUTPUT  : KSOURC,KOFSET,KBYTSZ UNCHANGED
00014 C*              KDEST(1) AND EVENTUALLY KDEST(2) CONTAIN FIELD
00015 C*
00016 C*    AUTHOR  : M.MIQUEU   08/1981 (REWRITTEN FROM J.MARTELLET'S)
00017 C*
00018 C*****
00019 C
00020 #include "precision.h"
00021 C
00022       INTEGER KOFSET, KBYTSZ
00023       INTEGER (KIND=JPDBLE) KSOURC
00024 C
00025       INTEGER (KIND=JPDBLE) KDEST(*)
00026 C
00027       INTEGER INBPW, ISH1, ISH2, ISH3
00028 C
00029       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00030       IF (LHOOK) CALL DR_HOOK('SBYTE_MF',0,ZHOOK_HANDLE)
00031       INBPW=64
00032       ISH1=KOFSET+KBYTSZ-INBPW
00033 C
00034       IF (ISH1.LE.0) THEN
00035 C
00036 C     BYTE  DOES NOT SPAN WORDS
00037 C
00038         KDEST(1)=ISHFTC(IOR(ISHFT(ISHFTC(KDEST(1),KOFSET,
00039      s           BIT_SIZE(KDEST(1))),KBYTSZ),
00040      s           IBITS (KSOURC,0,KBYTSZ)),-ISH1,
00041      s           BIT_SIZE(IOR(ISHFT(ISHFTC(KDEST(1),KOFSET,
00042      s           BIT_SIZE(KDEST(1))),KBYTSZ),IBITS (KSOURC,0,KBYTSZ))))
00043 C
00044       ELSE
00045 C
00046 C     BYTE SPANS 2 WORDS
00047 C
00048         KDEST(1)=IOR(ISHFTC(ISHFT(KDEST(1),KOFSET-INBPW),INBPW-KOFSET,
00049      s           BIT_SIZE(ISHFT(KDEST(1),KOFSET-INBPW))),
00050      s           ISHFT(IBITS(KSOURC,0,KBYTSZ),-ISH1))
00051 C    
00052         KDEST(2)=ISHFTC(IOR(ISHFT(KDEST(2),ISH1),IBITS(KSOURC,0,ISH1)),
00053      s           -ISH1,BIT_SIZE(IOR(ISHFT(KDEST(2),ISH1),
00054      s           IBITS(KSOURC,0,ISH1))))
00055 C
00056       ENDIF
00057 C
00058       IF (LHOOK) CALL DR_HOOK('SBYTE_MF',1,ZHOOK_HANDLE)
00059       END