var/external/bufr/upftbv.f

   1       SUBROUTINE UPFTBV(LUNIT,NEMO,VAL,MXIB,IBIT,NIB)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UPFTBV
   6 C   PRGMMR: JATOR            ORG: NP12       DATE: 2005-11-29
   7 C
   8 C ABSTRACT:  GIVEN A MNEMONIC OF TYPE "FLAG TABLE" ALONG WITH ITS
   9 C   CORRESPONDING VALUE, THIS SUBROUTINE DETERMINES THE BIT SETTINGS
  10 C   EQUIVALANT TO THAT VALUE.  NOTE THAT THIS SUBROUTINE IS THE
  11 C   LOGICAL INVERSE OF BUFRLIB SUBROUTINE PKFTBV.
  12 C
  13 C PROGRAM HISTORY LOG:
  14 C 2005-11-29  J. ATOR    -- ORIGINAL VERSION
  15 C
  16 C USAGE:    UPFTBV (LUNIT,NEMO,VAL,MXIB,IBIT,NIB)
  17 C   INPUT ARGUMENT LIST:
  18 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  19 C     NEMO     - CHARACTER*(*): MNEMONIC OF TYPE "FLAG TABLE"
  20 C     VAL      - REAL*8: VALUE CORRESPONDING TO NEMO
  21 C     MXIB     - INTEGER: DIMENSIONED SIZE OF IBIT IN CALLING PROGRAM
  22 C
  23 C   OUTPUT ARGUMENT LIST:
  24 C     IBIT     - INTEGER(*): BIT NUMBERS WHICH WERE SET TO "ON"
  25 C                (I.E. SET TO "1") IN VAL
  26 C     NIB      - INTEGER: NUMBER OF BIT NUMBERS RETURNED IN IBIT
  27 C
  28 C REMARKS:
  29 C    THIS ROUTINE CALLS:        BORT     NEMTAB   STATUS   VALX
  30 C    THIS ROUTINE IS CALLED BY: UFBDMP   UFDUMP
  31 C                               Also called by application programs.
  32 C
  33 C ATTRIBUTES:
  34 C   LANGUAGE: FORTRAN 77
  35 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  36 C
  37 C$$$
  38
  39       INCLUDE 'bufrlib.prm'
  40
  41       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
  42      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
  43      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
  44      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
  45      .                TABD(MAXTBD,NFILES)
  46
  47       REAL*8  VAL,R8VAL,R82I
  48
  49       INTEGER IBIT (*)
  50
  51       CHARACTER*(*) NEMO
  52       CHARACTER*600 TABD
  53       CHARACTER*128 TABB
  54       CHARACTER*128 TABA
  55       CHARACTER*128 BORT_STR
  56       CHARACTER*1   TAB
  57
  58 C----------------------------------------------------------------------
  59 C----------------------------------------------------------------------
  60
  61 C     Perform some sanity checks.
  62
  63       CALL STATUS(LUNIT,LUN,IL,IM)
  64       IF(IL.EQ.0) GOTO 900
  65
  66       CALL NEMTAB(LUN,NEMO,IDN,TAB,N)
  67       IF(N.EQ.0) GOTO 901
  68       IF(TABB(N,LUN)(71:74).NE.'FLAG') GOTO 902
  69
  70 C     Figure out which bits are set.
  71
  72       NIB = 0
  73       R8VAL = VAL
  74       NBITS = VALX(TABB(N,LUN)(110:112))
  75       DO I=(NBITS-1),0,-1
  76           R82I = (2.)**I
  77           IF(ABS(R8VAL-R82I).LT.(0.005)) THEN
  78               NIB = NIB + 1
  79               IF(NIB.GT.MXIB) GOTO 903
  80               IBIT(NIB) = NBITS-I
  81               RETURN
  82           ELSEIF(R82I.LT.R8VAL) THEN
  83               NIB = NIB + 1
  84               IF(NIB.GT.MXIB) GOTO 903
  85               IBIT(NIB) = NBITS-I
  86               R8VAL = R8VAL - R82I
  87           ENDIF
  88       ENDDO
  89
  90       RETURN
  91 900   CALL BORT('BUFRLIB: UPFTBV - INPUT BUFR FILE IS CLOSED, IT '//
  92      . 'MUST BE OPEN FOR INPUT')
  93 901   WRITE(BORT_STR,'("BUFRLIB: UPFTBV - MNEMONIC ",A,'//
  94      . '" NOT FOUND IN TABLE B")') NEMO
  95       CALL BORT(BORT_STR)
  96 902   WRITE(BORT_STR,'("BUFRLIB: UPFTBV - MNEMONIC ",A,'//
  97      . '" IS NOT A FLAG TABLE")') NEMO
  98       CALL BORT(BORT_STR)
  99 903   CALL BORT('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW')
 100       END