C Copyright 1981-2016 ECMWF.
C
C This software is licensed under the terms of the Apache Licence 
C Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
C
C In applying this licence, ECMWF does not waive the privileges and immunities 
C granted to it by virtue of its status as an intergovernmental organisation 
C nor does it submit to any jurisdiction.
C

      SUBROUTINE INXBIT (KGRIB,KLENG,KNSPT,KPARM,KNUM,KBIT,
     C                   KBLEN,HFUNC,KRET)
C
C---->
C**** INXBIT - Insert/extract bits consecutively in/from a given array
C
C     Purpose.
C     --------
C
C           Take rightmost KBLEN bits from KNUM words of KPARM
C           and insert them consecutively in KGRIB, starting at
C           bit after KNSPT or vice versa.
C
C**   Interface.
C     ----------
C
C           CALL INXBIT (KGRIB,KLENG,KNSPT,KPARM,KNUM,KBIT,
C    C                   KBLEN,KRET)
C
C           Integer    K.
C           Real       P.
C           Logical    O.
C           Character  H.
C
C               Input Parameters.
C               -----------------
C
C               KGRIB      - Array containing bitstream.
C               KLENG      - Length (words) of this array.
C               KNSPT      - Bit number after which insertion or
C                            extraction starts.
C               KPARM      - Array from which bits are taken for
C                            insertion in the bitstream or to which
C                            bits are extracted from the bitstream.
C               KBIT       - Number of bits in computer word.
C               KNUM       - Number of bit fields inserted/extracted.
C               KBLEN      - Number of bits per bit field.
C               HFUNC      - Requested function.
C                            'C' to insert bits in bitstream,
C                            'D' to extract bits from bitstream.
C
C               Output Parameters.
C               ------------------
C
C               KNSPT      - Bit number of last bit inserted/extracted.
C
C               KRET       - Return code.
C                            0 , No error encountered.
C                            1 , Insertion/extraction exceeded
C                                array boundary.
C
C     Method.
C     -------
C
C           Word and offset pointer calculated before calling
C           insertion/extraction routines.
C
C     Externals.
C     ----------
C
C           SBYTES
C           GBYTES
C           GSBITE
C
C     Reference.
C     ----------
C
C           ECLIB documentation on SBYTES and GBYTES.
C
C     Comments.
C     ---------
C
C           Cray version of routine.
C           This routine should only be used on the Cray as it
C           contains a call to GSBITE, a vectorising version of
C           GBYTE(S) and SBYTE(S).
C           Routine contains Sections 0 to 3 and Section 9.
C
C     Author.
C     -------
C
C           J. Hennessy      ECMWF      18.06.91
C
C     Modifications.
C     --------------
C
C           J. Hennessy      ECMWF      08.11.91
C           Parameter KMACH removed from list of input parameters.
C
C           J. Hennessy      ECMWF      12.10.92
C           Dimension of IMASK changed from 64 to 65.
C
C     ----------------------------------------------------------------
C----<
C
C
C
C
C
C
C
C
C
C
C*    Section 0 . Definition of variables. Data statements.
C     ----------------------------------------------------------------
C
C*    Prefix conventions for variable names.
C
C     Logical      L (but not LP), global or common.
C                  O, dummy arguments.
C                  G, local variable.
C                  LP, parameter.
C     Character    C, Global or common.
C                  H, dummy arguments.
C                  Y (but not YP), local variables.
C                  YP, parameter.
C     Integer      M and N, global or common.
C                  K, dummy arguments.
C                  I, local variables.
C                  J (but not JP), loop control.
C                  JP, parameter.
C     Real         A to F and Q to X, global or common.
C                  P (but not PP), dummy arguments.
C                  Z, local variables.
C                  PP, parameter.
C
      IMPLICIT NONE
C
      INTEGER IMASK
      INTEGER IND
      INTEGER INUM
      INTEGER IOFF
      INTEGER IPR
      INTEGER IWORD
C
      INTEGER KBIT
      INTEGER KBLEN
      INTEGER KGRIB
      INTEGER KLENG
      INTEGER KNSPT
      INTEGER KNUM
      INTEGER KPARM
      INTEGER KRET
C
      INTEGER J901
C
      DIMENSION KGRIB(KLENG)
      DIMENSION KPARM(*)
      DIMENSION IMASK(65)
