NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
ufbtab.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Read one or more data values from every data subset in a
3 C> BUFR file
4 
5 C> This subroutine reads through every data subset in a BUFR file
6 C> and returns one or more specified data values from each subset.
7 C>
8 C> <p>This provides a useful way to scan the ranges of one or more
9 C> specified data values across an entire BUFR file.
10 C>
11 C> @author J. Woollen
12 C> @date 1994-01-06
13 C>
14 C> @param[in] LUNIN -- integer: Absolute value is Fortran logical
15 C> unit number for BUFR file
16 C> @param[out] TAB -- real*8(*,*): Data values
17 C> @param[in] I1 -- integer: Actual first dimension of TAB as allocated
18 C> within the calling program
19 C> @param[in] I2 -- integer: Actual second dimension of TAB as allocated
20 C> within the calling program
21 C> @param[out] IRET -- integer: Number of data subsets in BUFR file
22 C> @param[in] STR -- character*(*): String of blank-separated
23 C> Table B mnemonics, in one-to-one correspondence
24 C> with the number of data values that will be read
25 C> from each data subset within the first dimension of
26 C> TAB (see [DX BUFR Tables](@ref dfbftab) for further
27 C> information about Table B mnemonics)
28 C>
29 C> <p>It is the user's responsibility to ensure that TAB is dimensioned
30 C> sufficiently large enough to accommodate the number of data values
31 C> that are to be read from the BUFR file. Specifically, each row of
32 C> TAB will contain the data values read from a different data subset,
33 C> so the value I2 must be at least as large as the total number of data
34 C> subsets in the BUFR file.
35 C>
36 C> <p>If logical unit ABS(LUNIN) has already been opened
37 C> via a previous call to subroutine openbf(), then this subroutine
38 C> will save the current file position, rewind the file to the
39 C> beginning, read through the entire file, and then restore it to its
40 C> previous file position. Otherwise, if logical unit ABS(LUNIN) has
41 C> not already been opened via a previous call to subroutine openbf(),
42 C> then this subroutine will open it via an internal call to
43 C> subroutine openbf(), read through the entire file, and then close
44 C> it via an internal call to subroutine closbf().
45 C>
46 C> @remarks
47 C> - If LUNIN < 0, the number of data subsets in the BUFR file will
48 C> still be returned in IRET; however, STR will be ignored,
49 C> and all of the values returned in TAB will contain the current
50 C> placeholder value for "missing" data.
51 C> - If any of the Table B mnemonics in STR are replicated within the
52 C> data subset definition for the BUFR file, then this subroutine will
53 C> only return the value corresponding to the first occurrence of each
54 C> such mnemonic (counting from the beginning of the data subset
55 C> definition) within the corresponding row of TAB.
56 C>
57 C> <b>Program history log:</b>
58 C> | Date | Programmer | Comments |
59 C> | -----|------------|----------|
60 C> | 1994-01-06 | J. Woollen | Original author |
61 C> | 1998-07-08 | J. Woollen | Replaced call to Cray library routine "ABORT" with call to new internal routine bort() |
62 C> | 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32 |
63 C> | 2000-09-19 | J. Woollen | Maximum length increased from 10,000 to 20,000 bytes |
64 C> | 2002-05-14 | J. Woollen | Removed old Cray compiler directives |
65 C> | 2003-11-04 | D. Keyser | Modified to not abort when there are more than I2 data subsets, but instead just process first I2 subsets and print a diagnostic |
66 C> | 2003-11-04 | D. Keyser | Increased MAXJL from 15000 to 16000; modified to use rewnbf(); upgraded to allow reading from a file that has already been opened via openbf() |
67 C> | 2004-08-09 | J. Ator | Maximum message length increased from 20,000 to 50,000 bytes |
68 C> | 2005-09-16 | J. Woollen | upgraded to work for compressed BUFR messages, and to allow for LUNIN < 0 option |
69 C> | 2006-04-14 | J. Ator | Add declaration for CREF |
70 C> | 2007-01-19 | J. Ator | Replaced call to parseq with call to parstr() |
71 C> | 2009-04-21 | J. Ator | Use errwrt() |
72 C> | 2009-12-01 | J. Ator | Fix bug for compressed character strings which are identical across all subsets in a single messagE |
73 C> | 2010-05-07 | J. Ator | When calling ireadmg(), treat read error as EOF condition |
74 C> | 2012-03-02 | J. Ator | Use function ups() |
75 C> | 2012-09-15 | J. Woollen | Modified for C/I/O/BUFR interface; added IO type 'INX' to enable open and close for C file without closing FORTRAN file |
76 C> | 2014-11-20 | J. Ator | Ensure openbf() has been called at least once before calling status() |
77 C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
78 C> | 2016-12-19 | J. Woollen | Fix bug to prevent inventory overflow |
79 C>
80  SUBROUTINE ufbtab(LUNIN,TAB,I1,I2,IRET,STR)
81 
82  USE modv_bmiss
83  USE moda_usrint
84  USE moda_msgcwd
85  USE moda_bitbuf
86  USE moda_tables
87 
88  COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
89  COMMON /acmode/ iac
90  COMMON /quiet / iprt
91 
92  CHARACTER*(*) str
93  CHARACTER*128 bort_str,errstr
94  CHARACTER*40 cref
95  CHARACTER*10 tgs(100)
96  CHARACTER*8 subset,cval
97  equivalence(cval,rval)
98  LOGICAL openit,just_count
99  REAL*8 tab(i1,i2),rval,ups
100 
101  DATA maxtg /100/
102 
103 C-----------------------------------------------------------------------
104  mps(node) = 2**(ibt(node))-1
105  lps(lbit) = max(2**(lbit)-1,1)
106 C-----------------------------------------------------------------------
107 
108 C SET COUNTERS TO ZERO
109 C --------------------
110 
111  iret = 0
112  irec = 0
113  isub = 0
114  iacc = iac
115 
116 C CHECK FOR COUNT SUBSET ONLY OPTION (RETURNING THE BUFRLIB'S GLOBAL
117 C VALUE FOR MISSING IN OUTPUT ARRAY) INDICATED BY NEGATIVE UNIT
118 C ------------------------------------------------------------------
119 
120  lunit = abs(lunin)
121  just_count = lunin.LT.lunit
122 
123 C Make sure OPENBF has been called at least once before trying to
124 C call STATUS; otherwise, STATUS might try to access array space
125 C that hasn't yet been dynamically allocated.
126  CALL openbf(0,'FIRST',0)
127 
128  CALL status(lunit,lun,il,im)
129  openit = il.EQ.0
130 
131  IF(openit) THEN
132 
133 C OPEN BUFR FILE CONNECTED TO UNIT LUNIT IF IT IS NOT ALREADY OPEN
134 C ----------------------------------------------------------------
135 
136  CALL openbf(lunit,'INX',lunit)
137  ELSE
138 
139 C IF BUFR FILE ALREADY OPENED, SAVE POSITION & REWIND TO FIRST DATA MSG
140 C ---------------------------------------------------------------------
141 
142  CALL rewnbf(lunit,0)
143  ENDIF
144 
145  iac = 1
146 
147 C SET THE OUTPUT ARRAY VALUES TO THE BUFRLIB'S GLOBAL VALUE FOR
148 C MISSING (BMISS)
149 C -------------------------------------------------------------
150 
151  DO j=1,i2
152  DO i=1,i1
153  tab(i,j) = bmiss
154  ENDDO
155  ENDDO
156 
157  IF(just_count) THEN
158 
159 C COME HERE FOR COUNT ONLY OPTION (OUTPUT ARRAY VALUES REMAIN MISSING)
160 C --------------------------------------------------------------------
161 
162  DO WHILE(ireadmg(-lunit,subset,idate).GE.0)
163  iret = iret+nmsub(lunit)
164  ENDDO
165  goto 25
166  ENDIF
167 
168 C OTHERWISE, CHECK FOR SPECIAL TAGS IN STRING
169 C -------------------------------------------
170 
171  CALL parstr(str,tgs,maxtg,ntg,' ',.true.)
172  DO i=1,ntg
173  IF(tgs(i).EQ.'IREC') irec = i
174  IF(tgs(i).EQ.'ISUB') isub = i
175  ENDDO
176 
177 C READ A MESSAGE AND PARSE A STRING
178 C ---------------------------------
179 
180 10 IF(ireadmg(-lunit,subset,jdate).LT.0) goto 25
181  CALL string(str,lun,i1,0)
182  IF(irec.GT.0) nods(irec) = 0
183  IF(isub.GT.0) nods(isub) = 0
184 
185 C PARSE THE MESSAGE DEPENDING ON WHETHER COMPRESSED OR NOT
186 C --------------------------------------------------------
187 
188  CALL mesgbc(-lunit,mtyp,icmp)
189  IF(icmp.EQ.0) THEN
190  goto 15
191  ELSEIF(icmp.EQ.1) then
192  goto 115
193  ELSE
194  goto 900
195  ENDIF
196 
197 C ---------------------------------------------
198 C THIS BRANCH IS FOR UNCOMPRESSED MESSAGES
199 C ---------------------------------------------
200 C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
201 C ---------------------------------------------
202 
203 15 IF(nsub(lun).EQ.msub(lun)) goto 10
204  IF(iret+1.GT.i2) goto 99
205  iret = iret+1
206 
207  DO i=1,nnod
208  nods(i) = abs(nods(i))
209  ENDDO
210 
211 C PARSE THE STRING NODES FROM A SUBSET
212 C ------------------------------------
213 
214  mbit = mbyt(lun)*8 + 16
215  nbit = 0
216  n = 1
217  CALL usrtpl(lun,n,n)
218 20 IF(n+1.LE.nval(lun)) THEN
219  n = n+1
220  node = inv(n,lun)
221  mbit = mbit+nbit
222  nbit = ibt(node)
223  IF(itp(node).EQ.1) THEN
224  CALL upbb(ival,nbit,mbit,mbay(1,lun))
225  CALL usrtpl(lun,n,ival)
226  ENDIF
227  DO i=1,nnod
228  IF(nods(i).EQ.node) THEN
229  IF(itp(node).EQ.1) THEN
230  CALL upbb(ival,nbit,mbit,mbay(1,lun))
231  tab(i,iret) = ival
232  ELSEIF(itp(node).EQ.2) THEN
233  CALL upbb(ival,nbit,mbit,mbay(1,lun))
234  IF(ival.LT.mps(node)) tab(i,iret) = ups(ival,node)
235  ELSEIF(itp(node).EQ.3) THEN
236  cval = ' '
237  kbit = mbit
238  CALL upc(cval,nbit/8,mbay(1,lun),kbit,.true.)
239  tab(i,iret) = rval
240  ENDIF
241  nods(i) = -nods(i)
242  goto 20
243  ENDIF
244  ENDDO
245  DO i=1,nnod
246  IF(nods(i).GT.0) goto 20
247  ENDDO
248  ENDIF
249 
250 C UPDATE THE SUBSET POINTERS BEFORE NEXT READ
251 C -------------------------------------------
252 
253  ibit = mbyt(lun)*8
254  CALL upb(nbyt,16,mbay(1,lun),ibit)
255  mbyt(lun) = mbyt(lun) + nbyt
256  nsub(lun) = nsub(lun) + 1
257  IF(irec.GT.0) tab(irec,iret) = nmsg(lun)
258  IF(isub.GT.0) tab(isub,iret) = nsub(lun)
259  goto 15
260 
261 C ---------------------------------------------
262 C THIS BRANCH IS FOR COMPRESSED MESSAGES
263 C ---------------------------------------------
264 C STORE ANY MESSAGE AND/OR SUBSET COUNTERS
265 C ---------------------------------------------
266 
267 C CHECK ARRAY BOUNDS
268 C ------------------
269 
270 115 IF(iret+msub(lun).GT.i2) goto 99
271 
272 C STORE MESG/SUBS TOKENS
273 C ----------------------
274 
275  IF(irec.GT.0.OR.isub.GT.0) THEN
276  DO nsb=1,msub(lun)
277  IF(irec.GT.0) tab(irec,iret+nsb) = nmsg(lun)
278  IF(isub.GT.0) tab(isub,iret+nsb) = nsb
279  ENDDO
280  ENDIF
281 
282 C SETUP A NEW SUBSET TEMPLATE, PREPARE TO SUB-SURF
283 C ------------------------------------------------
284 
285  CALL usrtpl(lun,1,1)
286  ibit = mbyt(lun)
287  n = 0
288 
289 C UNCOMPRESS CHOSEN NODES INTO THE TAB ARRAY (FIRST OCCURANCES ONLY)
290 C ------------------------------------------------------------------
291 
292 C READ ELEMENTS LOOP
293 C ------------------
294 
295 120 DO n=n+1,nval(lun)
296  node = inv(n,lun)
297  nbit = ibt(node)
298  ityp = itp(node)
299 
300 C FIRST TIME IN RESET NODE INDEXES, OR CHECK FOR NODE(S) STILL NEEDED
301 C -------------------------------------------------------------------
302 
303  IF(n.EQ.1) THEN
304  DO i=1,nnod
305  nods(i) = abs(nods(i))
306  ENDDO
307  ELSE
308  DO i=1,nnod
309  IF(nods(i).GT.0) goto 125
310  ENDDO
311  goto 135
312  ENDIF
313 
314 C FIND THE EXTENT OF THE NEXT SUB-GROUP
315 C -------------------------------------
316 
317 125 IF(ityp.EQ.1.OR.ityp.EQ.2) THEN
318  CALL upb(lref,nbit,mbay(1,lun),ibit)
319  CALL upb(linc, 6,mbay(1,lun),ibit)
320  nibit = ibit + linc*msub(lun)
321  ELSEIF(ityp.EQ.3) THEN
322  cref=' '
323  CALL upc(cref,nbit/8,mbay(1,lun),ibit,.true.)
324  CALL upb(linc, 6,mbay(1,lun),ibit)
325  nibit = ibit + 8*linc*msub(lun)
326  ELSE
327  goto 120
328  ENDIF
329 
330 C PROCESS A TYPE1 NODE INTO NVAL
331 C ------------------------------
332 
333  IF(ityp.EQ.1) THEN
334  jbit = ibit + linc
335  CALL upb(ninc,linc,mbay(1,lun),jbit)
336  ival = lref+ninc
337  CALL usrtpl(lun,n,ival)
338  goto 120
339  ENDIF
340 
341 C LOOP OVER STRING NODES
342 C ----------------------
343 
344  DO i=1,nnod
345 
346 C CHOSEN NODES LOOP - KEEP TRACK OF NODES NEEDED AND NODES FOUND
347 C --------------------------------------------------------------
348 
349  IF(node.NE.nods(i)) goto 130
350  nods(i) = -nods(i)
351  lret = iret
352 
353 C PROCESS A FOUND NODE INTO TAB
354 C -----------------------------
355 
356  IF(ityp.EQ.1.OR.ityp.EQ.2) THEN
357  DO nsb=1,msub(lun)
358  jbit = ibit + linc*(nsb-1)
359  CALL upb(ninc,linc,mbay(1,lun),jbit)
360  ival = lref+ninc
361  lret = lret+1
362  IF(ninc.LT.lps(linc)) tab(i,lret) = ups(ival,node)
363  ENDDO
364  ELSEIF(ityp.EQ.3) THEN
365  DO nsb=1,msub(lun)
366  IF(linc.EQ.0) THEN
367  cval = cref
368  ELSE
369  jbit = ibit + linc*(nsb-1)*8
370  cval = ' '
371  CALL upc(cval,linc,mbay(1,lun),jbit,.true.)
372  ENDIF
373  lret = lret+1
374  tab(i,lret) = rval
375  ENDDO
376  ELSE
377  CALL bort('UFBTAB - INVALID ELEMENT TYPE SPECIFIED')
378  ENDIF
379 
380 C END OF LOOPS FOR COMPRESSED MESSAGE PARSING
381 C -------------------------------------------
382 
383 130 CONTINUE
384  ENDDO
385  ibit = nibit
386 
387 C END OF READ ELEMENTS LOOP
388 C -------------------------
389 
390  ENDDO
391 135 iret = iret+msub(lun)
392 
393 C END OF MESSAGE PARSING - GO BACK FOR ANOTHER
394 C --------------------------------------------
395 
396  goto 10
397 
398 C -------------------------------------------
399 C ERROR PROCESSING AND EXIT ROUTES BELOW
400 C -------------------------------------------
401 C EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW
402 C -------------------------------------------
403 
404 99 nrep = iret
405  DO WHILE(ireadsb(lunit).EQ.0)
406  nrep = nrep+1
407  ENDDO
408  DO WHILE(ireadmg(-lunit,subset,jdate).GE.0)
409  nrep = nrep+nmsub(lunit)
410  ENDDO
411  IF(iprt.GE.0) THEN
412  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
413  WRITE ( unit=errstr, fmt='(A,A,I8,A,A)' )
414  . 'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ',
415  . .GT.'IS LIMIT OF ', i2, ' IN THE 4TH ARG. (INPUT) - ',
416  . 'INCOMPLETE READ'
417  CALL errwrt(errstr)
418  WRITE ( unit=errstr, fmt='(A,I8,A,I8,A)' )
419  . '>>>UFBTAB STORED ', iret, ' REPORTS OUT OF ', nrep, '<<<'
420  CALL errwrt(errstr)
421  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
422  CALL errwrt(' ')
423  ENDIF
424 
425 
426 25 IF(openit) THEN
427 
428 C CLOSE BUFR FILE IF IT WAS OPENED HERE
429 C -------------------------------------
430 
431  CALL closbf(lunit)
432  ELSE
433 
434 C RESTORE BUFR FILE TO PREV. STATUS & POSITION IF NOT ORIG. OPENED HERE
435 C ---------------------------------------------------------------------
436 
437  CALL rewnbf(lunit,1)
438  ENDIF
439 
440  iac = iacc
441 
442 C EXITS
443 C -----
444 
445  RETURN
446 900 WRITE(bort_str,'("BUFRLIB: UFBTAB - INVALID COMPRESSION '//
447  . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '//
448  . 'ROUTINE MESGBC")') icmp
449  CALL bort(bort_str)
450  END
subroutine upbb(NVAL, NBITS, IBIT, IBAY)
THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER CONTAINED WITHIN NBITS BITS OF IBAY...
Definition: upbb.f:42
function ireadmg(LUNIT, SUBSET, IDATE)
This function calls BUFRLIB subroutine readmg() and passes back its return code as the function value...
Definition: ireadmg.f:39
subroutine upb(NVAL, NBITS, IBAY, IBIT)
THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER CONTAINED WITHIN NBITS BITS OF IBAY...
Definition: upb.f:49
function ireadsb(LUNIT)
This function calls BUFRLIB subroutine readsb() and passes back its return code as the function value...
Definition: ireadsb.f:30
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
subroutine usrtpl(LUN, INVN, NBMP)
THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL SUBSET ARRAYS IN MODULE USRINT FOR CASES OF ...
Definition: usrtpl.f:51
This module declares and initializes the BMISS variable.
Definition: modv_BMISS.f90:9
subroutine closbf(LUNIT)
This subroutine closes the connection between logical unit LUNIT and the BUFRLIB software.
Definition: closbf.f:34
subroutine upc(CHR, NCHR, IBAY, IBIT, CNVNULL)
THIS SUBROUTINE UNPACKS AND RETURNS A CHARACTER STRING OF LENGTH NCHR CONTAINED WITHIN NCHR BYTES OF ...
Definition: upc.f:49
subroutine mesgbc(LUNIN, MESGTYP, ICOMP)
THIS SUBROUTINE EXAMINES A BUFR MESSAGE AND RETURNS BOTH THE MESSAGE TYPE FROM SECTION 1 AND A MESSAG...
Definition: mesgbc.f:96
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
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 openbf(LUNIT, IO, LUNDX)
This subroutine connects a new file to the BUFRLIB software for input or output operations.
Definition: openbf.f:138
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:41
function nmsub(LUNIT)
This function returns the total number of data subsets available within the BUFR message that was mos...
Definition: nmsub.f:29
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
This module contains array and variable declarations used to store BUFR messages internally for multi...
Definition: moda_bitbuf.F:10
subroutine ufbtab(LUNIN, TAB, I1, I2, IRET, STR)
This subroutine reads through every data subset in a BUFR file and returns one or more specified data...
Definition: ufbtab.f:80
REAL *8 function ups(IVAL, NODE)
THIS FUNCTION UNPACKS A REAL*8 USER VALUE FROM A PACKED BUFR INTEGER BY APPLYING THE PROPER SCALE AND...
Definition: ups.f:31
subroutine rewnbf(LUNIT, ISR)
THIS SUBROUTINE, DEPENDING ON THE VALUE OF ISR, WILL EITHER: 1) STORE THE CURRENT PARAMETERS ASSOCIAT...
Definition: rewnbf.f:64