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