upftbv.f

Go to the documentation of this file.

C> @file
C> @brief Determine the bit settings equivalent to a numerical flag table value.
C>
C> @author J. Ator @date 2005-11-29
 
C> Given a Table B mnemonic with flag table units and a
C> corresponding numerical data value, this subroutine determines
C> the bit settings equivalent to that numerical value.
C>
C> This subroutine is the logical inverse of function pkftbv().
C>
C> According to the WMO standard, bits within a bit field are
C> numbered from left to right, so bit #1 is always the high-order
C> (i.e. most significant) bit in any bit field.
C>
C> @param[in]  LUNIT - integer: Fortran logical unit number for BUFR file.
C> @param[in]  NEMO - character*(*): Table B mnemonic with flag table units.
C> @param[in]  VAL - real*8: Value corresponding to NEMO.
C> @param[in]  MXIB - integer: Dimensioned size (in integers) of IBIT in the calling
C> program; used by the subroutine to ensure that it doesn't overflow the IBIT array.
C> @param[out] IBIT - integer: Bit numbers which were set to "On" (i.e. set to "1")
C> in VAL.
C> @param[out] NIB - integer: Number of bit numbers returned in IBIT.
C>
C> @author J. Ator @date 2005-11-29
 
      RECURSIVE SUBROUTINE upftbv(LUNIT,NEMO,VAL,MXIB,IBIT,NIB)
 
      USE modv_im8b
 
      USE moda_tababd
 
      real*8  val, r8val, r82i
 
      INTEGER ibit(*), nib(*)
 
      CHARACTER*(*) nemo
      CHARACTER*128 bort_str
      CHARACTER*1   tab
 
C----------------------------------------------------------------------
C----------------------------------------------------------------------
 
C     Check for I8 integers.
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL x84(mxib,my_mxib,1)
         CALL upftbv( my_lunit, nemo, val, my_mxib*2, ibit, nib )
         CALL x48(ibit,ibit,nib(1))
         CALL x48(nib,nib,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
C     Perform some sanity checks.
 
      CALL status(lunit,lun,il,im)
      IF(il.EQ.0) GOTO 900
 
      CALL nemtab(lun,nemo,idn,tab,n)
      IF(n.EQ.0) GOTO 901
      IF(tabb(n,lun)(71:74).NE.'FLAG') GOTO 902
 
C     Figure out which bits are set.
 
      nib(1) = 0
      r8val = val
      CALL strnum(tabb(n,lun)(110:112),nbits,iersn)
      DO i=(nbits-1),0,-1
          r82i = (2.)**i
          IF(abs(r8val-r82i).LT.(0.005)) THEN
              nib(1) = nib(1) + 1
              IF(nib(1).GT.mxib) GOTO 903
              ibit(nib(1)) = nbits-i
              RETURN
          ELSEIF(r82i.LT.r8val) THEN
              nib(1) = nib(1) + 1
              IF(nib(1).GT.mxib) GOTO 903
              ibit(nib(1)) = nbits-i
              r8val = r8val - r82i
          ENDIF
      ENDDO
 
      RETURN
900   CALL bort('BUFRLIB: UPFTBV - INPUT BUFR FILE IS CLOSED, IT '//
     . 'MUST BE OPEN FOR INPUT')
901   WRITE(bort_str,'("BUFRLIB: UPFTBV - MNEMONIC ",A,'//
     . '" NOT FOUND IN TABLE B")') nemo
      CALL bort(bort_str)
902   WRITE(bort_str,'("BUFRLIB: UPFTBV - MNEMONIC ",A,'//
     . '" IS NOT A FLAG TABLE")') nemo
      CALL bort(bort_str)
903   CALL bort('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW')
      END