1C Copyright 1981-2016 ECMWF.
2C
3C This software is licensed under the terms of the Apache Licence
4C Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
5C
6C In applying this licence, ECMWF does not waive the privileges and immunities
7C granted to it by virtue of its status as an intergovernmental organisation
8C nor does it submit to any jurisdiction.
9C
10
11      SUBROUTINE INXBIT (KGRIB,KLENG,KNSPT,KPARM,KNUM,KBIT,
12     C                   KBLEN,HFUNC,KRET)
13C
14C---->
15C**** INXBIT - Insert/extract bits consecutively in/from a given array
16C
17C     Purpose.
18C     --------
19C
20C     Take rightmost KBLEN bits from KNUM words of KPARM
21C     and insert them consecutively in KGRIB, starting at
22C     bit after KNSPT or vice versa.
23C
24C**   Interface.
25C     ----------
26C
27C     CALL INXBIT (KGRIB,KLENG,KNSPT,KPARM,KNUM,KBIT, KBLEN,KRET)
28C
29C
30C     Input Parameters.
31C     -----------------
32C
33C     KGRIB      - Array containing bitstream.
34C     KLENG      - Length (words) of this array.
35C     KNSPT      - Bit number after which insertion/extraction starts.
36C     KPARM      - Array from which bits are taken for
37C                  insertion in the bitstream or to which
38C                  bits are extracted from the bitstream.
39C     KBIT       - Number of bits in computer word.
40C     KNUM       - Number of bit fields inserted/extracted.
41C     KBLEN      - Number of bits per bit field.
42C     HFUNC      - Requested function.
43C                  'C' to insert bits in bitstream,
44C                  'D' to extract bits from bitstream.
45C
46C     Output Parameters.
47C     ------------------
48C
49C     KNSPT      - Bit number of last bit inserted/extracted.
50C
51C     KRET       - Return code.
52C                  0 , No error encountered.
53C                  1 , Insertion/extraction exceeded array boundary.
54C
55C     Method.
56C     -------
57C
58C     Word and offset pointer calculated before calling
59C     insertion/extraction routines.
60C
61C     Externals.
62C     ----------
63C
64C
65C     Reference.
66C     ----------
67C
68C     ECLIB documentation on SBYTES and GBYTES.
69C
70C     Comments.
71C     ---------
72C
73#if (defined CRAY) || (defined __uxp__ ) || (defined IBM_POWER4)
74C     Vectorized Fortran version of routine.
75C     This routine contains a call to GSBITE, a vectorising
76C     version of GBYTE(S) and SBYTE(S).
77#else
78C     Generic version of routine.
79#endif
80C     Author.
81C     -------
82C
83C     J. Hennessy      ECMWF      18.06.91
84C
85C     Modifications.
86C     --------------
87C
88C     J. Hennessy      ECMWF      08.11.91
89C     Parameter KMACH removed from list of input parameters.
90C
91C     J. Hennessy      ECMWF      12.10.92
92C     Dimension of IMASK changed from 64 to 65.
93C
94C     J.D.Chambers     ECMWF      21.05.96
95C     Defines put in for Fujtsu.
96C
97C----<
98C     ----------------------------------------------------------------
99C*    Section 0 . Definition of variables. Data statements.
100C     ----------------------------------------------------------------
101C
102      IMPLICIT NONE
103C
104#include "common/grprs.h"
105C
106      CHARACTER*1 HFUNC
107      INTEGER IND, IOFF, IWORD
108      INTEGER KBIT, KBLEN, KGRIB, KLENG, KNSPT, KNUM, KPARM, KRET
109#ifdef DEBUG
110      INTEGER INUM, J901
111#endif
112C
113      DIMENSION KGRIB(KLENG)
114      DIMENSION KPARM(*)
115#if (defined CRAY) || (defined __uxp__ ) || (defined IBM_POWER4)
116      INTEGER IMASK
117      DIMENSION IMASK(65)
118C
119C     Values in IMASK are set in the first call to routine GSBITE, and
120C     are used in subsequent calls.
121C
122      SAVE IMASK
123C
124C     Force routine GSBITE to calculate bit-masks first time through.
125C
126      DATA IMASK(2) /0/
127#endif
128C
129C     ----------------------------------------------------------------
130C*    Section 1 . Set initial values.
131C     ----------------------------------------------------------------
132C
133  100 CONTINUE
134C
135#ifdef DEBUG
136      WRITE(GRPRSM,*) 'INXBIT: Input values used -'
137      WRITE(GRPRSM,*) 'KLENG = ', KLENG
138      WRITE(GRPRSM,*) 'KNSPT = ', KNSPT
139      WRITE(GRPRSM,*) 'KBIT = ', KBIT
140      WRITE(GRPRSM,*) 'HFUNC = ', HFUNC
141#endif
142C
143      KRET = 0
144C
145C     ----------------------------------------------------------------
146C*    Section 2 . Bit insertion/extraction.
147C     ----------------------------------------------------------------
148C
149  200 CONTINUE
150C
151C*    Calculate word pointer and offset.
152C
153      IWORD = KNSPT / KBIT
154      IOFF  = KNSPT - IWORD * KBIT
155      IWORD = IWORD + 1
156#ifdef DEBUG
157      WRITE(GRPRSM,*) 'INXBIT: Word is ',IWORD,', bit offset is ',IOFF
158#endif
159C
160C     Insert/extract bits.
161C
162#if (defined CRAY) || (defined __uxp__ ) || (defined IBM_POWER4)
163      IF (KNUM.GE.8) THEN
164C
165C       Vectorising routine GSBITE performs the same
166C       functions as SBYTE(S) and GBYTE(S).
167C
168        CALL GSBITE (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM,
169     X                    KBIT,IMASK,HFUNC)
170      ELSE
171C
172C       Scalar faster.
173C
174        IF (HFUNC.EQ.'C') THEN
175          CALL SBYTES (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM)
176        ELSE
177          CALL GBYTES (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM)
178        ENDIF
179      ENDIF
180#elif (defined CYBER)
181      IF (HFUNC.EQ.'C') THEN
182        CALL SBYTES6 (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM)
183      ELSE
184        CALL GBYTES6 (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM)
185      ENDIF
186#elif (defined IBM) || (defined VAX)
187      IF (HFUNC.EQ.'C') THEN
188        CALL SBYTES (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM)
189      ELSE
190        CALL GBYTES (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM)
191      ENDIF
192#else
193      IF (HFUNC.EQ.'C') THEN
194        CALL SBYTES (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM)
195      ELSE
196        CALL GBYTES (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM)
197      ENDIF
198#endif
199C
200C     Update pointer.
201C
202      KNSPT = KNSPT + KBLEN * KNUM
203C
204C     ----------------------------------------------------------------
205C*    Section 3 . Check out of range.
206C    -----------------------------------------------------------------
207C
208  300 CONTINUE
209C
210      IND = KNSPT / KBIT
211      IF (IND.GT.KLENG) THEN
212        KRET = 1
213        WRITE(GRPRSM,*) 'INXBIT : Word ', IND ,
214     X              ' is outside array bounds ', KLENG
215      ENDIF
216C
217C     ----------------------------------------------------------------
218C*    Section 9 . Return to calling routine.
219C     ----------------------------------------------------------------
220C
221  900 CONTINUE
222C
223#ifdef DEBUG
224      INUM = KNUM
225      IF( INUM.GT.360 ) THEN
226        INUM = 360
227        WRITE(GRPRSM,*) 'First ', INUM,' values.'
228      ENDIF
229      DO 901 J901=1,INUM
230        IF( HFUNC.EQ.'C' ) THEN
231          WRITE(GRPRSM,*) 'Inserted value = ', KPARM(J901)
232        ELSE
233          WRITE(GRPRSM,'(1H ,Z)') KGRIB(IWORD)
234          WRITE(GRPRSM,*) 'Extracted value = ', KPARM(J901)
235          WRITE(GRPRSM,'(1H ,Z)') KPARM(J901)
236        ENDIF
237  901 CONTINUE
238      WRITE(GRPRSM,*) '         Output values set -'
239      WRITE(GRPRSM,*) 'KNSPT = ', KNSPT
240#endif
241C
242      RETURN
243      END
244