ciencode.F90

Go to the documentation of this file.

 
 
subroutine pkc(chr,nchr,ibay,ibit)
 
  use modv_vars, only: nbitw, nbytw, iordle, iordbe
 
  implicit none
 
  character*(*), intent(in) :: chr
  character*1 cval(8)
 
  integer, intent(in) :: nchr
  integer, intent(out) :: ibay(*)
  integer, intent(inout) :: ibit
  integer ival(2), lb, i, nwd, nbt, nbit, int, msk, irev
 
  equivalence(cval,ival)
 
  ! Set lb to point to the "low-order" (i.e. least significant) byte within a machine word.
 
#ifdef BIG_ENDIAN
  lb = iordbe(nbytw)
#else
  lb = iordle(nbytw)
#endif
 
  ival(1) = 0
  nbit = 8
 
  do i=1,nchr
    if(i<=len(chr)) then
      cval(lb) = chr(i:i)
    else
      cval(lb) = ' '
    endif
 
    nwd  = ibit/nbitw + 1
    nbt  = mod(ibit,nbitw)
    int = ishft(ival(1),nbitw-nbit)
    int = ishft(int,-nbt)
    msk = ishft(  -1,nbitw-nbit)
    msk = ishft(msk,-nbt)
    ibay(nwd) = irev(ior(iand(irev(ibay(nwd)),not(msk)),int))
    if(nbt+nbit>nbitw) then
 
      ! This character will not fit within the current word (i.e. array member) of ibay, because there
      ! are less than 8 bits of space left.  Store as many bits as will fit within the current
      ! word and then store the remaining bits within the next word.
 
      int = ishft(ival(1),2*nbitw-(nbt+nbit))
      msk = ishft(  -1,2*nbitw-(nbt+nbit))
      ibay(nwd+1) = irev(ior(iand(irev(ibay(nwd+1)),not(msk)),int))
    endif
    ibit = ibit + nbit
  enddo
 
  return
end subroutine pkc
 
subroutine pkb8(nval,nbits,ibay,ibit)
 
  use modv_vars, only: nbitw
 
  implicit none
 
  integer*8, intent(in) :: nval
  integer, intent(in) :: nbits
  integer, intent(out) :: ibay(*)
  integer, intent(inout) :: ibit
 
  integer*8 :: nval8
  integer :: nval4, nvals(2)
 
  equivalence(nval8,nvals)
 
  if(nbits<0) call bort('bufrlib: pkb8 - nbits < zero !!!!!')
  if(nbits>64) call bort('bufrlib: pkb8 - nbits > 64   !!!!!')
 
  nval8=nval
  nval4=nvals(2)
  call pkb(nval4,max(nbits-nbitw,0),ibay,ibit)
  nval4=nvals(1)
  call pkb(nval4,min(nbits,nbitw  ),ibay,ibit)
 
  return
end subroutine pkb8
 
subroutine pkb(nval,nbits,ibay,ibit)
 
  use modv_vars, only: nbitw
 
  implicit none
 
  integer, intent(in) :: nval, nbits
  integer, intent(out) :: ibay(*)
  integer, intent(inout) :: ibit
  integer nwd, nbt, ival, int, msk, irev
 
  character*156 bort_str
 
  if(nbits>nbitw) then
    write(bort_str,'("BUFRLIB: PKB - NUMBER OF BITS BEING PACKED '// &
      ', NBITS (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS MACHINE, NBITW (",I3,")")') nbits,nbitw
    call bort(bort_str)
  endif
 
  nwd  = ibit/nbitw + 1
  nbt  = mod(ibit,nbitw)
  ival = nval
  if(ishft(ival,-nbits)>0) ival = -1
  int = ishft(ival,nbitw-nbits)
  int = ishft(int,-nbt)
  msk = ishft(-1,nbitw-nbits)
  msk = ishft(msk,-nbt)
  ibay(nwd) = irev(ior(iand(irev(ibay(nwd)),not(msk)),int))
  if(nbt+nbits>nbitw) then
 
    ! There are less than nbits bits remaining within the current word (i.e. array member) of ibay,
    ! so store as many bits as will fit within the current word and then store the remaining bits
    ! within the next word.
 
    int = ishft(ival,2*nbitw-(nbt+nbits))
    msk = ishft(  -1,2*nbitw-(nbt+nbits))
    ibay(nwd+1) = irev(ior(iand(irev(ibay(nwd+1)),not(msk)),int))
  endif
 
  ibit = ibit + nbits
 
  return
end subroutine pkb
 
recursive subroutine ipkm(cbay,nbyt,n)
 
  use modv_vars, only: im8b, nbytw
 
  implicit none
 
  integer, intent(in) :: n, nbyt
  integer my_n, my_nbyt, int, irev, i
 
  character*(*), intent(out) :: cbay
  character*128 bort_str
  character*4 cint
 
  equivalence(cint,int)
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
 
    call x84(n,my_n,1)
    call x84(nbyt,my_nbyt,1)
    call ipkm(cbay,my_nbyt,my_n)
 
    im8b=.true.
    return
  endif
 
  if(nbyt>nbytw) then
    write(bort_str,'("BUFRLIB: IPKM - NUMBER OF BYTES BEING PACKED '// &
      ', NBYT (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS MACHINE, NBYTW (",I3,")")') nbyt,nbytw
    call bort(bort_str)
  endif
 
  int = irev(ishft(n,(nbytw-nbyt)*8))
  do i=1,nbyt
    cbay(i:i) = cint(i:i)
  enddo
 
  return
end subroutine ipkm
 
integer*8 function ipks(val,node) result(i8ret)
 
  use moda_tables
  use moda_nrv203
 
  implicit none
 
  integer*8 imask
  integer, intent(in) :: node
  integer jj
 
  real*8, parameter :: ten = 10.
  real*8, intent(in) :: val
 
  i8ret = nint(val * ten**isc(node),8) - irf(node)
 
  if ( nnrv > 0 ) then
    ! There are redefined reference values in the jump/link table, so we need to check if this node is affected by any of them.
    do jj = 1, nnrv
      if ( node == inodnrv(jj) ) then
        ! This node contains a redefined reference value. Per the rules of BUFR, negative values should be encoded as positive
        ! integers with the left-most bit set to 1.
        nrv(jj) = nint(val)
        if ( nrv(jj) < 0 ) then
          imask = 2_8**(ibt(node)-1)
          i8ret = ior(abs(nrv(jj)),imask)
        else
          i8ret = nrv(jj)
        end if
        return
      else if ( ( tag(node)(1:8) == tagnrv(jj) ) .and. ( node >= isnrv(jj) ) .and. ( node <= ienrv(jj) ) ) then
        ! The corresponding redefinded reference value needs to be used when encoding this value.
        i8ret = nint(val * ten**isc(node),8) - nrv(jj)
        return
      end if
    end do
  end if
 
  return
end function ipks