C
      CHARACTER*1 HFUNC
C
C     Values in IMASK are set in the first call to routine GSBITE, and
C     are used in subsequent calls.
C
      SAVE IMASK
C
C     Force routine GSBITE to calculate bit-masks first time through.
C
      DATA IMASK(2) /0/
C
C     Debug print switch.
C
      DATA IPR /0/
C
C     ----------------------------------------------------------------
C
C
C
C
C
C
C
C
C
C
C*    Section 1 . Set initial values.
C     ----------------------------------------------------------------
C
  100 CONTINUE
C
      IF (IPR.EQ.1)
     C   THEN
             WRITE (*,*) 'INXBIT : Section 1.'
             WRITE (*,*) '         Input values used -'
             WRITE (*,9009) KLENG
             WRITE (*,9002) KNSPT
             WRITE (*,9004) KBIT
             WRITE (*,9005) HFUNC
         ENDIF
C
      KRET = 0
C
C     ----------------------------------------------------------------
C
C
C
C
C
C
C
C
C
C
C*    Section 2 . Bit insertion/extraction.
C     ----------------------------------------------------------------
C
  200 CONTINUE
C
      IF (IPR.EQ.1) WRITE (*,*) 'INXBIT : Section 2.'
C
C*    Calculate word pointer and offset.
C
      IWORD = KNSPT / KBIT
      IOFF  = KNSPT - IWORD * KBIT
      IWORD = IWORD + 1
      IF (IPR.EQ.1) WRITE (*,9003) IWORD , IOFF
C
C     Insert/extract bits.
C
      IF (KNUM.GE.8)
     C   THEN
C
C            Cray vectorising routine GSBITE performs the same
C            functions as SBYTE(S) and GBYTE(S).
C
             CALL GSBITE (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM,
     C                    KBIT,IMASK,HFUNC)
         ELSE
C
C            Cray scalar faster.
C
             IF (HFUNC.EQ.'C')
     C          THEN
                    CALL SBYTES (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM)
                ELSE
                    CALL GBYTES (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM)
                ENDIF
         ENDIF
C
C     Update pointer.
C
      KNSPT = KNSPT + KBLEN * KNUM
C
C     ----------------------------------------------------------------
C
C
C
C
C
C
C
C
C
C
C*    Section 3 . Check out of range.
C    -----------------------------------------------------------------
C
  300 CONTINUE
C
      IF (IPR.EQ.1) WRITE (*,*) 'INXBIT : Section 3.'
C
      IND = KNSPT / KBIT
      IF (IND.GT.KLENG)
     C   THEN
             KRET = 1
             WRITE (*,9001) IND , KLENG
         ENDIF
C
C     ----------------------------------------------------------------
C
C
C
C
C
C
C
C
C
C
C*    Section 9 . Return to calling routine. Format statements.
C     ----------------------------------------------------------------
C
  900 CONTINUE
C
      IF (IPR.EQ.1)
     C   THEN
             INUM = KNUM
             IF (INUM.GT.360)
     C          THEN
                    INUM = 360
                    WRITE (*,9007) INUM
                ENDIF
             DO 901 J901=1,INUM
               IF (HFUNC.EQ.'C')
     C             THEN
                       WRITE (*,9006) KPARM(J901)
                   ELSE
                       WRITE (*,9008) KPARM(J901)
                   ENDIF
  901        CONTINUE
             WRITE (*,*) 'INXBIT : Section 9.'
             WRITE (*,*) '         Output values set -'
             WRITE (*,9002) KNSPT
         ENDIF
C
C
 9001 FORMAT (1H ,'INXBIT : Word ',I8,' is outside array bounds ',I8)
C
 9002 FORMAT (1H ,'         KNSPT  = ',I8)
C
 9003 FORMAT (1H ,'INXBIT : Word is',I8,', bit offset is ',I2)
C
 9004 FORMAT (1H ,'         KBIT   = ',I8)
C
 9005 FORMAT (1H ,'         HFUNC  = ',A)
C
 9006 FORMAT (1H ,'         Inserted value = ',I20)
C
 9007 FORMAT (1H ,'         First ',I9,' values.')
C
 9008 FORMAT (1H ,'         Extracted value = ',I20)
