cpdxmm.f

Go to the documentation of this file.

C> @file
C> Read embedded DX BUFR table into internal arrays.

C> This subroutine reads an entire DX BUFR table from a specified
C> file into internal arrays.
C>
C> @author J. Ator
C> @date 2009-03-23
C>
C> @param[in] LUNIT   -- integer: Fortran logical unit number for BUFR
C>                       file
C>
C> <b>Program history log:</b>
C> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 2009-03-23 | J. Ator    | Original author |
C> | 2012-09-15 | J. Woollen | Modified for C/I/O/BUFR interface; replace Fortran BACKSPACE with C backbufr() |
C> | 2014-12-10 | J. Ator    | Use modules instead of COMMON blocks |
C>
    SUBROUTINE cpdxmm( LUNIT )

    USE moda_mgwa
    USE moda_msgmem

    COMMON /quiet/  iprt

    character*128   errstr

    LOGICAL done

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

    IF ( ndxts .GE. mxdxts ) goto 900

    ict = 0
    done = .false.
        CALL status(lunit,lun,il,im)

C   Read a complete dictionary table from LUNIT, as a set of one or
C   more DX dictionary messages.

    DO WHILE ( .NOT. done )
          CALL rdmsgw( lunit, mgwa, ier )
          IF ( ier .EQ. -1 ) THEN

C       Don't abort for an end-of-file condition, since it may be
C       possible for a file to end with dictionary messages.
C       Instead, backspace the file pointer and let the calling
C       routine diagnose the end-of-file condition and deal with
C       it as it sees fit.

        CALL backbufr(lun) 
        done = .true.
          ELSE IF ( ier .EQ. -2 ) THEN
        goto 901
      ELSE IF ( idxmsg(mgwa) .NE. 1 ) THEN

C       This is a non-DX dictionary message.  Assume we've reached
C       the end of the dictionary table, and backspace LUNIT so that
C       the next read (e.g. in the calling routine) will get this
C       same message.

        CALL backbufr(lun) 
        done = .true.
      ELSE IF ( iupbs3(mgwa,'NSUB') .EQ. 0 ) THEN

C       This is a DX dictionary message, but it doesn't contain any
C       actual dictionary information.  Assume we've reached the end
C       of the dictionary table.

        done = .true.
      ELSE

C       Store this message into MODULE MSGMEM.

            ict = ict + 1
        IF ( ( ndxm + ict ) .GT. mxdxm ) goto 902
            ipdxm(ndxm+ict) = ldxm + 1
            lmem = nmwrd(mgwa)
        IF ( ( ldxm + lmem ) .GT. mxdxw ) goto 903
            DO j = 1, lmem
              mdx(ldxm+j) = mgwa(j)
            ENDDO
            ldxm = ldxm + lmem
          ENDIF
    ENDDO

C   Update the table information within MODULE MSGMEM.

    IF ( ict .GT. 0 ) THEN
          ifdxts(ndxts+1) = ndxm + 1
          icdxts(ndxts+1) = ict
          ipmsgs(ndxts+1) = msgp(0) + 1
          ndxm = ndxm + ict
          ndxts = ndxts + 1
      IF ( iprt .GE. 2 ) THEN
        CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
        WRITE ( unit=errstr, fmt='(A,I3,A,I3,A)') 
     .      'BUFRLIB: CPDXMM - STORED NEW DX TABLE #', ndxts,
     .      ' CONSISTING OF ', ict, ' MESSAGES'
        CALL errwrt(errstr)
        CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
            CALL errwrt(' ')
      ENDIF
    ENDIF

    RETURN
 900    CALL bort('BUFRLIB: CPDXMM - MXDXTS OVERFLOW')
 901    CALL bort('BUFRLIB: CPDXMM - UNEXPECTED READ ERROR')
 902    CALL bort('BUFRLIB: CPDXMM - MXDXM OVERFLOW')
 903    CALL bort('BUFRLIB: CPDXMM - MXDXW OVERFLOW')
    END