ungrib/src/ngl/g2/gbytesc.f

   1       SUBROUTINE GBYTE(IN,IOUT,ISKIP,NBYTE)
   2       character*1 in(*)
   3       integer iout(*)
   4       CALL GBYTES(IN,IOUT,ISKIP,NBYTE,0,1)
   5       RETURN
   6       END
   7
   8       SUBROUTINE SBYTE(OUT,IN,ISKIP,NBYTE)
   9       character*1 out(*)
  10       integer in(*)
  11       CALL SBYTES(OUT,IN,ISKIP,NBYTE,0,1)
  12       RETURN
  13       END
  14
  15       SUBROUTINE GBYTES(IN,IOUT,ISKIP,NBYTE,NSKIP,N)
  16 C          Get bytes - unpack bits:  Extract arbitrary size values from a
  17 C          packed bit string, right justifying each value in the unpacked
  18 C          array.
  19 C            IN    = character*1 array input
  20 C            IOUT  = unpacked array output
  21 C            ISKIP = initial number of bits to skip
  22 C            NBYTE = number of bits to take
  23 C            NSKIP = additional number of bits to skip on each iteration
  24 C            N     = number of iterations
  25 C v1.1
  26 C
  27       character*1 in(*)
  28       integer iout(*)
  29       integer tbit, bitcnt
  30       integer, parameter :: ones(8) = (/ 1,3,7,15,31,63,127,255 /)
  31
  32 c     nbit is the start position of the field in bits
  33       nbit = iskip
  34       do i = 1, n
  35          bitcnt = nbyte
  36          index=nbit/8+1
  37          ibit=mod(nbit,8)
  38          nbit = nbit + nbyte + nskip
  39
  40 c        first byte
  41          tbit = min(bitcnt,8-ibit)
  42          itmp = iand(mov_a2i(in(index)),ones(8-ibit))
  43          if (tbit.ne.8-ibit) itmp = ishft(itmp,tbit-8+ibit)
  44          index = index + 1
  45          bitcnt = bitcnt - tbit
  46
  47 c        now transfer whole bytes
  48          do while (bitcnt.ge.8)
  49              itmp = ior(ishft(itmp,8),mov_a2i(in(index)))
  50              bitcnt = bitcnt - 8
  51              index = index + 1
  52          enddo
  53
  54 c        get data from last byte
  55          if (bitcnt.gt.0) then
  56             itmp = ior(ishft(itmp,bitcnt),iand(ishft(mov_a2i(in(index)),
  57      1          -(8-bitcnt)),ones(bitcnt)))
  58          endif
  59
  60          iout(i) = itmp
  61       enddo
  62
  63       RETURN
  64       END
  65
  66       SUBROUTINE SBYTES(OUT,IN,ISKIP,NBYTE,NSKIP,N)
  67 C          Store bytes - pack bits:  Put arbitrary size values into a
  68 C          packed bit string, taking the low order bits from each value
  69 C          in the unpacked array.
  70 C            IOUT  = packed array output
  71 C            IN    = unpacked array input
  72 C            ISKIP = initial number of bits to skip
  73 C            NBYTE = number of bits to pack
  74 C            NSKIP = additional number of bits to skip on each iteration
  75 C            N     = number of iterations
  76 C v1.1
  77 C
  78       character*1 out(*)
  79       integer in(N), bitcnt, tbit
  80       integer, parameter :: ones(8)=(/ 1,  3,  7, 15, 31, 63,127,255/)
  81
  82 c     number bits from zero to ...
  83 c     nbit is the last bit of the field to be filled
  84
  85       nbit = iskip + nbyte - 1
  86       do i = 1, n
  87          itmp = in(i)
  88          bitcnt = nbyte
  89          index=nbit/8+1
  90          ibit=mod(nbit,8)
  91          nbit = nbit + nbyte + nskip
  92
  93 c        make byte aligned
  94          if (ibit.ne.7) then
  95              tbit = min(bitcnt,ibit+1)
  96              imask = ishft(ones(tbit),7-ibit)
  97              itmp2 = iand(ishft(itmp,7-ibit),imask)
  98              itmp3 = iand(mov_a2i(out(index)), 255-imask)
  99              out(index) = char(ior(itmp2,itmp3))
 100              bitcnt = bitcnt - tbit
 101              itmp = ishft(itmp, -tbit)
 102              index = index - 1
 103          endif
 104
 105 c        now byte aligned
 106
 107 c        do by bytes
 108          do while (bitcnt.ge.8)
 109              out(index) = char(iand(itmp,255))
 110              itmp = ishft(itmp,-8)
 111              bitcnt = bitcnt - 8
 112              index = index - 1
 113          enddo
 114
 115 c        do last byte
 116
 117          if (bitcnt.gt.0) then
 118              itmp2 = iand(itmp,ones(bitcnt))
 119              itmp3 = iand(mov_a2i(out(index)), 255-ones(bitcnt))
 120              out(index) = char(ior(itmp2,itmp3))
 121          endif
 122       enddo
 123
 124       return
 125       end