C
 9009 FORMAT (1H ,'         KLENG  = ',I20)
C
      RETURN
C
      END
      SUBROUTINE ABORTX (HNAME)
C
C**** ABORTX - Terminates execution of program.
C
C     Purpose.
C     --------
C
C           Terminates execution of program.
C
C**   Interface.
C     ----------
C
C           CALL ABORTX (HNAME)
C
C           Integer    K.
C           Real       P.
C           Logical    O.
C           Character  H.
C
C               Input Parameters.
C               -----------------
C
C               HNAME      - Name of calling routine.
C
C               Output Parameters.
C               ------------------
C
C               None.
C
C     Method.
C     -------
C
C           Prints message and terminates.
C
C     Externals.
C     ----------
C
C           ABORT
C
C     Reference.
C     ----------
C
C           None.
C
C     Comments.
C     ---------
C
C           Cray version of routine.
C           Routine contains Sections 0 to 1 and Section 9.
C
C     Author.
C     -------
C
C           J. Hennessy      ECMWF      13.11.91
C
C     Modifications.
C     --------------
C
C           None.
C
C     ------------------------------------------------------------------
C
C
C
C
C
C
C
C
C
C
C*    Section 0 . Definition of variables.
C     ------------------------------------------------------------------
C
C*    Prefix conventions for variable names.
C
C     Logical      L (but not LP), global or common.
C                  O, dummy arguments.
C                  G, local variable.
C                  LP, parameter.
C     Character    C, Global or common.
C                  H, dummy arguments.
C                  Y (but not YP), local variables.
C                  YP, parameter.
C     Integer      M and N, global or common.
C                  K, dummy arguments.
C                  I, local variables.
C                  J (but not JP), loop control.
C                  JP, parameter.
C     Real         A to F and Q to X, global or common.
C                  P (but not PP), dummy arguments.
C                  Z, local variables.
C                  PP, parameter.
C
      IMPLICIT NONE
C
      CHARACTER*(*) HNAME
C
C     ------------------------------------------------------------------
C
C
C
C
C
C
C
C
C
C
C*    Section 1 . Print message and terminate.
C     ------------------------------------------------------------------
C
  100 CONTINUE
C
      WRITE (*,9001) HNAME
C
      CALL ABORT
C
C     ------------------------------------------------------------------
C
C
C
C
C
C
C
C
C
C*    Section 9 . Format statements.
C     ------------------------------------------------------------------
C
  900 CONTINUE
C
 9001 FORMAT (1H ,'ABORTX : Routine ',A,' has requested program',
     C               ' termination.')
C
      RETURN
C
      END
      SUBROUTINE SETPAR (KBIT,KNEG,KPR)
C
C**** SETPAR - Set number of bits in word. Set maximum negative integer.
C
C     Purpose.
C     --------
C
C           Set number of bits in word. Set maximum negative integer.
C
C**   Interface.
C     ----------
C
C           CALL SETPAR (KBIT,KNEG,KPR)
C
C           Integer    K.
C           Real       P.
C           Logical    O.
C           Character  H.
C
C               Input Parameters.
C               -----------------
C
C               KPR        - Debug print switch.
C                            1 , print out.
C                            0 , No print out.
C
C               Output Parameters.
C               ------------------
C
C               KBIT       - Number of bits in computer word.
C
C               KNEG       - Maximum negative integer.
C
C     Method.
C     -------
C
C           Values are assigned.
C
C     Externals.
C     ----------
C
C           None.
C
C     Reference.
C     ----------
C
C           None.
C
C     Comments.
C     ---------
C
C           Cray version of routine.
C           Routine contains Sections 0 to 3 and Section 9.
C
C     Author.
C     -------
C
C           J. Hennessy      ECMWF      28.10.91
C
C     Modifications.
C     --------------
C
C           None.
C
C     ------------------------------------------------------------------
C
C
C
C
C
C
C
C
C
C
C*    Section 0 . Definition of variables. Data statements.
C     ------------------------------------------------------------------
C
C*    Prefix conventions for variable names.
C
C     Logical      L (but not LP), global or common.
C                  O, dummy arguments.
C                  G, local variable.
C                  LP, parameter.
C     Character    C, Global or common.
C                  H, dummy arguments.
C                  Y (but not YP), local variables.
C                  YP, parameter.
C     Integer      M and N, global or common.
C                  K, dummy arguments.
C                  I, local variables.
C                  J (but not JP), loop control.
C                  JP, parameter.
C     Real         A to F and Q to X, global or common.
C                  P (but not PP), dummy arguments.
C                  Z, local variables.
C                  PP, parameter.
C
      IMPLICIT NONE
