upftbv.f

Go to the documentation of this file.

C> @file
C> @brief Determine the bit settings equivalent to a numerical
C> flag table value.

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> @author J. Ator
C> @date 2005-11-29
C>
C> @param[in] LUNIT -- integer: Fortran logical unit number for
C>                     BUFR file
C> @param[in] NEMO  -- character*(*): Table B mnemonic with
C>                     flag table units
C> @param[in] VAL   -- real*8: Value corresponding to NEMO
C> @param[in] MXIB  -- integer: Dimensioned size (in integers) of
C>                     IBIT; used by the subroutine to ensure that
C>                     it doesn't overflow the IBIT array
C> @param[out] IBIT -- integer(*): Bit numbers which were set to
C>                     "On" (i.e. set to "1") in VAL
C> @param[out] NIB  -- integer: Number of bit numbers returned in
C>                     IBIT
C>
C> @remarks
C> - This subroutine is the logical inverse of function pkftbv().
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> <b>Program history log:</b>
C> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 2005-11-29 | J. Ator | Original version |
C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
C>
      SUBROUTINE upftbv(LUNIT,NEMO,VAL,MXIB,IBIT,NIB)

      USE moda_tababd

      REAL*8  val,r8val,r82i

      INTEGER ibit (*)

      CHARACTER*(*) nemo
      CHARACTER*128 bort_str
      CHARACTER*1   tab

C----------------------------------------------------------------------
C----------------------------------------------------------------------

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 = 0
      r8val = val
      nbits = valx(tabb(n,lun)(110:112))
      DO i=(nbits-1),0,-1
          r82i = (2.)**i
          IF(abs(r8val-r82i).LT.(0.005)) THEN
              nib = nib + 1
              IF(nib.GT.mxib) goto 903
              ibit(nib) = nbits-i
              RETURN
          ELSEIF(r82i.LT.r8val) THEN
              nib = nib + 1
              IF(nib.GT.mxib) goto 903
              ibit(nib) = 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