NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
ufbcup.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE MAKES ONE COPY OF EACH UNIQUE ELEMENT IN AN
5 C> INPUT SUBSET BUFFER INTO THE IDENTICAL MNEMONIC SLOT IN THE OUTPUT
6 C> SUBSET BUFFER.
7 C>
8 C> PROGRAM HISTORY LOG:
9 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
10 C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
11 C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
12 C> ROUTINE "BORT"
13 C> 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
14 C> OPENED AT ONE TIME INCREASED FROM 10 TO 32
15 C> (NECESSARY IN ORDER TO PROCESS MULTIPLE
16 C> BUFR FILES UNDER THE MPI)
17 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
18 C> INTERDEPENDENCIES
19 C> 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
20 C> INCREASED FROM 15000 TO 16000 (WAS IN
21 C> VERIFICATION VERSION); UNIFIED/PORTABLE FOR
22 C> WRF; ADDED DOCUMENTATION (INCLUDING
23 C> HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
24 C> INFO WHEN ROUTINE TERMINATES ABNORMALLY
25 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
26 C>
27 C> USAGE: CALL UFBCUP (LUBIN, LUBOT)
28 C> INPUT ARGUMENT LIST:
29 C> LUBIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR
30 C> FILE
31 C> LUBOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR
32 C> FILE
33 C>
34 C> REMARKS:
35 C> THIS ROUTINE CALLS: BORT STATUS
36 C> THIS ROUTINE IS CALLED BY: None
37 C> Normally called only by application
38 C> programs.
39 C>
40  SUBROUTINE ufbcup(LUBIN,LUBOT)
41 
42  USE moda_usrint
43  USE moda_msgcwd
44  USE moda_tables
45  USE moda_ivttmp
46 
47  CHARACTER*10 tago
48 
49 C----------------------------------------------------------------------
50 C----------------------------------------------------------------------
51 
52 C CHECK THE FILE STATUSES AND I-NODE
53 C ----------------------------------
54 
55  CALL status(lubin,lui,il,im)
56  IF(il.EQ.0) goto 900
57  IF(il.GT.0) goto 901
58  IF(im.EQ.0) goto 902
59  IF(inode(lui).NE.inv(1,lui)) goto 903
60 
61  CALL status(lubot,luo,il,im)
62  IF(il.EQ.0) goto 904
63  IF(il.LT.0) goto 905
64  IF(im.EQ.0) goto 906
65 
66 C MAKE A LIST OF UNIQUE TAGS IN INPUT BUFFER
67 C ------------------------------------------
68 
69  ntag = 0
70 
71  DO 5 ni=1,nval(lui)
72  nin = inv(ni,lui)
73  IF(itp(nin).GE.2) THEN
74  DO nv=1,ntag
75  IF(ttmp(nv).EQ.tag(nin)) goto 5
76  ENDDO
77  ntag = ntag+1
78  itmp(ntag) = ni
79  ttmp(ntag) = tag(nin)
80  ENDIF
81 5 ENDDO
82 
83  IF(ntag.EQ.0) goto 907
84 
85 C GIVEN A LIST MAKE ONE COPY OF COMMON ELEMENTS TO OUTPUT BUFFER
86 C --------------------------------------------------------------
87 
88  DO 10 nv=1,ntag
89  ni = itmp(nv)
90  DO no=1,nval(luo)
91  tago = tag(inv(no,luo))
92  IF(ttmp(nv).EQ.tago) THEN
93  val(no,luo) = val(ni,lui)
94  goto 10
95  ENDIF
96  ENDDO
97 10 ENDDO
98 
99 C EXITS
100 C -----
101 
102  RETURN
103 900 CALL bort('BUFRLIB: UFBCUP - INPUT BUFR FILE IS CLOSED, IT '//
104  . 'MUST BE OPEN FOR INPUT')
105 901 CALL bort('BUFRLIB: UFBCUP - INPUT BUFR FILE IS OPEN FOR '//
106  . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
107 902 CALL bort('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN INPUT '//
108  . 'BUFR FILE, NONE ARE')
109 903 CALL bort('BUFRLIB: UFBCUP - LOCATION OF INTERNAL TABLE FOR '//
110  . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
111  . 'INTERNAL SUBSET ARRAY')
112 904 CALL bort('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS CLOSED, IT '//
113  . 'MUST BE OPEN FOR OUTPUT')
114 905 CALL bort('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS OPEN FOR '//
115  . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
116 906 CALL bort('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN OUTPUT '//
117  . 'BUFR FILE, NONE ARE')
118 907 CALL bort('BUFRLIB: UFBCUP - THERE ARE NO ELEMENTS (TAGS) IN '//
119  . 'INPUT SUBSET BUFFER')
120  END
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:61
subroutine ufbcup(LUBIN, LUBOT)
THIS SUBROUTINE MAKES ONE COPY OF EACH UNIQUE ELEMENT IN AN INPUT SUBSET BUFFER INTO THE IDENTICAL MN...
Definition: ufbcup.f:40
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23