C
      INTEGER KBIT
      INTEGER KNEG
      INTEGER KPR
C
C     ------------------------------------------------------------------
C
C
C
C
C
C
C
C
C
C
C*    Section 1 . Assign values.
C     ------------------------------------------------------------------
C
  100 CONTINUE
C
      IF (KPR.EQ.1)  WRITE (*,*) ' SETPAR : Section 1.'
C
      KBIT = 64
      KNEG = -9223372036854775807
C
C     ------------------------------------------------------------------
C
C
C
C
C
C
C
C
C
C*    Section 9 . Return to calling routine. Format statements.
C     ------------------------------------------------------------------
C
  900 CONTINUE
C
      IF (KPR.EQ.1)
     C   THEN
             WRITE (*,*) ' SETPAR : Section 9.'
             WRITE (*,*) '          Output values set -'
             WRITE (*,9001) KBIT
             WRITE (*,9002) KNEG
         ENDIF
C
 9001 FORMAT (1H ,'          KBIT = ',I3)
C
 9002 FORMAT (1H ,'          KNEG = ',I22)
C
      RETURN
C
      END
      SUBROUTINE GSBITE (KS,KD,KSKST,KSIZE,KSKBTW,K,KBPW,KMASK,HADIR)
C
C**** GSBITE - Extraction/insertion of bits from/to bitstream on Cray.
C
C     Purpose.
C     --------
C
C           Vectorising extraction/insertion of bits from/to bitstream.
C
C**   Interface.
C     ----------
C
C           CALL GSBITE (KS,KD,KSKST,KSIZE,KSKBTW,K,KBPW,KMASK,HADIR)
C
C           Integer    K.
C           Real       P.
C           Logical    O.
C           Character  H.
C
C               Input Parameters.
C               -----------------
C
C               KS      - If HADIR='D', input bit stream, else output
C                         bit stream.
C               KD      - If HADIR='D', output words, else input words.
C               KSKST   - Number of bits skipped at beginning of KS.
C               KSIZE   - Number of bits to be extracted to one word
C                         of KD.
C               KSKBTW  - Number of bits skipped between two words to
C                         be extracted.
C               K       - Number of words to be extracted into KD. If
C                         less than or equal to 0 only calculate KBPW
C                         and KMASK.
C               KBPW    - Number of bits per word in KS,calculated if 0.
C               KMASK   - Masks for bit patterns, calculated if
C                         KMASK(2) is 0.
C               HADIR   - Direction of conversion: 'D' for decoding, ie
C                         extract words KD(1...K) from bits
C                         KS(KSKST+1....)
C                         If not 'D', encode, i.e. pack words
C                         KD(1....K) into bits
C                         KS(KSKST+1.....KSKST+K*(KSIZE+KSKBTW))
C
C               Output Parameters.
C               ------------------
C
C               KS,KD   - See above.
C               KSKST   - Updated to number of bits used, i.e. to
C                         KSKST+K*(KSIZE+KSKBTW)
C               KBPW    - If 0 on input, number of bits in each word
C                         of KS.
C               KMASK   - If KMASK(2) was 0 on input, bit pattern masks.
C
C     Method.
C     -------
C
C           Vector loop is over repeatedly occurring bit patterns.
C
C     Externals.
C     ----------
C
C           None.
C
C     Reference.
C     ----------
C
C           None.
C
C     Comments.
C     ---------
C
C           This routine is for the Cray only.
C           Variable names do not conform to the standard.
C
C     Author.
C     -------
C
C           G.J.Cats 08 Dec 87
C
C     Modifications.
C     --------------
C
C           J. Hennessy     ECMWF     09.09.91
C           Introductory comments changed to conform to standard.
C
C     ------------------------------------------------------------------
C
      DIMENSION KS(*),KD(*),KMASK(*)
      CHARACTER*1 HADIR
