gsbite_mf.F

Go to the documentation of this file.

      SUBROUTINE gsbite_mf(KS,KD,KSKST,KSIZE,KSKBTW,K,KBPW,KMASK,YADIR)
      USE parkind1, ONLY : jprb
      USE yomhook , ONLY : lhook, dr_hook
      USE lfi_precision

!
!     GSBITE: VECTORISING EXTRACTION/INSERTION OF BITS FROM/TO BITSTREAM
!
! INPUT:
!     KS:     IF YADIR='D', INPUT BIT STREAM, ELSE OUTPUT BIT STREAM
!     KD:     IF YADIR='D', OUTPUT WORDS, ELSE INPUT WORDS
!     KSKST:  NUMBER OF BITS SKIPPED AT BEGINNING OF KS
!     KSIZE:  NUMBER OF BITS TO BE EXTRACTED TO ONE WORD OF KD
!     KSKBTW: NUMBER OF BITS SKIPPED BETWEEN TWO WORDS TO BE EXTRACTED
!     K:      NUMBER OF WORDS TO BE EXTRACTED INTO KD (IF .LE.0, ONLY
!             CALCULATE KBPW AND KMASK
!     KBPW:   NUMBER OF BITS PER WORD IN KS, CALCULATED IF 0
!     KMASK:  MASKS FOR BIT PATTERNS, CALCULATED IF KMASK(2).EQ.0
!     YADIR:  DIRECTION OF CONVERSION: 'D' FOR DECODING, I.E.
!             EXTRACT WORDS KD(1...K)  FROM BITS KS(KSKST+1....)
!             IF NOT 'D', ENCODE, I.E. PACK WORDS KD(1....K) INTO BITS
!             KS(KSKST+1.....KSKST+K*(KSIZE+KSKBTW))
!
! OUTPUT:
!     KS,KD:  SEE ABOVE
!     KSKST:  UPDATED TO NR OF BITS USED, I.E. TO KSKST+K*(KSIZE+KSKBTW)
!     KBPW:   (IF 0 ON INPUT): NUMBER OF BITS IN EACH WORD OF KS
!     KMASK:  (IF (KMASK(2) WAS 0 ON INPUT): BIT PATTERN MASKS
!
!                                                     G.J.CATS 08 DEC 87
!
      IMPLICIT NONE
      INTEGER (KIND=JPLIKB) :: KS(*)
      INTEGER (KIND=JPLIKB) :: KD(*)
      INTEGER (KIND=JPLIKB) :: KMASK(*)
      INTEGER (KIND=JPLIKB) :: IS , ISHFT, ISH, IMASK
      INTEGER (KIND=JPLIKM) :: KSKST
      INTEGER (KIND=JPLIKM) :: KSIZE
      INTEGER (KIND=JPLIKM) :: KSKBTW
      INTEGER (KIND=JPLIKM) :: K
      INTEGER (KIND=JPLIKM) :: KBPW
      INTEGER (KIND=JPLIKM) :: IBDL
      INTEGER (KIND=JPLIKM) :: IBS,IENBS,IEND,ILCF,ILL,IOD,IOS
      INTEGER (KIND=JPLIKM) :: ISHF,ISKB,ISKW,ISKWS,ISTA,ISTD,ISTEP,ISTS
      INTEGER (KIND=JPLIKM) :: J,JBD,JI
      CHARACTER (LEN=1) :: YADIR
!
!     STATEMENT FUNCTIONS TO MANIPULATE BITS IN WORDS OF 64 BITS
!
!     DATA ONES/7777777777777777B/
!     DATA OOOS/0B/
!
!     1.  SINGLE BIT MANIPULATIONS
!
!     1.1 SET BIT KBIT IN WORD PW
!
!CRAY  IBSET(KW,KBIT)=OR(KW,SHIFT(1B,KBIT))
!
!     2.  WORD MANIPULATIONS, BIT BY BIT
!
!     2.1 ARE WORDS PW1 AND PW2 EQUAL?
!
!      LOGICAL NLEQAL
!     NLEQAL(PW1,PW2)=(PW1.XOR.PW2).EQ.0B
!
!     2.2 BITWISE AND AND OR
!
!CRAY  IAND(K1,K2)=AND(K1,K2)
!CRAY  IOR (K1,K2)= OR(K1,K2)
!
!     2.3 BITWISE NEGATION
!
!CRAY  NOT(K)=COMPL(K)
!
!     2.4 SHIFT (LEFT FOR KSH POSITIVE, RIGHT FOR KSH NEGATIVE)
!
!CRAY  ISHFT(K,KSH)=CVMGP(SHIFTL(K,KSH),SHIFTR(K,-KSH),KSH)
!
!     3.  SPECIAL PURPOSE
!
!     3.1 TAKE 4 LAST BITS OF KW, PUT THEM IN PW AT POS K*4-1
!
!     SETLEV(PW,KW,K)=OR(AND(PW,SHIFT(0B.EQV.17B,K*4-4)),
!    +SHIFT(AND(17B,KW),K*4-4))
!
!     3.2 EXTRACT FIELD [K*4-1:4] FROM PW
!
!     MGTLEV(PW,K)=AND(17B,SHIFT(PW,68-K*4))
!
!     1.  COMPLETE KBPW AND KMASK, RETURN IF 0 WORDS ARE TO BE EXTRACTED
!
      REAL(KIND=JPRB) :: ZHOOK_HANDLE
      IF (lhook) CALL dr_hook('GSBITE_MF',0,zhook_handle)
      IF(kbpw.EQ.0)THEN
         is=ks(1)
         ks(1)=1
 1101    CONTINUE
         IF(ks(1).NE.0)THEN
            kbpw=kbpw+1
            ks(1)=ishft(ks(1),1)
            GOTO 1101
         ENDIF
         ks(1)=is
      ENDIF
      IF(kmask(2).EQ.0)THEN
         kmask(kbpw+1)=0
         DO 1110 j=kbpw,1,-1
         kmask(j)=ibset(kmask(j+1),kbpw-j)
 1110    CONTINUE
      ENDIF
      IF(k.LE.0) THEN
        IF (lhook) CALL dr_hook('GSBITE_MF',1,zhook_handle)
        RETURN
      ENDIF
!
!     2.  PRESET KD TO 0 IF KD IS OUTPUT I.E. WHEN DECODING
!
      IF(yadir.EQ.'D')THEN
         DO 2101 j=1,k
         kd(j)=0
 2101    CONTINUE
      ENDIF
!
!     3.  CALCULATE SEVERAL PARAMETERS FOR LOOPING (FOR EFFICIENCY, THE
!         CODE OF SECTIONS 3.3 AND 3.4 FOR K=1 IS SEPARATED INTO 3.2)
!
!     3.1 NUMBER OF BITS USED PER WORD, INITIAL NR OF SKIPPED BITS
!
      istep=ksize+kskbtw
      iskws=kskst
!
!     3.2 VECTOR LOOP LENGTH AND STEP SIZE IN KD IF K=1;KS STEP IRRELVNT
!
      IF(k.EQ.1)THEN
         ill=1
         ibdl=2
         istd=1
      ELSE
!
!     3.3 STEP SIZES IN KS,KD: INVERSE OF LARGEST FACTOR OF ISTEP,KBPW
!
         ilcf=kbpw
         ishf=istep
 331     CONTINUE
         IF(ilcf.EQ.ishf)GOTO 332
         IF(ilcf.EQ.1)GOTO 332
         IF(ilcf.GT.ishf)THEN
            ilcf=ilcf-ishf
         ELSE
            ishf=ishf-ilcf
         ENDIF
         GOTO 331
 332     CONTINUE
         istd=kbpw/ilcf
         ists=istep/ilcf
!
!     3.4 VECTOR LOOP LENGTH AND SWITCH-OVER POINT FOR SMALLER LOOP
!
         ill=(k-1)/istd+1
         ibdl=k-(ill-1)*istd
      ENDIF
!
!     3.5 SWAP BYTES ON VAX WHEN DECODING
!
!
!     4.  LOOP OVER FIRST ISTD WORDS OF KD (TRAILS THE VECTOR LOOP)
!
      DO 790 jbd=1,istd
!
!     4.1 LAST BIT IN KS TO BE TREATED
!
      ienbs=iskws+ksize
!
!     4.2 NR OF WORDS OF KS TO BE SKIPPED, NR OF BITS IN THOSE AND THIS
!
      iskw=iskws/kbpw
      ista=iskw*kbpw
      iskb=iskws-ista
!
!     4.3 MASK AND LEFT SHIFT FOR THE REMAINING BITS
!
      imask=kmask(iskb+1)
      ish=ksize+iskb
!
!     4.4 POSITION OF CURRENT WORD OF KS
!
      ibs=iskw+1
!
!     5.  LOOP OVER WORDS OF KS CONTRIBUTING TO ONE WORD OF KD
!
 500  CONTINUE
!
!     5.1 UPDATE SHIFT AND LAST BIT IN CURRENT WORD
!
      ish=ish-kbpw
      iend=ista+kbpw
!
!     5.2 IS LAST BIT OF CURRENT WORD OUTSIDE RANGE TO BE EXTRACTED
!
      IF(iend.GT.ienbs)THEN
         ish=ienbs-iend
         imask=iand(imask,not(kmask(kbpw+ish+1)))
      ENDIF
!
!     5.3 INITIAL OFFSETS FOR VECTOR ELEMENTS IN VECTOR LOOP
!
      ios=0
      iod=0
!
!     6.  VECTOR LOOP IS OVER REPEATEDLY OCCURRING BITPATTERNS/MASKS
!
      IF(yadir.EQ.'D')THEN
!DIR$ IVDEP
         DO 611 ji=1,ill
         kd(jbd+iod)=ior(kd(jbd+iod),ishft(iand(imask,ks(ibs+ios)),ish))
         iod=iod+istd
         ios=ios+ists
 611     CONTINUE
      ELSE
!DIR$ IVDEP
         DO 612 ji=1,ill
         ks(ibs+ios)=ior(                                               &
     &   iand(      ks(ibs+ios),      not(imask)),                      &
     &   iand(ishft(kd(jbd+iod),-ish),    imask ))
         iod=iod+istd
         ios=ios+ists
 612     CONTINUE
      ENDIF
!
!     7.  END LOOPS
!
!     7.1 PREPARE FOR END OF LOOP OVER WORDS OF KS WITIHN ONE KD WORD
!
      ista=ista+kbpw
!
!     7.2 NEXT WORD OF KD IF EXTRACTION NOT COMPLETED
!
      IF(ista.LT.ienbs)THEN
         imask=kmask(1)
         ibs=ibs+1
         GOTO 500
      ENDIF
!
!     7.8 PREPARE FOR END OF LOOP OVER FIRST WORDS OF KD
!
      IF(jbd.EQ.ibdl)ill=ill-1
      iskws=iskws+istep
!
!     7.9 END LOOP OVER FIRST WORDS OF KD
!
 790  CONTINUE
!
!     8.  FINISHED: UPDATE KSKST AND RETURN
!
      kskst=kskst+k*istep
!
!     8.5 SWAP BYTES ON VAX
!
      IF (lhook) CALL dr_hook('GSBITE_MF',1,zhook_handle)
      ENDSUBROUTINE gsbite_mf