NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
invmrg.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1996-10-09
3 
4 C> THIS SUBROUTINE MERGES "PARTS" OF SUBSETS WHICH HAVE
5 C> DUPLICATE SPACE AND TIME COORDINATES BUT DIFFERENT OR UNIQUE
6 C> OBSERVATIONAL DATA. IT CANNOT MERGE REPLICATED DATA.
7 C>
8 C> PROGRAM HISTORY LOG:
9 C> 1996-10-09 J. WOOLLEN -- ORIGINAL AUTHOR
10 C> 1996-11-25 J. WOOLLEN -- MODIFIED FOR RADIOSONDE CALL SIGNS
11 C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
12 C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
13 C> ROUTINE "BORT"
14 C> 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
15 C> OPENED AT ONE TIME INCREASED FROM 10 TO 32
16 C> (NECESSARY IN ORDER TO PROCESS MULTIPLE
17 C> BUFR FILES UNDER THE MPI)
18 C> 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES;
19 C> REMOVED ENTRY POINT MRGINV (IT BECAME A
20 C> SEPARATE ROUTINE IN THE BUFRLIB TO
21 C> INCREASE PORTABILITY TO OTHER PLATFORMS)
22 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
23 C> INTERDEPENDENCIES
24 C> 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
25 C> INCREASED FROM 15000 TO 16000 (WAS IN
26 C> VERIFICATION VERSION); UNIFIED/PORTABLE FOR
27 C> WRF; ADDED DOCUMENTATION (INCLUDING
28 C> HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
29 C> INFO WHEN ROUTINE TERMINATES ABNORMALLY
30 C> 2007-01-19 J. ATOR -- USE FUNCTION IBFMS AND SIMPLIFY LOGIC
31 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
32 C>
33 C> USAGE: CALL INVMRG (LUBFI, LUBFJ)
34 C> INPUT ARGUMENT LIST:
35 C> LUBFI - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR
36 C> FILE
37 C> LUBFJ - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR
38 C> FILE
39 C>
40 C> REMARKS:
41 C> THIS ROUTINE CALLS: BORT IBFMS NWORDS STATUS
42 C> THIS ROUTINE IS CALLED BY: None
43 C> Normally called only by application
44 C> programs.
45 C>
46  SUBROUTINE invmrg(LUBFI,LUBFJ)
47 
48  USE moda_usrint
49  USE moda_tables
50 
51  COMMON /mrgcom/ nrpl,nmrg,namb,ntot
52 
53  CHARACTER*128 bort_str
54  LOGICAL herei,herej,missi,missj,samei
55 
56 C-----------------------------------------------------------------------
57 C-----------------------------------------------------------------------
58 
59  is = 1
60  js = 1
61 
62 C GET THE UNIT POINTERS
63 C ---------------------
64 
65  CALL status(lubfi,luni,il,im)
66  CALL status(lubfj,lunj,jl,jm)
67 
68 C STEP THROUGH THE BUFFERS COMPARING THE INVENTORY AND MERGING DATA
69 C -----------------------------------------------------------------
70 
71  DO WHILE(is.LE.nval(luni))
72 
73 C CHECK TO SEE WE ARE AT THE SAME NODE IN EACH BUFFER
74 C ---------------------------------------------------
75 
76  node = inv(is,luni)
77  nodj = inv(js,lunj)
78  IF(node.NE.nodj) goto 900
79 
80  ityp = itp(node)
81 
82 C FOR TYPE 1 NODES DO AN ENTIRE SEQUENCE REPLACEMENT
83 C --------------------------------------------------
84 
85  IF(ityp.EQ.1) THEN
86  IF(typ(node).EQ.'DRB') ioff = 0
87  IF(typ(node).NE.'DRB') ioff = 1
88  iwrds = nwords(is,luni)+ioff
89  jwrds = nwords(js,lunj)+ioff
90  IF(iwrds.GT.ioff .AND. jwrds.EQ.ioff) THEN
91  DO n=nval(lunj),js+1,-1
92  inv(n+iwrds-jwrds,lunj) = inv(n,lunj)
93  val(n+iwrds-jwrds,lunj) = val(n,lunj)
94  ENDDO
95  DO n=0,iwrds
96  inv(js+n,lunj) = inv(is+n,luni)
97  val(js+n,lunj) = val(is+n,luni)
98  ENDDO
99  nval(lunj) = nval(lunj)+iwrds-jwrds
100  jwrds = iwrds
101  nrpl = nrpl+1
102  ENDIF
103  is = is+iwrds
104  js = js+jwrds
105  ENDIF
106 
107 C FOR TYPES 2 AND 3 FILL MISSINGS
108 C -------------------------------
109 
110  IF((ityp.EQ.2).OR.(ityp.EQ.3)) THEN
111  herei = ibfms(val(is,luni)).EQ.0
112  herej = ibfms(val(js,lunj)).EQ.0
113  missi = .NOT.(herei)
114  missj = .NOT.(herej)
115  samei = val(is,luni).EQ.val(js,lunj)
116  IF(herei.AND.missj) THEN
117  val(js,lunj) = val(is,luni)
118  nmrg = nmrg+1
119  ELSEIF(herei.AND.herej.AND..NOT.samei) THEN
120  namb = namb+1
121  ENDIF
122  ENDIF
123 
124 C BUMP THE COUNTERS AND GO CHECK THE NEXT PAIR
125 C --------------------------------------------
126 
127  is = is + 1
128  js = js + 1
129  ENDDO
130 
131  ntot = ntot+1
132 
133 C EXITS
134 C -----
135 
136  RETURN
137 900 WRITE(bort_str,'("BUFRLIB: INVMRG - NODE FROM INPUT BUFR FILE '//
138  . '(",I7,") DOES NOT EQUAL NODE FROM OUTPUT BUFR FILE (",I7,"), '//
139  . 'TABULAR MISMATCH")') node,nodj
140  CALL bort(bort_str)
141  END
subroutine invmrg(LUBFI, LUBFJ)
THIS SUBROUTINE MERGES "PARTS" OF SUBSETS WHICH HAVE DUPLICATE SPACE AND TIME COORDINATES BUT DIFFERE...
Definition: invmrg.f:46
function nwords(N, LUN)
THIS FUNCTION ADDS UP THE COMPLETE LENGTH OF THE DELAYED REPLICATION SEQUENCE BEGINNING AT INDEX N OF...
Definition: nwords.f:38
INTEGER function ibfms(R8VAL)
This function provides a handy way to check whether a real*8 data value returned from a previous call...
Definition: ibfms.f:38
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
Definition: status.f:55
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22