C
C     STATEMENT FUNCTIONS TO MANIPULATE BITS IN WORDS OF 64 BITS
C
C     DATA ONES/7777777777777777B/
C     DATA OOOS/0B/
C
C     1.  SINGLE BIT MANIPULATIONS
C
C     1.1 SET BIT KBIT IN WORD PW
C
      IBSET(KW,KBIT)=OR(KW,SHIFT(1B,KBIT))
C
C     2.  WORD MANIPULATIONS, BIT BY BIT
C
C     2.1 ARE WORDS PW1 AND PW2 EQUAL?
C
C      LOGICAL NLEQAL
C     NLEQAL(PW1,PW2)=(PW1.XOR.PW2).EQ.0B
C
C     2.2 BITWISE AND AND OR
C
      IAND(K1,K2)=AND(K1,K2)
      IOR (K1,K2)= OR(K1,K2)
C
C     2.3 BITWISE NEGATION
C
      NOT(K)=COMPL(K)
C
C     2.4 SHIFT (LEFT FOR KSH POSITIVE, RIGHT FOR KSH NEGATIVE
C
      ISHFT(K,KSH)=CVMGP(SHIFTL(K,KSH),SHIFTR(K,-KSH),KSH)
C
C     3.  SPECIAL PURPOSE
C
C     3.1 TAKE 4 LAST BITS OF KW, PUT THEM IN PW AT POS K*4-1
C
C     SETLEV(PW,KW,K)=OR(AND(PW,SHIFT(0B.EQV.17B,K*4-4)),
C    +SHIFT(AND(17B,KW),K*4-4))
C
C     3.2 EXTRACT FIELD [K*4-1:4] FROM PW
C
C     MGTLEV(PW,K)=AND(17B,SHIFT(PW,68-K*4))
C
C     1.  COMPLETE KBPW AND KMASK, RETURN IF 0 WORDS ARE TO BE EXTRACTED
C
      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)RETURN
C
C     2.  PRESET KD TO 0 IF KD IS OUTPUT I.E. WHEN DECODING
C
      IF(HADIR.EQ.'D')THEN
         DO 2101 J=1,K
         KD(J)=0
 2101    CONTINUE
      ENDIF
C
C     3.  CALCULATE SEVERAL PARAMETERS FOR LOOPING (FOR EFFICIENCY, THE
C         CODE OF SECTIONS 3.3 AND 3.4 FOR K=1 IS SEPARATED INTO 3.2)
C
C     3.1 NUMBER OF BITS USED PER WORD, INITIAL NR OF SKIPPED BITS
C
      ISTEP=KSIZE+KSKBTW
      ISKWS=KSKST
C
C     3.2 VECTOR LOOP LENGTH AND STEP SIZE IN KD IF K=1;KS STEP IRRELVNT
C
      IF(K.EQ.1)THEN
         ILL=1
         IBDL=2
         ISTD=1
      ELSE
C
C     3.3 STEP SIZES IN KS,KD: INVERSE OF LARGEST FACTOR OF ISTEP,KBPW
C
         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
C
C     3.4 VECTOR LOOP LENGTH AND SWITCH-OVER POINT FOR SMALLER LOOP
C
         ILL=(K-1)/ISTD+1
         IBDL=K-(ILL-1)*ISTD
      ENDIF
C
C     4.  LOOP OVER FIRST ISTD WORDS OF KD (TRAILS THE VECTOR LOOP)
C
      DO 790 JBD=1,ISTD
C
C     4.1 LAST BIT IN KS TO BE TREATED
C
      IENBS=ISKWS+KSIZE
C
C     4.2 NR OF WORDS OF KS TO BE SKIPPED, NR OF BITS IN THOSE AND THIS
C
      ISKW=ISKWS/KBPW
      ISTA=ISKW*KBPW
      ISKB=ISKWS-ISTA
C
C     4.3 MASK AND LEFT SHIFT FOR THE REMAINING BITS
C
      IMASK=KMASK(ISKB+1)
      ISH=KSIZE+ISKB
C
C     4.4 POSITION OF CURRENT WORD OF KS
C
      IBS=ISKW+1
C
C     5.  LOOP OVER WORDS OF KS CONTRIBUTING TO ONE WORD OF KD
C
 500  CONTINUE
C
C     5.1 UPDATE SHIFT AND LAST BIT IN CURRENT WORD
C
      ISH=ISH-KBPW
      IEND=ISTA+KBPW
