invmrg.f

Go to the documentation of this file.

C> @file
C> @brief Merge parts of data subsets
C>
C> @author J. Woollen @date 1996-10-09
 
C> This subroutine merges parts of data subsets which have duplicate
C> space and time coordinates but different or unique observational data.
C>
C> @param[in] LUBFI   -- integer: Fortran logical unit number for input
C>                       BUFR file
C> @param[in] LUBFJ   -- integer: Fortran logical unit number for output
C>                       BUFR file
C>
C> Logical unit LUBFI should have already been opened for input
C> operations via a previous call to subroutine openbf().
C>
C> Logical unit LUBFJ should have already been opened for output
C> operations via a previous call to subroutine openbf().
C>
C> @remarks
C> - This subroutine cannot merge parts of data subsets which are
C> contained within replication sequences.
C>
C> @author J. Woollen @date 1996-10-09
      RECURSIVE SUBROUTINE invmrg(LUBFI,LUBFJ)
 
      USE moda_usrint
      USE moda_tables
      USE modv_im8b
 
      COMMON /mrgcom/ nrpl,nmrg,namb,ntot
 
      CHARACTER*128 bort_str
      LOGICAL       herei,herej,missi,missj,samei
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lubfi,my_lubfi,1)
         CALL x84(lubfj,my_lubfj,1)
         CALL invmrg(my_lubfi,my_lubfj)
 
         im8b=.true.
         RETURN
      ENDIF
 
      is = 1
      js = 1
 
C  GET THE UNIT POINTERS
C  ---------------------
 
      CALL status(lubfi,luni,il,im)
      CALL status(lubfj,lunj,jl,jm)
 
C  STEP THROUGH THE BUFFERS COMPARING THE INVENTORY AND MERGING DATA
C  -----------------------------------------------------------------
 
      DO WHILE(is.LE.nval(luni))
 
C  CHECK TO SEE WE ARE AT THE SAME NODE IN EACH BUFFER
C  ---------------------------------------------------
 
      node = inv(is,luni)
      nodj = inv(js,lunj)
      IF(node.NE.nodj) GOTO 900
 
      ityp = itp(node)
 
C  FOR TYPE 1 NODES DO AN ENTIRE SEQUENCE REPLACEMENT
C  --------------------------------------------------
 
      IF(ityp.EQ.1) THEN
         IF(typ(node).EQ.'DRB') ioff = 0
         IF(typ(node).NE.'DRB') ioff = 1
         iwrds = nwords(is,luni)+ioff
         jwrds = nwords(js,lunj)+ioff
         IF(iwrds.GT.ioff .AND. jwrds.EQ.ioff) THEN
            DO n=nval(lunj),js+1,-1
            inv(n+iwrds-jwrds,lunj) = inv(n,lunj)
            val(n+iwrds-jwrds,lunj) = val(n,lunj)
            ENDDO
            DO n=0,iwrds
            inv(js+n,lunj) = inv(is+n,luni)
            val(js+n,lunj) = val(is+n,luni)
            ENDDO
            nval(lunj) = nval(lunj)+iwrds-jwrds
            jwrds = iwrds
            nrpl = nrpl+1
         ENDIF
         is = is+iwrds
         js = js+jwrds
      ENDIF
 
C  FOR TYPES 2 AND 3 FILL MISSINGS
C  -------------------------------
 
      IF((ityp.EQ.2).OR.(ityp.EQ.3)) THEN
         herei = ibfms(val(is,luni)).EQ.0
         herej = ibfms(val(js,lunj)).EQ.0
         missi = .NOT.(herei)
         missj = .NOT.(herej)
         samei = val(is,luni).EQ.val(js,lunj)
         IF(herei.AND.missj) THEN
            val(js,lunj) = val(is,luni)
            nmrg = nmrg+1
         ELSEIF(herei.AND.herej.AND..NOT.samei) THEN
            namb = namb+1
         ENDIF
      ENDIF
 
C  BUMP THE COUNTERS AND GO CHECK THE NEXT PAIR
C  --------------------------------------------
 
      is = is + 1
      js = js + 1
      ENDDO
 
      ntot = ntot+1
 
C  EXITS
C  -----
 
      RETURN
900   WRITE(bort_str,'("BUFRLIB: INVMRG - NODE FROM INPUT BUFR FILE '//
     . '(",I7,") DOES NOT EQUAL NODE FROM OUTPUT BUFR FILE (",I7,"), '//
     . 'TABULAR MISMATCH")') node,nodj
      CALL bort(bort_str)
      END