reads3.f

Go to the documentation of this file.

C> @file
C> @author ATOR @date 2009-03-23
    
C> THIS SUBROUTINE READS THE SECTION 3 DESCRIPTORS FROM THE
C>   BUFR MESSAGE IN MBAY(1,LUN).  IT THEN USES THE BUFR MASTER TABLES
C>   TO GENERATE THE NECESSARY INFORMATION FOR THESE DESCRIPTORS WITHIN
C>   THE INTERNAL BUFR TABLE ARRAYS.
C>
C> PROGRAM HISTORY LOG:
C> 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> 2017-10-13  J. ATOR    -- REMOVE FUNCTIONALITY TO CHECK WHETHER NEW
C>                           MASTER TABLES NEED TO BE READ (THIS
C>                           FUNCTIONALITY IS NOW PART OF FUNCTION
C>                           IREADMT)

C>
C> USAGE:    CALL READS3 ( LUN )
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        ADN30    BORT     DXINIT   ERRWRT
C>                               IFXY     IGETNTBI IGETTDI  IREADMT
C>                               MAKESTAB STNTBIA  STSEQ    UPDS3
C>    THIS ROUTINE IS CALLED BY: READERME READMG
C>                               Normally not called by any application
C>                               programs.
C>
    SUBROUTINE reads3 ( LUN )

    USE moda_sc3bfr
    USE moda_bitbuf
        USE moda_dscach

    COMMON /quiet/  iprt

    dimension   ids3(maxnc)
    character*6 cds3(maxnc),numb,adn30

    character*55    cseq

    character*128   errstr

    logical     incach

    SAVE    irepct

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

C*  Check whether the appropriate BUFR master table information has
C*  already been read into internal memory for this message.

    IF ( ireadmt( lun ) .EQ. 1 ) THEN

C*    NO (i.e. we just had to read in new master table information
C*    for this message), so reset some corresponding values in
C*    other parts of the library.

      CALL dxinit( lun, 0 )
      itmp = igettdi( 0 )
      irepct = 0
      ncnem = 0
    ENDIF

C*  Unpack the list of Section 3 descriptors from the message.

    CALL upds3( mbay(1,lun), maxnc, cds3, ncds3 )
    DO ii = 1, ncds3
      ids3(ii) = ifxy( cds3(ii) )
    ENDDO

C*  Is the list of Section 3 descriptors already in the cache?

C*  The cache is a performance-enhancing device which saves
C*  time when the same descriptor sequences are encountered
C*  over and over within the calling program.  Time is saved
C*  because the below calls to subroutines STSEQ and MAKESTAB
C*  are bypassed whenever a list is already in the cache.

    incach = .false.
    IF ( ncnem .GT. 0 ) THEN
      ii = 1
      DO WHILE ( (.NOT.incach) .AND. (ii.LE.ncnem) )
        IF ( ncds3 .EQ. ndc(ii) ) THEN
          jj = 1
          incach = .true.
          DO WHILE ( (incach) .AND. (jj.LE.ncds3) )
        IF ( ids3(jj) .EQ. idcach(ii,jj) ) THEN
          jj = jj + 1
        ELSE
          incach = .false.
        ENDIF
          ENDDO
          IF (incach) THEN

C*      The list is already in the cache, so store the
C*      corresponding Table A mnemonic into MODULE SC3BFR
C*      and return.

        IF ( iprt .GE. 2 ) THEN
    CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++')
    errstr = 'BUFRLIB: READS3 - RE-USED CACHE LIST FOR ' // cnem(ii)
    CALL errwrt(errstr)
    CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++')
        CALL errwrt(' ')
        ENDIF
        tamnem(lun) = cnem(ii)
        RETURN
          ENDIF
        ENDIF
        ii = ii + 1
      ENDDO
    ENDIF

C*  Get the next available index within the internal Table A.

    n = igetntbi( lun, 'A' )

C*  Generate a Table A mnemonic and sequence description.

    WRITE ( tamnem(lun), '(A5,I3.3)') 'MSTTB', n
    cseq = 'TABLE A MNEMONIC ' // tamnem(lun)

C*  Store the Table A mnemonic and sequence into the cache.

    ncnem = ncnem + 1
    IF ( ncnem .GT. mxcnem ) goto 900
    cnem(ncnem) = tamnem(lun)
    ndc(ncnem) = ncds3
    DO jj = 1, ncds3
      idcach(ncnem,jj) = ids3(jj)
    ENDDO
    IF ( iprt .GE. 2 ) THEN
    CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++')
    errstr = 'BUFRLIB: READS3 - STORED CACHE LIST FOR ' //
     .    cnem(ncnem)
    CALL errwrt(errstr)
    CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++')
        CALL errwrt(' ')
    ENDIF

C*  Get an FXY value to use with this Table A mnemonic.
  
    idn = igettdi( lun )
    numb = adn30( idn, 6 )

C*  Store all of the information for this mnemonic within the
C*  internal Table A.

    CALL stntbia( n, lun, numb, tamnem(lun), cseq )

C*  Store all of the information for this sequence within the
C*  internal Tables B and D.

    CALL stseq( lun, irepct, idn, tamnem(lun), cseq, ids3, ncds3 )

C*  Update the jump/link table.

    CALL makestab

    RETURN
900 CALL bort('BUFRLIB: READS3 - MXCNEM OVERFLOW')
    END