C
C     5.2 IS LAST BIT OF CURRENT WORD OUTSIDE RANGE TO BE EXTRACTED
C
      IF(IEND.GT.IENBS)THEN
         ISH=IENBS-IEND
         IMASK=IAND(IMASK,NOT(KMASK(KBPW+ISH+1)))
      ENDIF
C
C     5.3 INITIAL OFFSETS FOR VECTOR ELEMENTS IN VECTOR LOOP
C
      IOS=0
      IOD=0
C
C     6.  VECTOR LOOP IS OVER REPEATEDLY OCCURRING BITPATTERNS/MASKS
C
      IF(HADIR.EQ.'D')THEN
CDIR$ 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
CDIR$ 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
C
C     7.  END LOOPS
C
C     7.1 PREPARE FOR END OF LOOP OVER WORDS OF KS WITIHN ONE KD WORD
C
      ISTA=ISTA+KBPW
C
C     7.2 NEXT WORD OF KD IF EXTRACTION NOT COMPLETED
C
      IF(ISTA.LT.IENBS)THEN
         IMASK=KMASK(1)
         IBS=IBS+1
         GOTO 500
      ENDIF
C
C     7.8 PREPARE FOR END OF LOOP OVER FIRST WORDS OF KD
C
      IF(JBD.EQ.IBDL)ILL=ILL-1
      ISKWS=ISKWS+ISTEP
C
C     7.9 END LOOP OVER FIRST WORDS OF KD
C
 790  CONTINUE
C
C     8.  FINISHED: UPDATE KSKST AND RETURN
C
      KSKST=KSKST+K*ISTEP
C
      RETURN
      END
      SUBROUTINE GBYTE  (SOURCE,DEST,IOFSET,IBYTSZ)
