invmrg.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1996-10-09
      
C> THIS SUBROUTINE MERGES "PARTS" OF SUBSETS WHICH HAVE
C>   DUPLICATE SPACE AND TIME COORDINATES BUT DIFFERENT OR UNIQUE
C>   OBSERVATIONAL DATA.  IT CANNOT MERGE REPLICATED DATA.
C>
C> PROGRAM HISTORY LOG:
C> 1996-10-09  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1996-11-25  J. WOOLLEN -- MODIFIED FOR RADIOSONDE CALL SIGNS
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES;
C>                           REMOVED ENTRY POINT MRGINV (IT BECAME A
C>                           SEPARATE ROUTINE IN THE BUFRLIB TO
C>                           INCREASE PORTABILITY TO OTHER PLATFORMS)
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C>                           INCREASED FROM 15000 TO 16000 (WAS IN
C>                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C>                           WRF; ADDED DOCUMENTATION (INCLUDING
C>                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
C>                           INFO WHEN ROUTINE TERMINATES ABNORMALLY
C> 2007-01-19  J. ATOR    -- USE FUNCTION IBFMS AND SIMPLIFY LOGIC
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL INVMRG (LUBFI, LUBFJ)
C>   INPUT ARGUMENT LIST:
C>     LUBFI    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR
C>                FILE
C>     LUBFJ    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR
C>                FILE
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     IBFMS    NWORDS   STATUS
C>    THIS ROUTINE IS CALLED BY: None
C>                               Normally called only by application
C>                               programs.
C>
      SUBROUTINE invmrg(LUBFI,LUBFJ)
 
      USE moda_usrint
      USE moda_tables
 
      COMMON /mrgcom/ nrpl,nmrg,namb,ntot
 
      CHARACTER*128 BORT_STR
      LOGICAL       HEREI,HEREJ,MISSI,MISSJ,SAMEI
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
      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