ungrib/src/ngl/w3/gbytes_char.f

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