C
C**** GBYTE  - Extract a single bit field. Cray routine.
C
C*    FUNCTION: GET A SINGLE BIT FIELD FROM SOURCE INTO DEST
C*
C*    INPUT   : SOURCE(1)= WORD CONTAINING START OF BIT FIELD
C*              DEST     = TARGET WORD
C*              IOFSET   = OFFSET IN BITS FOR START OF THE FIELD
C*              IBYTSZ   = LENGTH OF FIELD IN BITS
C*
C*    OUTPUT  : SOURCE,IOFSET,IBYTSZ UNCHANGED
C*              DEST CONTAINS FIELD RIGHT JUSTIFIED
C*
C*    AUTHOR  : M.MIQUEU   08/1981 (REWRITTEN FROM J.MARTELLET'S)
C*
      PARAMETER(NBPW=64)
      INTEGER SOURCE(1),DEST
      INTEGER SH1
      SH1=IOFSET+IBYTSZ-NBPW

      IF(SH1.GT.0) GO TO 2


C     BYTES DO NOT SPAN WORDS


      SH1=NBPW+SH1


      DEST=AND(
     1          SHIFT(SOURCE(1),SH1),
     2          SHIFT(MASK(IBYTSZ),IBYTSZ)
     3        )

      RETURN

C     BYTE SPANS WORDS

2     CONTINUE


      DEST=OR(
     1        SHIFT(
     2              AND(SOURCE(1),COMPL(MASK(IOFSET)))
     3              ,SH1),
     4        SHIFT(
     5              AND(SOURCE(2),MASK(SH1))
     6              ,SH1)
     7       )



      RETURN
      END
      SUBROUTINE GBYTES (S,D,ISKIP1,IBSIZ,ISKIP2,NBYTES,KWOFF)
C
C**** GBYTES - Extract a number of bit fields. Cray routine.
C
C S CONTAINS A BIT STRING OF INDEFINITE LENGTH. GBYTES WILL
C EXTRACT NBYTES BITSTRINGS, IBSIZ BITS LONG, AND STORE THEM
C RIGHT JUSTIFIED 0 FILL, INTO SUCCESSIVE WORDS OF D. THE
C SUCCESSIVE BITSTRINGS START AT BIT POSITIONS
C     ISKIP1+1+(IBYTE-1)*(IBSIZ+ISKIP2)
C IN THE BIT STRING S. I.E. SKIP ISKIP1 BITS AT THE START,
C AND ISKIP2 BITS BETWEEN THE EXTRACTED STRINGS.
C BIT ISKP+1 IN A STRING IS FOUND IN WORD IS=1+ISKIP/NBPW IN S,
C WHERE NBPW IS THE NUMBER OF BITS PER WORD. THE STARTING BIT
C IS FOUND BY SKIPPING MOD(ISKP,NBPW) BITS IN THAT WORD.
C KWOFF IS AN OPTIONAL 7TH PARAMETER, WHICH DEFAULTS TO 0
C IF PRESENT KWOFF BITS ARE TOTALLY IGNORED AT THE START OF A WORD
C THUS IF A PACKED CYBER BIT STRING IS TRANSFERRED TO THE
C CRAY, WITH EACH 60 BIT CYBER WORD PLACED AT THE RIGHT END OF
C A 64 BIT CRAY WORD, A BYTE SEQUENCE WHICH WAS ORIGINALLY
C LOCATED WITH START POINTS IN ARITHMETIC PROGRESSION ON THE
C CYBER, WILL NO LONGER HAVE THIS PROPERTY ON THE CRAY. BY
C USING THE ROUTINE WITH KWOFF=4, THE ELEMENTS OF THE BYTE
C SEQUENCE CAN BE EXTRACTED ON THE CRAY, USING THE SAME SKIPS
C AS WERE USED ON THE CYBER.
C
      PARAMETER(NBPW=64)
      DIMENSION S(2) , D(NBYTES)
      INTEGER SH1
      IGNORE = 0
      IF(NUMARG().GT.6) IGNORE = KWOFF
      IS=1+ISKIP1/(NBPW-IGNORE)
      ISKIP = MOD(ISKIP1,NBPW-IGNORE) + IGNORE
      ISTEP = ISKIP2+IBSIZ
      DO 75 IBYTE = 1 , NBYTES
C WITH THE STARTING WORD AND BIT POSITION DETERMINED, THE
C DESIRED EXTRACTION CAN BE DONE BY
C***     CALL GBYTE(S(IS),D(IBYTE),ISKIP,IBSIZ)
C BUT SINCE THE CODE IS SHORT IT IS INSERTED IN-LINE.
         SH1 = ISKIP+IBSIZ
         IF(SH1.GT.NBPW) GO TO 50
C BYTE COMES FROM 1 WORD OF S
         D(IBYTE) = AND( SHIFT(S(IS),SH1),SHIFT(MASK(IBSIZ),IBSIZ))
         GO TO 65
   50    CONTINUE
         SH1 =SH1-NBPW
C BYTE COMES FROM 2 WORDS OF S.
         D(IBYTE) = OR(SHIFT(AND(S(IS),COMPL(MASK(ISKIP))),SH1)
     1                           ,
     2                SHIFT(AND(SHIFT(S(IS+1),IGNORE),MASK(SH1)),SH1)
     3                 )
   65    CONTINUE
C UPDATE STARTING WORD AND BIT POSITION
         ISKIP = ISKIP+ISTEP
         IF(ISKIP.LT.NBPW) GO TO 75
         ISKIP =ISKIP-NBPW
         IS = IS+1+ISKIP/(NBPW-IGNORE)
         ISKIP = MOD(ISKIP,NBPW-IGNORE) + IGNORE
   75 CONTINUE
      RETURN
      END
      SUBROUTINE SBYTE  (DEST,SOURCE,IOFSET,IBYTSZ)
C
C**** SBYTE  - Insert a single bit field. Cray routine.
C
C*    FUNCTION: STORE A SINGLE BIT FIELD FROM SOURCE INTO DEST
C*
C*    INPUT   : SOURCE   = WORD CONTAINING  BIT FIELD RIGHT JUSTIFIED
C*              DEST(1)  = 1ST TARGET WORD
C*              IOFSET   = OFFSET IN BITS FOR START OF THE FIELD
C*              IBYTSZ   = LENGTH OF FIELD IN BITS ; .LE.WORD SIZE .....
C*
C*    OUTPUT  : SOURCE,IOFSET,IBYTSZ UNCHANGED
C*              DEST(1) AND EVENTUALLY DEST(2) CONTAIN FIELD
C*
C*    AUTHOR  : M.MIQUEU   08/1981 (REWRITTEN FROM J.MARTELLET'S)
C*
      PARAMETER(NBPW=64)
      INTEGER SOURCE,DEST(1)
      INTEGER SH1,SH2,SH3
      SH1=IOFSET+IBYTSZ
      IF(SH1.GT.NBPW) GO TO 2

      SH2=NBPW-SH1
      IF(SH2.LT.0) SH2=NBPW-SH2

C     BYTE  DOES NOT SPAN WORDS


      DEST(1)=SHIFT(
     1              OR(
     2                 AND(SHIFT(DEST(1),SH1),
     3                     SHIFT(COMPL(MASK(IBYTSZ)),IBYTSZ) )
     4                 ,
     5                 AND(SOURCE,
     6                     COMPL(SHIFT(COMPL(MASK(IBYTSZ)),IBYTSZ)) )
     7                 )
     8              ,SH2)



      RETURN

2     CONTINUE

C     BYTE SPANS 2 WORDS

      SH3=2*NBPW-SH1


      DEST(1)=OR(
     1           AND(DEST(1),MASK(IOFSET))
     2           ,
     3           AND(SHIFT(SOURCE,SH3) , COMPL(MASK(IOFSET)) )
     4           )

      DEST(2)=OR(
     1           AND(DEST(2) , COMPL(MASK(SH1-NBPW)) )
     2           ,
     3           SHIFT( AND(SOURCE , COMPL(MASK(SH3)) ) ,SH3)
     4           )



      RETURN
      END
      SUBROUTINE SBYTES (D,S,ISKIP1,IBSIZ,ISKIP2,NBYTES,KWOFF)
C
C**** SBYTES - Insert a number of bit fields. Cray routine.
C
C REVERSES THE ACTION OF GBYTES, TAKING FIELDS FROM S AND
C INSERTING THEM INTO A BIT STRING IN D. SEE GBYTES.
C AUTHOR D. ROBERTSON  AUG,1981
C
      PARAMETER(NBPW=64)
      DIMENSION D(2) , S(NBYTES)
      INTEGER SH1,SH2,SH3
      IGNORE = 0
      IF(NUMARG().GT.6) IGNORE = KWOFF
      ID=1+ISKIP1/(NBPW-IGNORE)
      ISKIP = MOD(ISKIP1,NBPW-IGNORE) + IGNORE
      ISTEP = ISKIP2+IBSIZ
      DO 75 IBYTE = 1 , NBYTES
C WITH THE STARTING WORD AND BIT POSITION KNOWN, THE
C DESIRED INSERTION CAN BE DONE BY
C**      CALL SBYTE(D(ID),S(IBYTE),ISKIP,IBSIZ)
C BUT THE CODE IS SHORT ENOUGH TO GO IN-LINE.
         SH1 = ISKIP+IBSIZ
         IF(SH1.GT.NBPW) GO TO 50
         SH2 = NBPW-SH1
         IF(SH2.LT.0) SH2 = NBPW-SH2
C BYTE GOES INTO 1 WORD OF D.
         D(ID) = SHIFT(OR(AND(SHIFT(D(ID),SH1),MASK(NBPW-IBSIZ)),
     1                   AND(S(IBYTE),SHIFT(MASK(IBSIZ),IBSIZ))),SH2)
         GO TO 65
   50    CONTINUE
C BYTE GOES INTO 2 WORDS OF D.
         SH3 = 2*NBPW-SH1
         D(ID)=OR(AND(D(ID),MASK(ISKIP)),
     1               AND(SHIFT(S(IBYTE),SH3),COMPL(MASK(ISKIP))))
         D(ID+1)=OR(AND(D(ID+1),SHIFT(COMPL(MASK(SH1-NBPW)),NBPW-IGNORE)
     1                 ),
     2              SHIFT(AND(S(IBYTE),COMPL(MASK(SH3))),SH3-IGNORE))
   65    CONTINUE
C UPDATE STARTING WORD AND BIT POSITION
         ISKIP = ISKIP+ISTEP
         IF(ISKIP.LT.NBPW) GO TO 75
         ISKIP = ISKIP - NBPW
         ID = ID+1+ISKIP/(NBPW-IGNORE)
         ISKIP = MOD(ISKIP,NBPW-IGNORE) + IGNORE
   75    CONTINUE
      RETURN
      END
