cidecode.F90

Go to the documentation of this file.

 
 
subroutine upc(chr,nchr,ibay,ibit,cnvnull)
 
  use modv_vars, only: nbytw, iordle, iordbe
 
  implicit none
 
  character*(*), intent(out) :: chr
  character*1 cval(8)
 
  integer, intent(in) :: nchr, ibay(*)
  integer, intent(inout) :: ibit
  integer ival(2), lb, i, numchr
 
  logical, intent(in) :: cnvnull
 
  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
 
  cval = ' '
 
  numchr = min(nchr,len(chr))
  do i=1,numchr
    call upb(ival(1),8,ibay,ibit)
    if((ival(1)==0).and.(cnvnull)) then
      chr(i:i) = ' '
    else
      chr(i:i) = cval(lb)
    endif
  enddo
 
  return
end subroutine upc
 
subroutine upb8(nval,nbits,ibit,ibay)
 
  use modv_vars, only: nbitw
 
  implicit none
 
  integer, intent(in) :: nbits,ibit,ibay(*)
  integer*8, intent(out) :: nval
 
  integer :: nvals(2), jbit, ival
  integer*8 :: nval8
 
  equivalence(nval8,nvals)
 
  if(nbits<0) then
     call bort('BUFRLIB: UPB8 - nbits < zero !!!!!')
  elseif(nbits<=32) then
     jbit=ibit; ival=0
     call upb(ival,nbits,ibay,jbit)
     nval=ival
  elseif(nbits<=64) then
     jbit=ibit; nvals=0
     call upb(nvals(2),max(nbits-nbitw,0),ibay,jbit)
     call upb(nvals(1),min(nbitw,nbits  ),ibay,jbit)
     nval=nval8
  else
     nval=0
  endif
 
  return
end subroutine upb8
 
subroutine up8(nval,nbits,ibay,ibit)
 
  implicit none
 
  integer, intent(in) :: nbits, ibay(*)
  integer, intent(inout) :: ibit
  integer*8, intent(out) :: nval
 
  call upb8(nval,nbits,ibit,ibay)
  ibit = ibit+nbits
 
  return
end subroutine up8
 
subroutine upbb(nval,nbits,ibit,ibay)
 
  use modv_vars, only: nbitw
 
  implicit none
 
  integer, intent(in) :: ibay(*), ibit, nbits
  integer, intent(out) :: nval
  integer nwd, nbt, int, jnt, irev, lbt
 
  !  If nbits=0, then just set nval=0 and return
 
  if(nbits==0) then
    nval=0
    return
  endif
 
  nwd = ibit/nbitw + 1
  nbt = mod(ibit,nbitw)
  int = ishft(irev(ibay(nwd)),nbt)
  int = ishft(int,nbits-nbitw)
  lbt = nbt+nbits
  if(lbt>nbitw) then
    jnt = irev(ibay(nwd+1))
    int = ior(int,ishft(jnt,lbt-2*nbitw))
  endif
  nval = int
 
  return
end subroutine upbb
 
subroutine upb(nval,nbits,ibay,ibit)
 
  implicit none
 
  integer, intent(in) :: ibay(*), nbits
  integer, intent(out) :: nval
  integer, intent(inout) :: ibit
 
  call upbb(nval,nbits,ibit,ibay)
  ibit = ibit+nbits
 
  return
end subroutine upb
 
recursive integer function iupb(mbay,nbyt,nbit) result(iret)
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(in) :: mbay(*), nbit, nbyt
  integer my_nbit, my_nbyt, mbit
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
 
    call x84(nbyt,my_nbyt,1)
    call x84(nbit,my_nbit,1)
    iret = iupb(mbay,my_nbyt,my_nbit)
 
    im8b=.true.
    return
  endif
 
  mbit = (nbyt-1)*8
  call upb(iret,nbit,mbay,mbit)
 
  return
end function iupb
 
recursive integer function iupm(cbay,nbits) result(iret)
 
  use modv_vars, only: im8b, nbitw
 
  implicit none
 
  character*4, intent(in) :: cbay
  character*4 cint
  character*128 bort_str
 
  integer, intent(in) :: nbits
  integer my_nbits, int, irev
 
  equivalence(cint,int)
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
 
    call x84(nbits,my_nbits,1)
    iret = iupm(cbay,my_nbits)
 
    im8b=.true.
    return
  endif
 
  iret = 0
  if(nbits>nbitw) then
    write(bort_str,'("BUFRLIB: IUPM - NUMBER OF BITS BEING UNPACKED'// &
      ', NBITS (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS MACHINE, NBITW (",I3,")")') nbits,nbitw
    call bort(bort_str)
  endif
  cint = cbay
  int = irev(int)
  iret = ishft(int,nbits-nbitw)
 
  return
end function iupm
 
real*8 function ups(ival,node) result(r8ret)
 
  use moda_tables
  use moda_nrv203
 
  implicit none
 
  integer*8, intent(in) :: ival
  integer*8 imask
  integer, intent(in) :: node
  integer jj
 
  real*8, parameter :: ten = 10.
 
  r8ret = ( ival + irf(node) ) * ten**(-isc(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 may be encoded as positive
        ! integers with the left-most bit set to 1.
        imask = 2_8**(ibt(node)-1)
        if ( iand(ival,imask) > 0 ) then
          nrv(jj) = (-1) * ( ival - imask )
        else
          nrv(jj) = ival
        end if
        r8ret = nrv(jj)
        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 decoding this value.
        r8ret = ( ival + nrv(jj) ) * ten**(-isc(node))
        return
      end if
    end do
  end if
 
  return
end function ups