var/external/bufr/numtbd.f

   1       SUBROUTINE NUMTBD(LUN,IDN,NEMO,TAB,IRET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    NUMTBD
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2002-05-14
   7 C
   8 C ABSTRACT: THIS SUBROUTINE SEARCHES FOR AN INTEGER IDN, CONTAINING THE
   9 C   BIT-WISE REPRESENTATION OF A DESCRIPTOR (FXY) VALUE, WITHIN THE
  10 C   INTERNAL BUFR TABLE B AND D ARRAYS IN COMMON BLOCK /TABABD/.  IF
  11 C   FOUND, IT RETURNS THE CORRESPONDING MNEMONIC AND OTHER INFORMATION
  12 C   FROM WITHIN THESE ARRAYS.  IF IDN IS NOT FOUND, IT RETURNS WITH
  13 C   IRET=0.
  14 C
  15 C PROGRAM HISTORY LOG:
  16 C 2002-05-14  J. WOOLLEN -- ORIGINAL AUTHOR
  17 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  18 C                           INTERDEPENDENCIES
  19 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  20 C                           DOCUMENTATION (INCLUDING HISTORY)
  21 C 2009-04-21  J. ATOR    -- USE IFXY FOR MORE EFFICIENT SEARCHING
  22 C
  23 C USAGE:    CALL NUMTBD (LUN, IDN, NEMO, TAB, IRET)
  24 C   INPUT ARGUMENT LIST:
  25 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  26 C     IDN      - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY)
  27 C                VALUE
  28 C
  29 C   OUTPUT ARGUMENT LIST:
  30 C     NEMO     - CHARACTER*(*): MNEMONIC CORRESPONDING TO IDN
  31 C     TAB      - CHARACTER*1: TYPE OF FXY VALUE THAT IS BIT-WISE
  32 C                REPRESENTED BY IDN:
  33 C                     'B' = BUFR Table B descriptor
  34 C                     'D' = BUFR Table D descriptor
  35 C     IRET     - INTEGER: RETURN VALUE (SEE REMARKS)
  36 C
  37 C REMARKS:
  38 C    THE INTERPRETATION OF THE RETURN VALUE IRET DEPENDS UPON THE
  39 C    RETURN VALUE OF TAB, AS FOLLOWS:
  40 C
  41 C    IF ( TAB = 'B' ) THEN
  42 C       IRET = positional index of IDN within internal BUFR Table B
  43 C              array
  44 C    ELSE IF ( TAB = 'D') THEN
  45 C       IRET = positional index of IDN within internal BUFR Table D
  46 C              array
  47 C    ELSE IF ( IRET = 0 ) THEN
  48 C       IDN was not found in internal BUFR Table B or D
  49 C    END IF
  50 C
  51 C
  52 C    THIS ROUTINE CALLS:        IFXY
  53 C    THIS ROUTINE IS CALLED BY: NUMTAB   RESTD    STSEQ
  54 C                               Normally not called by any application
  55 C                               programs.
  56 C
  57 C ATTRIBUTES:
  58 C   LANGUAGE: FORTRAN 77
  59 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  60 C
  61 C$$$
  62
  63       INCLUDE 'bufrlib.prm'
  64
  65       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
  66      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
  67      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
  68      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
  69      .                TABD(MAXTBD,NFILES)
  70
  71       CHARACTER*(*) NEMO
  72       CHARACTER*600 TABD
  73       CHARACTER*128 TABB
  74       CHARACTER*128 TABA
  75       CHARACTER*1   TAB
  76
  77 C-----------------------------------------------------------------------
  78 C-----------------------------------------------------------------------
  79
  80       NEMO = ' '
  81       IRET = 0
  82       TAB = ' '
  83
  84       IF(IDN.GE.IFXY('300000')) THEN
  85
  86 C        LOOK FOR IDN IN TABLE D
  87 C        -----------------------
  88
  89          DO I=1,NTBD(LUN)
  90             IF(IDN.EQ.IDND(I,LUN)) THEN
  91                NEMO = TABD(I,LUN)(7:14)
  92                TAB  = 'D'
  93                IRET = I
  94                GOTO 100
  95             ENDIF
  96          ENDDO
  97
  98       ELSE
  99
 100 C        LOOK FOR IDN IN TABLE B
 101 C        -----------------------
 102
 103          DO I=1,NTBB(LUN)
 104             IF(IDN.EQ.IDNB(I,LUN)) THEN
 105                NEMO = TABB(I,LUN)(7:14)
 106                TAB  = 'B'
 107                IRET = I
 108                GOTO 100
 109             ENDIF
 110          ENDDO
 111
 112       ENDIF
 113
 114 C  EXIT
 115 C  ----
 116
 117 100   RETURN
 118       END