iok2cpy.f

Go to the documentation of this file.

C> @file
C> @brief Check whether a BUFR message or data subset can be copied
C> from one BUFR file to another.
 
C> This function determines whether a BUFR message, or a data subset
C> from within a BUFR message, can be copied from one Fortran logical
C> unit to another.
C>
C> <p>The decision is based on whether both logical units contain
C> identical definitions for the BUFR message type in question within
C> their associated [DX BUFR Table information](@ref dfbftab).
C> Note that it's possible for a BUFR message type to be identically
C> defined for two different logical units even if the full set of
C> associated DX BUFR table information isn't identical between both
C> units.
C>
C> @author J. Ator
C> @date 2009-06-26
C>
C> @param[in]  LUI     -- integer: Internal I/O stream index associated
C>                        with source BUFR file
C> @param[in]  LUO     -- integer: Internal I/O stream index associated
C>                        with target BUFR file
C> @returns iok2cpy    -- integer: Flag indicating whether a BUFR
C>                        message or data subset can be copied from the
C>                        BUFR file associated with LUI to the BUFR file
C>                        associated with LUO
C>                        - 0 = No
C>                        - 1 = Yes
C>
C> <b>Program history log:</b>
C> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 2009-06-26 | J. Ator | Original author |
C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
C>
      INTEGER FUNCTION iok2cpy(LUI,LUO)
 
      USE moda_msgcwd
      USE moda_tables
 
      CHARACTER*8  subset
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
      iok2cpy = 0
 
C     Do both logical units have the same internal table information?
 
      IF ( icmpdx(lui,luo) .EQ. 1 ) THEN
    iok2cpy = 1
    RETURN
      ENDIF
 
C     No, so get the Table A mnemonic from the message to be copied,
C     then check whether that mnemonic is defined within the dictionary
C     tables for the logical unit to be copied to.
 
      subset = tag(inode(lui))
      CALL nemtbax(luo,subset,mtyp,msbt,inod)
      IF ( inod .EQ. 0 ) RETURN
 
C     The Table A mnemonic is defined within the dictionary tables for
C     both units, so now make sure the definitions are identical.
 
      ntei = isc(inode(lui))-inode(lui)
      nteo = isc(inod)-inod
      IF ( ntei .NE. nteo ) RETURN
 
      DO i = 1, ntei
        IF ( tag(inode(lui)+i) .NE. tag(inod+i) ) RETURN
        IF ( typ(inode(lui)+i) .NE. typ(inod+i) ) RETURN
        IF ( isc(inode(lui)+i) .NE. isc(inod+i) ) RETURN
        IF ( irf(inode(lui)+i) .NE. irf(inod+i) ) RETURN
        IF ( ibt(inode(lui)+i) .NE. ibt(inod+i) ) RETURN
      ENDDO
 
      iok2cpy = 1
 
      RETURN
      END