NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
ufbovr.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE WRITES OVER SPECIFIED VALUES WHICH EXIST
5 C> IN CURRENT INTERNAL BUFR SUBSET ARRAYS IN A FILE OPEN FOR OUTPUT.
6 C> THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE PART OF A
7 C> DELAYED-REPLICATION SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION
8 C> AT ALL. EITHER BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR OPENMB
9 C> MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A BUFR
10 C> MESSAGE WITHIN MEMORY FOR THIS LUNIT. IN ADDITION, BUFR ARCHIVE
11 C> LIBRARY SUBROUTINE WRITSB OR INVMRG MUST HAVE BEEN CALLED TO STORE
12 C> DATA IN THE INTERNAL OUTPUT SUBSET ARRAYS.
13 C>
14 C> PROGRAM HISTORY LOG:
15 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
16 C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
17 C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
18 C> ROUTINE "BORT"
19 C> 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
20 C> OPENED AT ONE TIME INCREASED FROM 10 TO 32
21 C> (NECESSARY IN ORDER TO PROCESS MULTIPLE
22 C> BUFR FILES UNDER THE MPI)
23 C> 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
24 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
25 C> INTERDEPENDENCIES
26 C> 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
27 C> INCREASED FROM 15000 TO 16000 (WAS IN
28 C> VERIFICATION VERSION); UNIFIED/PORTABLE FOR
29 C> WRF; ADDED DOCUMENTATION (INCLUDING
30 C> HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
31 C> INFO WHEN ROUTINE TERMINATES ABNORMALLY OR
32 C> UNUSUAL THINGS HAPPEN; CHANGED CALL FROM
33 C> BORT TO BORT2 IN SOME CASES
34 C> 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS
35 C> 2009-04-21 J. ATOR -- USE ERRWRT
36 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
37 C> 2015-09-24 D. STOKES -- FIX MISSING DECLARATION OF COMMON /QUIET/
38 C>
39 C> USAGE: CALL UFBOVR (LUNIT, USR, I1, I2, IRET, STR)
40 C> INPUT ARGUMENT LIST:
41 C> LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
42 C> USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
43 C> WRITTEN TO DATA SUBSET
44 C> I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT
45 C> LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED
46 C> MNEMONICS IN STR)
47 C> I2 - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES TO BE
48 C> WRITTEN TO DATA SUBSET
49 C> STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
50 C> MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
51 C> DIMENSION OF USR
52 C>
53 C> OUTPUT ARGUMENT LIST:
54 C> IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES WRITTEN TO
55 C> DATA SUBSET (SHOULD BE SAME AS I2)
56 C>
57 C> REMARKS:
58 C> THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS
59 C> STRING TRYBUMP
60 C> THIS ROUTINE IS CALLED BY: None
61 C> Normally called only by application
62 C> programs.
63 C>
64  SUBROUTINE ufbovr(LUNIT,USR,I1,I2,IRET,STR)
65 
66  USE moda_usrint
67  USE moda_msgcwd
68 
69  COMMON /quiet / iprt
70 
71  CHARACTER*128 bort_str1,bort_str2,errstr
72  CHARACTER*(*) str
73  REAL*8 usr(i1,i2)
74 
75  DATA ifirst1/0/,ifirst2/0/
76 
77  SAVE ifirst1, ifirst2
78 
79 C----------------------------------------------------------------------
80 C----------------------------------------------------------------------
81 
82  iret = 0
83 
84 C CHECK THE FILE STATUS AND I-NODE
85 C --------------------------------
86 
87  CALL status(lunit,lun,il,im)
88  IF(il.EQ.0) goto 900
89  IF(il.LT.0) goto 901
90  IF(im.EQ.0) goto 902
91  IF(inode(lun).NE.inv(1,lun)) goto 903
92 
93 C .... DK: Why check, isn't IO always 1 here?
94  io = min(max(0,il),1)
95 
96  IF(i1.LE.0) THEN
97  IF(iprt.GE.0) THEN
98  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
99  errstr = .LE.'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS 0, ' //
100  . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
101  CALL errwrt(errstr)
102  CALL errwrt(str)
103  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
104  CALL errwrt(' ')
105  ENDIF
106  goto 100
107  ELSEIF(i2.LE.0) THEN
108  IF(iprt.EQ.-1) ifirst1 = 1
109  IF(io.EQ.0 .OR. ifirst1.EQ.0 .OR. iprt.GE.1) THEN
110  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
111  errstr = .LE.'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS 0, ' //
112  . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
113  CALL errwrt(errstr)
114  CALL errwrt(str)
115  IF(iprt.EQ.0 .AND. io.EQ.1) THEN
116  errstr = 'Note: Only the first occurrence of this WARNING ' //
117  . 'message is printed, there may be more. To output all ' //
118  . 'such messages,'
119  CALL errwrt(errstr)
120  errstr = 'modify your application program to add ' //
121  . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
122  . 'to a BUFRLIB routine.'
123  CALL errwrt(errstr)
124  ENDIF
125  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
126  CALL errwrt(' ')
127  ifirst1 = 1
128  ENDIF
129  goto 100
130  ENDIF
131 
132 C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES
133 C ----------------------------------------------------
134 
135  CALL string(str,lun,i1,io)
136  CALL trybump(lunit,lun,usr,i1,i2,io,iret)
137 
138  IF(io.EQ.1 .AND. iret.NE.i2) goto 904
139 
140  IF(iret.EQ.0) THEN
141  IF(iprt.EQ.-1) ifirst2 = 1
142  IF(ifirst2.EQ.0 .OR. iprt.GE.1) THEN
143  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
144  errstr = 'BUFRLIB: UFBOVR - NO SPECIFIED VALUES WRITTEN OUT, ' //
145  . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
146  CALL errwrt(errstr)
147  CALL errwrt(str)
148  CALL errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
149  IF(iprt.EQ.0) THEN
150  errstr = 'Note: Only the first occurrence of this WARNING ' //
151  . 'message is printed, there may be more. To output all ' //
152  . 'such messages,'
153  CALL errwrt(errstr)
154  errstr = 'modify your application program to add ' //
155  . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
156  . 'to a BUFRLIB routine.'
157  CALL errwrt(errstr)
158  ENDIF
159  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
160  CALL errwrt(' ')
161  ifirst2 = 1
162  ENDIF
163  ENDIF
164 
165 C EXITS
166 C -----
167 
168 100 RETURN
169 900 CALL bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT '//
170  . 'MUST BE OPEN FOR OUTPUT')
171 901 CALL bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR '//
172  . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
173 902 CALL bort('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT '//
174  . 'BUFR FILE, NONE ARE')
175 903 CALL bort('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '//
176  . 'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
177  . 'INTERNAL SUBSET ARRAY')
178 904 WRITE(bort_str1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS'//
179  . ': ",A)') str
180  WRITE(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '//
181  . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'//
182  . ' - INCOMPLETE WRITE")') iret,i2
183  CALL bort2(bort_str1,bort_str2)
184  END
subroutine bort2(STR1, STR2)
This subroutine calls subroutine errwrt() to log two error messages, then calls subroutine bort_exit(...
Definition: bort2.f:20
subroutine ufbovr(LUNIT, USR, I1, I2, IRET, STR)
THIS SUBROUTINE WRITES OVER SPECIFIED VALUES WHICH EXIST IN CURRENT INTERNAL BUFR SUBSET ARRAYS IN A ...
Definition: ufbovr.f:64
subroutine string(STR, LUN, I1, IO)
THIS SUBROUTINE CHECKS TO SEE IF A USER-SPECIFIED CHARACTER STRING IS IN THE STRING CACHE (ARRAYS IN ...
Definition: string.f:58
subroutine trybump(LUNIT, LUN, USR, I1, I2, IO, IRET)
THIS SUBROUTINE CHECKS THE FIRST NODE ASSOCIATED WITH A CHARACTER STRING (PARSED INTO ARRAYS IN COMMO...
Definition: trybump.f:70
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 errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:39
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23