sbytes_mf.F

Go to the documentation of this file.

      SUBROUTINE sbytes_mf(KD,KS,KSKIP1,KBSIZ,KSKIP2,KBYTES)
      USE parkind1, ONLY : jprb
      USE yomhook , ONLY : lhook, dr_hook
      USE lfi_precision
!
! REVERSES THE ACTION OF GBYTES, TAKING FIELDS FROM KS AND
! INSERTING THEM INTO A BIT STRING IN KD. SEE GBYTES.
! AUTHOR D. ROBERTSON  AUG,1981
!*
!*    Modified by Mats HAMRUD, ECMWF, 1988, to have a constant number
!*    number af arguments , as within the GRIB package calls,
!*    and to make some cleanings.
!*
!*    Modifications by Jean CLOCHARD, French DMN, January 1990,
!*    essentially to get a vectorising code on CRAY (no recurrences),
!*    and to make some cleanings.
!
      IMPLICIT NONE
!
      INTEGER (KIND=JPLIKM) :: KSKIP1
      INTEGER (KIND=JPLIKM) :: KBSIZ
      INTEGER (KIND=JPLIKM) :: KSKIP2
      INTEGER (KIND=JPLIKM) :: KBYTES
!
      INTEGER (KIND=JPLIKB) :: KD(*)
      INTEGER (KIND=JPLIKB) :: KS(kbytes)
!
      INTEGER (KIND=JPLIKM) :: INBPW, ISTEP, JBYTE, IAUXIL
      INTEGER (KIND=JPLIKM) :: ID, ISKIP, ISH1, ISH2, ISH3
!
!     LOGICAL LLSTOP
!
      REAL(KIND=JPRB) :: ZHOOK_HANDLE
      IF (lhook) CALL dr_hook('SBYTES_MF',0,zhook_handle)
      inbpw=64
      istep = kskip2+kbsiz
!
      DO 75 jbyte = 1 , kbytes
!
! WITH THE STARTING WORD AND BIT POSITION KNOWN, THE
! DESIRED INSERTION CAN BE DONE BY
!**      CALL SBYTE(KD(ID),KS(JBYTE),ISKIP,KBSIZ)
! BUT THE CODE IS SHORT ENOUGH TO GO IN-LINE.
!
      iauxil=kskip1+(jbyte-1)*istep
      id=1+iauxil/inbpw
      iskip=iauxil-(id-1)*inbpw
      ish1=iskip+kbsiz-inbpw
!     LLSTOP=ISH1.GT.0
!
      IF(ish1.LE.0) THEN
!*
! BYTE GOES INTO 1 WORD OF KD.
!
!        PRINT '(''a'',2(TR1,B64))', KD(ID),KS(JBYTE)
         kd(id) = ishftc(ior(ishft(ishftc(kd(id),iskip,bit_size(kd(id)))&
     &            ,kbsiz),ibits(ks(jbyte),0,kbsiz)),-ish1,             &
     &            bit_size(ior(ishft( ishftc(kd(id),iskip,              &
     &            bit_size(kd(id))),kbsiz),ibits(ks(jbyte),0,kbsiz))))
!        PRINT '(''a'',TR1,B64))', KD(ID)
      ELSE
!*
! BYTE GOES INTO 2 WORDS OF KD.
!
!        PRINT *, JBYTE, INBPW, KSKIP1, KBSIZ, ISTEP, ID, ISKIP, ISH1
!        PRINT '(''b1 KD(ID  ) ='',B64.64))', KD(ID)
!        PRINT '(''b1 KD(ID+1) ='',B64.64))', KD(ID+1)
!        PRINT '(''b1 KS(JBYTE)='',B64.64))', KS(JBYTE)
         kd(id)=ior(ishftc(ishft(kd(id),iskip-inbpw), inbpw-iskip,      &
     &          bit_size(ishft(kd(id),iskip-inbpw))),                   &
     &          ishft(ibits(ks(jbyte),0,kbsiz),-ish1))
         kd(id+1)=ishftc(ior(ishft(kd(id+1),ish1),                      &
     &            ibits(ks(jbyte),0,ish1)),-ish1,                       &
     &            bit_size(ior(ishft(kd(id+1),ish1),                    &
     &            ibits(ks(jbyte),0,ish1))))
!        PRINT '(''b2 KD(ID  ) ='',B64.64))', KD(ID)
!        PRINT '(''b2 KD(ID+1) ='',B64.64))', KD(ID+1)
!        IF (JBYTE.GT.10) STOP 'provisoire b'
      ENDIF
!
   75 CONTINUE
!
!     IF (LLSTOP) STOP 'provisoire'
!
      IF (lhook) CALL dr_hook('SBYTES_MF',1,zhook_handle)
      ENDSUBROUTINE sbytes_mf