var/external/bufr/invmrg.f

   1       SUBROUTINE INVMRG(LUBFI,LUBFJ)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    INVMRG
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1996-10-09
   7 C
   8 C ABSTRACT: THIS SUBROUTINE MERGES "PARTS" OF SUBSETS WHICH HAVE
   9 C   DUPLICATE SPACE AND TIME COORDINATES BUT DIFFERENT OR UNIQUE
  10 C   OBSERVATIONAL DATA.  IT CANNOT MERGE REPLICATED DATA.
  11 C
  12 C PROGRAM HISTORY LOG:
  13 C 1996-10-09  J. WOOLLEN -- ORIGINAL AUTHOR
  14 C 1996-11-25  J. WOOLLEN -- MODIFIED FOR RADIOSONDE CALL SIGNS
  15 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  16 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  17 C                           ROUTINE "BORT"
  18 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  19 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  20 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  21 C                           BUFR FILES UNDER THE MPI)
  22 C 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES;
  23 C                           REMOVED ENTRY POINT MRGINV (IT BECAME A
  24 C                           SEPARATE ROUTINE IN THE BUFRLIB TO
  25 C                           INCREASE PORTABILITY TO OTHER PLATFORMS)
  26 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  27 C                           INTERDEPENDENCIES
  28 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  29 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  30 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  31 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  32 C                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
  33 C                           INFO WHEN ROUTINE TERMINATES ABNORMALLY
  34 C 2007-01-19  J. ATOR    -- USE FUNCTION IBFMS AND SIMPLIFY LOGIC
  35 C
  36 C USAGE:    CALL INVMRG (LUBFI, LUBFJ)
  37 C   INPUT ARGUMENT LIST:
  38 C     LUBFI    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR
  39 C                FILE
  40 C     LUBFJ    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR
  41 C                FILE
  42 C
  43 C REMARKS:
  44 C    THIS ROUTINE CALLS:        BORT     IBFMS    NWORDS   STATUS
  45 C    THIS ROUTINE IS CALLED BY: None
  46 C                               Normally called only by application
  47 C                               programs.
  48 C
  49 C ATTRIBUTES:
  50 C   LANGUAGE: FORTRAN 77
  51 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  52 C
  53 C$$$
  54
  55       INCLUDE 'bufrlib.prm'
  56
  57       COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT
  58       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  59       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  60      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  61      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  62      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  63      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  64
  65       CHARACTER*128 BORT_STR
  66       CHARACTER*10  TAG
  67       CHARACTER*3   TYP
  68       LOGICAL       HEREI,HEREJ,MISSI,MISSJ,SAMEI
  69       REAL*8        VAL
  70
  71 C-----------------------------------------------------------------------
  72 C-----------------------------------------------------------------------
  73
  74       IS = 1
  75       JS = 1
  76
  77 C  GET THE UNIT POINTERS
  78 C  ---------------------
  79
  80       CALL STATUS(LUBFI,LUNI,IL,IM)
  81       CALL STATUS(LUBFJ,LUNJ,JL,JM)
  82
  83 C  STEP THROUGH THE BUFFERS COMPARING THE INVENTORY AND MERGING DATA
  84 C  -----------------------------------------------------------------
  85
  86       DO WHILE(IS.LE.NVAL(LUNI))
  87
  88 C  CHECK TO SEE WE ARE AT THE SAME NODE IN EACH BUFFER
  89 C  ---------------------------------------------------
  90
  91       NODE = INV(IS,LUNI)
  92       NODJ = INV(JS,LUNJ)
  93       IF(NODE.NE.NODJ) GOTO 900
  94
  95       ITYP = ITP(NODE)
  96
  97 C  FOR TYPE 1 NODES DO AN ENTIRE SEQUENCE REPLACEMENT
  98 C  --------------------------------------------------
  99
 100       IF(ITYP.EQ.1) THEN
 101          IF(TYP(NODE).EQ.'DRB') IOFF = 0
 102          IF(TYP(NODE).NE.'DRB') IOFF = 1
 103          IWRDS = NWORDS(IS,LUNI)+IOFF
 104          JWRDS = NWORDS(JS,LUNJ)+IOFF
 105          IF(IWRDS.GT.IOFF .AND. JWRDS.EQ.IOFF) THEN
 106             DO N=NVAL(LUNJ),JS+1,-1
 107             INV(N+IWRDS-JWRDS,LUNJ) = INV(N,LUNJ)
 108             VAL(N+IWRDS-JWRDS,LUNJ) = VAL(N,LUNJ)
 109             ENDDO
 110             DO N=0,IWRDS
 111             INV(JS+N,LUNJ) = INV(IS+N,LUNI)
 112             VAL(JS+N,LUNJ) = VAL(IS+N,LUNI)
 113             ENDDO
 114             NVAL(LUNJ) = NVAL(LUNJ)+IWRDS-JWRDS
 115             JWRDS = IWRDS
 116             NRPL = NRPL+1
 117          ENDIF
 118          IS = IS+IWRDS
 119          JS = JS+JWRDS
 120       ENDIF
 121
 122 C  FOR TYPES 2 AND 3 FILL MISSINGS
 123 C  -------------------------------
 124
 125       IF((ITYP.EQ.2).OR.(ITYP.EQ.3)) THEN
 126          HEREI = IBFMS(VAL(IS,LUNI)).EQ.0
 127          HEREJ = IBFMS(VAL(JS,LUNJ)).EQ.0
 128          MISSI = .NOT.(HEREI)
 129          MISSJ = .NOT.(HEREJ)
 130          SAMEI = VAL(IS,LUNI).EQ.VAL(JS,LUNJ)
 131          IF(HEREI.AND.MISSJ) THEN
 132             VAL(JS,LUNJ) = VAL(IS,LUNI)
 133             NMRG = NMRG+1
 134          ELSEIF(HEREI.AND.HEREJ.AND..NOT.SAMEI) THEN
 135             NAMB = NAMB+1
 136          ENDIF
 137       ENDIF
 138
 139 C  BUMP THE COUNTERS AND GO CHECK THE NEXT PAIR
 140 C  --------------------------------------------
 141
 142       IS = IS + 1
 143       JS = JS + 1
 144       ENDDO
 145
 146       NTOT = NTOT+1
 147
 148 C  EXITS
 149 C  -----
 150
 151       RETURN
 152 900   WRITE(BORT_STR,'("BUFRLIB: INVMRG - NODE FROM INPUT BUFR FILE '//
 153      . '(",I7,") DOES NOT EQUAL NODE FROM OUTPUT BUFR FILE (",I7,"), '//
 154      . 'TABULAR MISMATCH")') NODE,NODJ
 155       CALL BORT(BORT_STR)
 156       END