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