var/external/bufr/reads3.f

   1         SUBROUTINE READS3 ( LUN )
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    READS3
   6 C   PRGMMR: ATOR             ORG: NP12       DATE: 2009-03-23
   7 C
   8 C ABSTRACT: THIS SUBROUTINE READS THE SECTION 3 DESCRIPTORS FROM THE
   9 C   BUFR MESSAGE IN MBAY(1,LUN).  IT THEN USES THE BUFR MASTER TABLES
  10 C   TO GENERATE THE NECESSARY INFORMATION FOR THESE DESCRIPTORS WITHIN
  11 C   THE INTERNAL BUFR TABLE ARRAYS.
  12 C
  13 C PROGRAM HISTORY LOG:
  14 C 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR
  15 C
  16 C USAGE:    CALL READS3 (LUN)
  17 C   INPUT ARGUMENT LIST:
  18 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  19 C
  20 C REMARKS:
  21 C    THIS ROUTINE CALLS:        ADN30    BORT     DXINIT   ERRWRT
  22 C                               IGETNTBI IGETTDI  ISTDESC  IUPBS01
  23 C                               MAKESTAB READMT   STNTBIA  STSEQ
  24 C                               UPDS3
  25 C    THIS ROUTINE IS CALLED BY: READERME READMG
  26 C                               Normally not called by any application
  27 C                               programs.
  28 C
  29 C ATTRIBUTES:
  30 C   LANGUAGE: FORTRAN 77
  31 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  32 C
  33 C$$$
  34
  35         INCLUDE 'bufrlib.prm'
  36
  37         COMMON /QUIET/  IPRT
  38         COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES),IRDMT
  39         COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  40      .                  MBAY(MXMSGLD4,NFILES)
  41         COMMON /DSCACH/ NCNEM,CNEM(MXCNEM),NDC(MXCNEM),
  42      .                  IDCACH(MXCNEM,MAXNC)
  43
  44         DIMENSION       IDS3(MAXNC)
  45         CHARACTER*6     CDS3(MAXNC),NUMB,ADN30
  46
  47         CHARACTER*8     CNEM,TAMNEM
  48         CHARACTER*55    CSEQ
  49
  50         CHARACTER*128   ERRSTR
  51
  52         LOGICAL         INCACH, ALLSTD
  53
  54 C*      Initializing the following value ensures that new master tables
  55 C*      are read during the first call to this subroutine.
  56
  57         DATA    LMT /-99/
  58
  59         SAVE    LMT, LMTV, LOGCE, LMTVL, IREPCT
  60
  61 C-----------------------------------------------------------------------
  62 C-----------------------------------------------------------------------
  63
  64 C*      Unpack some Section 1 information from the message.
  65
  66         IMT  = IUPBS01 ( MBAY(1,LUN), 'BMT' )
  67         IMTV = IUPBS01 ( MBAY(1,LUN), 'MTV' )
  68         IOGCE = IUPBS01 ( MBAY(1,LUN), 'OGCE' )
  69         IMTVL = IUPBS01 ( MBAY(1,LUN), 'MTVL' )
  70
  71 C*      Unpack the list of Section 3 descriptors from the message.
  72
  73         CALL UPDS3 ( MBAY(1,LUN), MAXNC, CDS3, NCDS3 )
  74         DO II = 1, NCDS3
  75           IDS3(II) = IFXY( CDS3(II) )
  76         ENDDO
  77
  78 C*      Compare the master table and master table version numbers from
  79 C*      this message to those from the message that was processed during
  80 C*      the previous call to this subroutine.
  81
  82         IF (  ( IMT .NE. LMT )
  83      .          .OR.
  84      .      ( ( IMT .NE. 0 ) .AND. ( IMTV .NE. LMTV ) )
  85      .          .OR.
  86      .      ( ( IMT .EQ. 0 ) .AND. ( IMTV .NE. LMTV ) .AND.
  87      .        ( ( IMTV .GT. 13 ) .OR. ( LMTV .GT. 13 ) ) )  )
  88      .    THEN
  89
  90 C*        Either the master table number has changed
  91 C*              .OR.
  92 C*        The master table number hasn't changed, but it isn't 0, and
  93 C*        the table version number has changed
  94 C*              .OR.
  95 C*        The master table number hasn't changed and is 0, but the table
  96 C*        version number has changed, and at least one of the table
  97 C*        version numbers (i.e. the current or the previous) is greater
  98 C*        than 13 (which is the last version that was a superset of all
  99 C*        earlier versions of master table 0!)
 100
 101 C*        In any of these cases, we need to read in new tables and reset
 102 C*        the internal tables and local descriptor cache, since the
 103 C*        meanings of one or more Section 3 descriptors may have changed.
 104
 105           CALL READMT ( IMT, IMTV, IOGCE, IMTVL )
 106           LMT  = IMT
 107           LMTV = IMTV
 108           LOGCE = IOGCE
 109           LMTVL = IMTVL
 110           CALL DXINIT ( LUN, 0 )
 111           IREPCT = 0
 112           NCNEM = 0
 113         ELSE
 114
 115 C*        Check whether all of the Section 3 descriptors are standard.
 116 C*        If so, then the originating center and local table version
 117 C*        numbers are irrelevant as far as Section 3 is concerned.
 118
 119           II = 1
 120           ALLSTD = .TRUE.
 121           DO WHILE ( (ALLSTD) .AND. (II.LE.NCDS3) )
 122             IF ( ISTDESC(IDS3(II)) .EQ. 0 ) THEN
 123               ALLSTD = .FALSE.
 124             ELSE
 125               II = II + 1
 126             ENDIF
 127           ENDDO
 128           IF ( .NOT. ALLSTD ) THEN
 129
 130 C*          There was at least one local (i.e. non-standard) descriptor,
 131 C*          so check whether the originating center and/or local table
 132 C*          version number are different than those from the message
 133 C*          that was processed during the previous call to this
 134 C*          subroutine.  If so, then read in new tables and reset the
 135 C*          internal tables and local descriptor cache, since the
 136 C*          meanings of one or more local descriptors in Section 3 may
 137 C*          have changed.
 138
 139             IF ( ( IOGCE .NE. LOGCE ) .OR. ( IMTVL .NE. LMTVL ) )  THEN
 140               CALL READMT ( IMT, IMTV, IOGCE, IMTVL )
 141               LMT  = IMT
 142               LMTV = IMTV
 143               LOGCE = IOGCE
 144               LMTVL = IMTVL
 145               CALL DXINIT ( LUN, 0 )
 146               IREPCT = 0
 147               NCNEM = 0
 148             ENDIF
 149           ENDIF
 150         ENDIF
 151
 152 C*      Is the list of Section 3 descriptors already in the cache?
 153
 154 C*      The cache is a performance-enhancing device which saves
 155 C*      time when the same descriptor sequences are encountered
 156 C*      over and over within the calling program.  Time is saved
 157 C*      because the below calls to subroutines STSEQ and MAKESTAB
 158 C*      are bypassed whenever a list is already in the cache.
 159
 160         INCACH = .FALSE.
 161         IF ( NCNEM .GT. 0 ) THEN
 162           II = 1
 163           DO WHILE ( (.NOT.INCACH) .AND. (II.LE.NCNEM) )
 164             IF ( NCDS3 .EQ. NDC(II) ) THEN
 165               JJ = 1
 166               INCACH = .TRUE.
 167               DO WHILE ( (INCACH) .AND. (JJ.LE.NCDS3) )
 168                 IF ( IDS3(JJ) .EQ. IDCACH(II,JJ) ) THEN
 169                   JJ = JJ + 1
 170                 ELSE
 171                   INCACH = .FALSE.
 172                 ENDIF
 173               ENDDO
 174               IF (INCACH) THEN
 175
 176 C*              The list is already in the cache, so store the
 177 C*              corresponding Table A mnemonic into COMMON /SC3BFR/
 178 C*              and return.
 179
 180                 IF ( IPRT .GE. 2 ) THEN
 181         CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++')
 182         ERRSTR = 'BUFRLIB: READS3 - RE-USED CACHE LIST FOR ' // CNEM(II)
 183         CALL ERRWRT(ERRSTR)
 184         CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++')
 185         CALL ERRWRT(' ')
 186                 ENDIF
 187                 TAMNEM(LUN) = CNEM(II)
 188                 RETURN
 189               ENDIF
 190             ENDIF
 191             II = II + 1
 192           ENDDO
 193         ENDIF
 194
 195 C*      Get the next available index within the internal Table A.
 196
 197         N = IGETNTBI ( LUN, 'A' )
 198
 199 C*      Generate a Table A mnemonic and sequence description.
 200
 201         WRITE ( TAMNEM(LUN), '(A5,I3.3)') 'MSTTB', N
 202         CSEQ = 'TABLE A MNEMONIC ' // TAMNEM(LUN)
 203
 204 C*      Store the Table A mnemonic and sequence into the cache.
 205
 206         NCNEM = NCNEM + 1
 207         IF ( NCNEM .GT. MXCNEM ) GOTO 900
 208         CNEM(NCNEM) = TAMNEM(LUN)
 209         NDC(NCNEM) = NCDS3
 210         DO JJ = 1, NCDS3
 211           IDCACH(NCNEM,JJ) = IDS3(JJ)
 212         ENDDO
 213         IF ( IPRT .GE. 2 ) THEN
 214         CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++')
 215         ERRSTR = 'BUFRLIB: READS3 - STORED CACHE LIST FOR ' //
 216      .    CNEM(NCNEM)
 217         CALL ERRWRT(ERRSTR)
 218         CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++')
 219         CALL ERRWRT(' ')
 220         ENDIF
 221
 222 C*      Get an FXY value to use with this Table A mnemonic.
 223
 224         IDN = IGETTDI ( LUN )
 225         NUMB = ADN30 ( IDN, 6 )
 226
 227 C*      Store all of the information for this mnemonic within the
 228 C*      internal Table A.
 229
 230         CALL STNTBIA ( N, LUN, NUMB, TAMNEM(LUN), CSEQ )
 231
 232 C*      Store all of the information for this sequence within the
 233 C*      internal Tables B and D.
 234
 235         CALL STSEQ ( LUN, IREPCT, IDN, TAMNEM(LUN), CSEQ, IDS3, NCDS3 )
 236
 237 C*      Update the jump/link table.
 238
 239         CALL MAKESTAB
 240
 241         RETURN
 242 900     CALL BORT('BUFRLIB: READS3 - MXCNEM OVERFLOW')
 243         END