NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
ufbseq.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Read/write an entire sequence of data values from/to
3 C> a data subset.
4 
5 C> This subroutine reads or writes an entire sequence of data values
6 C> from or to the BUFR data subset that is currently open within the
7 C> BUFRLIB internal arrays. The direction of the data transfer is
8 C> determined by the context of ABS(LUNIN):
9 C> - If ABS(LUNIN) points to a file that was previously opened for
10 C> input using subroutine openbf(), then data values are read from
11 C> the current data subset.
12 C> - If ABS(LUNIN) points to a file that was previously opened for
13 C> output using subroutine openbf(), then data values are written to
14 C> the current data subset.
15 C>
16 C> <p>This subroutine is specifically designed for use with a single
17 C> Table A or Table D mnemonic. In the latter case, the mnemonic
18 C> may be replicated within the overall subset definition, and in
19 C> which case the subroutine will return all data values within all
20 C> replications of the sequence defined by the mnemonic. But in
21 C> either case, the mnemonic itself may contain, within its own
22 C> sequence definition, any number of data values defined by Table B
23 C> mnemonics and/or subsequences of data values defined by other
24 C> Table D mnemonics, and any such subsequences may themselves be
25 C> replicated using any manner of fixed or delayed replication.
26 C> See [DX BUFR Tables](@ref ufbsubs) for more details including
27 C> an example use case, and see also subroutines ufbint(), ufbrep()
28 C> and ufbstp() which are also used to read/write one or more data
29 C> values from/to a data subset but cannot themselves be directly
30 C> used with Table A or Table D mnemonics.
31 C>
32 C> @authors J. Woollen
33 C> @authors J. Ator
34 C> @date 2000-09-19
35 C>
36 C> @param[in] LUNIN - integer: Absolute value is Fortran logical
37 C> unit number for BUFR file
38 C> @param[in,out] USR - real*8(*,*): Data values
39 C> - If ABS(LUNIN) was opened for input, then
40 C> USR is output from this subroutine and
41 C> contains data values that were read
42 C> from the current data subset.
43 C> - If ABS(LUNIN) was opened for output, then
44 C> USR is input to this subroutine and
45 C> contains data values that are to be
46 C> written to the current data subset.
47 C> @param[in] I1 - integer: Actual first dimension of USR as allocated
48 C> within the calling program
49 C> @param[in] I2 - integer:
50 C> - If ABS(LUNIN) was opened for input, then I2
51 C> must be set equal to the actual second dimension
52 C> of USR as allocated within the calling program
53 C> - If ABS(LUNIN) was opened for output, then I2
54 C> must be set equal to the number of replications
55 C> of STR that are to be written to the data subset
56 C> @param[out] IRET - integer: Number of replications of STR that were
57 C> actually read/written from/to the data subset
58 C> @param[in] STR - character*(*): String consisting of a single Table A
59 C> or Table D mnemonic whose sequence definition is
60 C> in one-to-one correspondence with the number of data
61 C> values that will be read/written from/to the data
62 C> subset within the first dimension of USR
63 C> (see [DX BUFR Tables](@ref dfbftab) for further
64 C> information about Table A and Table D mnemonics)
65 C>
66 C> <p>It is the user's responsibility to ensure that USR is dimensioned
67 C> sufficiently large enough to accommodate the number of data values
68 C> that are to be read from or written to the data subset. Note also
69 C> that USR is an array of real*8 values; therefore, any data that are
70 C> to be written out as character (i.e. CCITT IA5) values in
71 C> BUFR must be converted from character into real*8 format within the
72 C> application program before calling this subroutine. Conversely,
73 C> when this subroutine is being used to read character values from a
74 C> data subset, the value that is returned will be in real*8 format
75 C> and must be converted back into character format by the application
76 C> program before it can be used as such. Alternatively, there are
77 C> different subroutines such as readlc() and writlc() which can be
78 C> used to read/write character data directly from/to a data subset
79 C> without the need to convert from/to real*8 format as an intermediate
80 C> step.
81 C>
82 C> <p>Numeric (i.e. non-character) data values within USR are always in
83 C> the exact units specified for the corresponding mnemonic within the
84 C> relevant DX or master BUFR table, without any scale or reference
85 C> values applied. Specifically, this means that, when writing
86 C> data values into an output subset, the user only needs to store each
87 C> respective value into USR using the units specified within the table,
88 C> and the BUFRLIB software will take care of any necessary scaling or
89 C> referencing of the value before it is actually encoded into BUFR.
90 C> Conversely, when reading data values from an input subset, the
91 C> values returned in USR are already de-scaled and de-referenced and,
92 C> thus, are already in the exact units that were defined for the
93 C> corresponding mnemonics within the table.
94 C>
95 C> <p>"Missing" values in USR are always denoted by a unique
96 C> placeholder value. This placeholder value is initially set
97 C> to a default value of 10E10_8, but it can be reset to
98 C> any substitute value of the user's choice via a separate
99 C> call to subroutine setbmiss(). In any case, and whenever this
100 C> subroutine is used to read data values from an input subset, any
101 C> returned value in USR can be easily checked for equivalence to the
102 C> current placeholder value via a call to function ibfms(), and a
103 C> positive result means that the value for the corresponding mnemonic
104 C> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
105 C> original data subset. Conversely, whenever this subroutine
106 C> is used to write data values to an output subset, the current
107 C> placeholder value can be obtained via a separate call to function
108 C> getbmiss(), and the resulting value can then be stored into the
109 C> USR array whereever the user desires a BUFR "missing" value (i.e.
110 C> all bits set to 1) to be encoded for the corresponding mnemonic
111 C> within the output subset.
112 C>
113 C> @remarks
114 C> - If LUNIN < 0, and if ABS(LUNIN) points to a file that is open
115 C> for output (writing BUFR), then the subroutine will treat the file
116 C> pointed to by ABS(LUNIN) as though it was open for input (reading
117 C> BUFR). This is a special capability for use by some applications
118 C> that need to read certain values back out from a BUFR file during
119 C> the same time that it is in the process of being written to.
120 C> - If ABS(LUNIN) points to a file that is open for output
121 C> (writing BUFR), and if the data values to be written are part of
122 C> a sequence replicated using delayed replication, then a call to
123 C> subroutine drfini() must be made prior to calling this subroutine,
124 C> in order to pre-allocate the necessary internal array space for
125 C> the number of replications of the sequence.
126 C>
127 C> <b>Program history log:</b>
128 C> - 2000-09-19 J. Woollen -- Original author
129 C> - 2002-05-14 J. Woollen -- Improved generality; previously ufbseq
130 C> would not recognize compressed delayed
131 C> replication as a legitimate data structure
132 C> - 2003-05-19 J. Woollen -- Corrected the logic array of exit
133 C> conditions for the subroutine; previously,
134 C> in some cases, proper exits were missed,
135 C> generating bogus error messages, because of
136 C> several miscellaneous bugs which are now
137 C> removed
138 C> - 2003-11-04 S. Bender -- Added remarks and routine interdependencies
139 C> - 2003-11-04 D. Keyser -- Unified/portable for WRF; added history
140 C> documentation; outputs more complete
141 C> diagnostic info when routine terminates
142 C> abnormally, unusual things happen or for
143 C> informational purposes
144 C> - 2004-08-18 J. Ator -- Added SAVE for IFIRST1 and IFIRST2 flags
145 C> - 2007-01-19 J. Ator -- Replaced call to parseq with call to parstr()
146 C> - 2009-04-21 J. Ator -- Use errwrt()
147 C> - 2014-09-10 J. Ator -- Fix bug involving nested delayed replication
148 C> where first replication of outer sequence
149 C> does not contain a replication of the inner
150 C> sequence
151 C> - 2014-12-10 J. Ator -- Use modules instead of COMMON blocks
152 C> - 2020-03-06 J. Ator -- No longer abort when reading data and number
153 C> of available levels is greater than I2;
154 C> instead just return first I2 levels and
155 C> print a diagnostic message
156 C>
157  SUBROUTINE ufbseq(LUNIN,USR,I1,I2,IRET,STR)
158 
159  USE modv_bmiss
160  USE moda_usrint
161  USE moda_msgcwd
162  USE moda_tables
163 
164  parameter(mtag=10)
165 
166  COMMON /quiet / iprt
167 
168  CHARACTER*(*) str
169  CHARACTER*156 bort_str
170  CHARACTER*128 errstr
171  CHARACTER*10 tags(mtag)
172  REAL*8 usr(i1,i2)
173 
174  DATA ifirst1/0/,ifirst2/0/
175 
176  SAVE ifirst1, ifirst2
177 
178 C----------------------------------------------------------------------
179 C----------------------------------------------------------------------
180 
181  iret = 0
182 
183 C CHECK THE FILE STATUS AND I-NODE
184 C --------------------------------
185 
186  lunit = abs(lunin)
187  CALL status(lunit,lun,il,im)
188  IF(il.EQ.0) goto 900
189  IF(im.EQ.0) goto 901
190 
191  io = min(max(0,il),1)
192  IF(lunit.NE.lunin) io = 0
193 
194  IF(i1.LE.0) THEN
195  IF(iprt.GE.0) THEN
196  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
197  errstr = .LE.'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS 0, ' //
198  . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
199  CALL errwrt(errstr)
200  CALL errwrt(str)
201  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
202  CALL errwrt(' ')
203  ENDIF
204  goto 100
205  ELSEIF(i2.LE.0) THEN
206  IF(iprt.EQ.-1) ifirst1 = 1
207  IF(io.EQ.0 .OR. ifirst1.EQ.0 .OR. iprt.GE.1) THEN
208  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
209  errstr = .LE.'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS 0, ' //
210  . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
211  CALL errwrt(errstr)
212  CALL errwrt(str)
213  IF(iprt.EQ.0 .AND. io.EQ.1) THEN
214  errstr = 'Note: Only the first occurrence of this WARNING ' //
215  . 'message is printed, there may be more. To output all ' //
216  . 'such messages,'
217  CALL errwrt(errstr)
218  errstr = 'modify your application program to add ' //
219  . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
220  . 'to a BUFRLIB routine.'
221  CALL errwrt(errstr)
222  ENDIF
223  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
224  CALL errwrt(' ')
225  ifirst1 = 1
226  ENDIF
227  goto 100
228  ENDIF
229 
230 C CHECK FOR VALID SEQUENCE AND SEQUENCE LENGTH ARGUMENTS
231 C ------------------------------------------------------
232 
233  CALL parstr(str,tags,mtag,ntag,' ',.true.)
234  IF(ntag.LT.1) goto 902
235  IF(ntag.GT.1) goto 903
236  IF(i1.LE.0) goto 904
237  IF(i2.LE.0) goto 905
238  IF(inode(lun).NE.inv(1,lun)) goto 906
239 
240 
241 C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION
242 C --------------------------------------------------
243 
244  IF(io.EQ.0) THEN
245  DO j=1,i2
246  DO i=1,i1
247  usr(i,j) = bmiss
248  ENDDO
249  ENDDO
250  ENDIF
251 
252 
253 C FIND THE PARAMETERS OF THE SPECIFIED SEQUENCE
254 C ---------------------------------------------
255 
256  DO node=inode(lun),isc(inode(lun))
257  IF(str.EQ.tag(node)) THEN
258  IF(typ(node).EQ.'SEQ'.OR.typ(node).EQ.'RPC') THEN
259  ins1 = 1
260 5 ins1 = invtag(node,lun,ins1,nval(lun))
261  IF(ins1.EQ.0) goto 200
262  IF(typ(node).EQ.'RPC'.AND.val(ins1,lun).EQ.0.) THEN
263  ins1 = ins1+1
264  goto 5
265  ENDIF
266  ins2 = invtag(node,lun,ins1+1,nval(lun))
267  IF(ins2.EQ.0) ins2 = 10e5
268  nods = node
269  DO WHILE(link(nods).EQ.0.AND.jmpb(nods).GT.0)
270  nods = jmpb(nods)
271  ENDDO
272  IF(link(nods).EQ.0) THEN
273  insx = nval(lun)
274  ELSEIF(link(nods).GT.0) THEN
275  insx = invwin(link(nods),lun,ins1+1,nval(lun))-1
276  ENDIF
277  ins2 = min(ins2,insx)
278  ELSEIF(typ(node).EQ.'SUB') THEN
279  ins1 = 1
280  ins2 = nval(lun)
281  ELSE
282  goto 907
283  ENDIF
284  nseq = 0
285  DO isq=ins1,ins2
286  ityp = itp(inv(isq,lun))
287  IF(ityp.GT.1) nseq = nseq+1
288  ENDDO
289  IF(nseq.GT.i1) goto 908
290  goto 1
291  ENDIF
292  ENDDO
293 
294  goto 200
295 
296 C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME
297 C ----------------------------------------------------
298 
299 1 ins1 = invtag(node,lun,ins1,nval(lun))
300  IF(ins1.GT.nval(lun)) goto 200
301  IF(ins1.GT.0) THEN
302  IF(typ(node).EQ.'RPC'.AND.val(ins1,lun).EQ.0.) THEN
303  ins1 = ins1+1
304  goto 1
305  ELSEIF(io.EQ.0.AND.iret+1.GT.i2) THEN
306  IF(iprt.GE.0) THEN
307  CALL errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
308  WRITE ( unit=errstr, fmt='(A,I5,A,A,A)' )
309  . 'BUFRLIB: UFBSEQ - INCOMPLETE READ; ONLY THE FIRST ', i2,
310  . ' (=4TH INPUT ARG.) ''LEVELS'' OF INPUT MNEMONIC ', tags(1),
311  . ' WERE READ'
312  CALL errwrt(errstr)
313  CALL errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
314  CALL errwrt(' ')
315  ENDIF
316  goto 200
317  ENDIF
318  ELSEIF(ins1.EQ.0) THEN
319  IF(io.EQ.1.AND.iret.LT.i2) goto 910
320  ELSE
321  goto 911
322  ENDIF
323 
324  IF(ins1.EQ. 0) goto 200
325  IF(iret.EQ.i2) goto 200
326 
327  iret = iret+1
328  ins1 = ins1+1
329 
330 C READ/WRITE USER VALUES
331 C ----------------------
332 
333  j = ins1
334  DO i=1,nseq
335  DO WHILE(itp(inv(j,lun)).LT.2)
336  j = j+1
337  ENDDO
338  IF(io.EQ.0) usr(i,iret) = val(j,lun )
339  IF(io.EQ.1) val(j,lun ) = usr(i,iret)
340  j = j+1
341  ENDDO
342 
343 C CHECK FOR NEXT FRAME
344 C --------------------
345 
346  goto 1
347 
348 200 CONTINUE
349 
350  IF(iret.EQ.0) THEN
351  IF(io.EQ.0) THEN
352  IF(iprt.GE.1) THEN
353  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
354  errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, ' //
355  . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
356  CALL errwrt(errstr)
357  CALL errwrt(str)
358  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
359  CALL errwrt(' ')
360  ENDIF
361  ELSE
362  IF(iprt.EQ.-1) ifirst2 = 1
363  IF(ifirst2.EQ.0 .OR. iprt.GE.1) THEN
364  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
365  errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, ' //
366  . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
367  CALL errwrt(errstr)
368  CALL errwrt(str)
369  CALL errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
370  IF(iprt.EQ.0) THEN
371  errstr = 'Note: Only the first occurrence of this WARNING ' //
372  . 'message is printed, there may be more. To output all ' //
373  . 'such messages,'
374  CALL errwrt(errstr)
375  errstr = 'modify your application program to add ' //
376  . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
377  . 'to a BUFRLIB routine.'
378  CALL errwrt(errstr)
379  ENDIF
380  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
381  CALL errwrt(' ')
382  ifirst2 = 1
383  ENDIF
384  ENDIF
385  ENDIF
386 
387 C EXITS
388 C -----
389 
390 100 RETURN
391 900 CALL bort('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE'//
392  . ' OPEN')
393 901 CALL bort('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR '//
394  . 'FILE, NONE ARE')
395 902 WRITE(bort_str,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") '//
396  . 'DOES NOT CONTAIN ANY MNEMONICS!!")') str
397  CALL bort(bort_str)
398 903 WRITE(bort_str,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '//
399  . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3'//
400  . ',")")') str,ntag
401  CALL bort(bort_str)
402 904 WRITE(bort_str,'("BUFRLIB: UFBSEQ - THIRD ARGUMENT (INPUT) MUST'//
403  . .GT.' BE ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)')
404  . i1,tags(1)
405  CALL bort(bort_str)
406 905 WRITE(bort_str,'("BUFRLIB: UFBSEQ - FOURTH ARGUMENT (INPUT) '//
407  . .GT.'MUST BE ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)')
408  . i2,tags(1)
409  CALL bort(bort_str)
410 906 CALL bort('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '//
411  . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '//
412  . 'SUBSET ARRAY')
413 907 WRITE(bort_str,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '//
414  . 'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') tags(1),typ(node)
415  CALL bort(bort_str)
416 908 WRITE(bort_str,'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A,'//
417  . .GT.'" CONSISTS OF",I4," TABLE B MNEM., THE MAX. SPECIFIED IN'//
418  . ' (INPUT) ARGUMENT 3 (",I3,")")') tags(1),nseq,i1
419  CALL bort(bort_str)
420 910 WRITE(bort_str,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' WRITTEN '//
421  . .LT.'(",I5,") NO. REQUESTED (",I5,") - INCOMPLETE WRITE '//
422  . '(INPUT MNEMONIC IS ",A,")")') iret,i2,tags(1)
423  CALL bort(bort_str)
424 911 WRITE(bort_str,.GE.'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE '//
425  . 'ZERO, HERE IT IS",I4," - INPUT MNEMONIC IS ",A)') ins1,tags(1)
426  CALL bort(bort_str)
427  END
subroutine parstr(STR, TAGS, MTAG, NTAG, SEP, LIMIT80)
THIS SUBROUTINE PARSES A STRING CONTAINING ONE OR MORE SUBSTRINGS INTO AN ARRAY OF SUBSTRINGS...
Definition: parstr.f:37
This module declares and initializes the BMISS variable.
Definition: modv_BMISS.f90:9
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 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
function invwin(NODE, LUN, INV1, INV2)
THIS FUNCTION LOOKS FOR A SPECIFIED NODE WITHIN THE PORTION OF THE CURRENT SUBSET BUFFER BOUNDED BY T...
Definition: invwin.f:48
subroutine ufbseq(LUNIN, USR, I1, I2, IRET, STR)
This subroutine reads or writes an entire sequence of data values from or to the BUFR data subset tha...
Definition: ufbseq.f:157
function invtag(NODE, LUN, INV1, INV2)
THIS FUNCTION LOOKS FOR A SPECIFIED MNEMONIC WITHIN THE PORTION OF THE CURRENT SUBSET BUFFER BOUNDED ...
Definition: invtag.f:49