NCEPLIBS-bufr  11.7.0
 All Data Structures Files Functions Variables Pages
makestab.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE
5 C> WITHIN MODULE TABLES, USING THE INFORMATION WITHIN THE
6 C> INTERNAL BUFR TABLE ARRAYS (WITHIN MODULE TABABD) FOR ALL OF
7 C> THE LUN (I.E., I/O STREAM INDEX) VALUES THAT ARE CURRENTLY DEFINED TO
8 C> THE BUFR ARCHIVE LIBRARY SOFTWARE. NOTE THAT THE ENTIRE JUMP/LINK
9 C> TABLE WILL ALWAYS BE COMPLETELY RECONSTRUCTED FROM SCRATCH, EVEN IF
10 C> SOME OF THE INFORMATION WITHIN THE INTERNAL BUFR TABLE ARRAYS
11 C> ALREADY EXISTED THERE AT THE TIME OF THE PREVIOUS CALL TO THIS
12 C> SUBROUTINE, BECAUSE THERE MAY HAVE BEEN OTHER EVENTS THAT HAVE TAKEN
13 C> PLACE SINCE THE PREVIOUS CALL TO THIS SUBROUTINE THAT HAVE NOT YET
14 C> BEEN REFLECTED WITHIN THE INTERNAL JUMP/LINK TABLE, SUCH AS, E.G.
15 C> THE UNLINKING OF AN LUN VALUE FROM THE BUFR ARCHIVE LIBRARY SOFTWARE
16 C> VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE CLOSBF.
17 C>
18 C> PROGRAM HISTORY LOG:
19 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
20 C> 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
21 C> ARRAYS IN ORDER TO HANDLE BIGGER FILES
22 C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
23 C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
24 C> ROUTINE "BORT"
25 C> 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
26 C> OPENED AT ONE TIME INCREASED FROM 10 TO 32
27 C> (NECESSARY IN ORDER TO PROCESS MULTIPLE
28 C> BUFR FILES UNDER THE MPI)
29 C> 2003-11-04 J. ATOR -- ADDED DOCUMENTATION
30 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
31 C> INTERDEPENDENCIES
32 C> 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
33 C> INCREASED FROM 15000 TO 16000 (WAS IN
34 C> VERIFICATION VERSION); UNIFIED/PORTABLE FOR
35 C> WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS
36 C> MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
37 C> TERMINATES ABNORMALLY; NOW ALLOWS FOR THE
38 C> POSSIBILITY THAT A CONNECTED FILE MAY NOT
39 C> CONTAIN ANY DICTIONARY TABLE INFO (E.G.,
40 C> AN EMPTY FILE), SUBSEQUENT CONNECTED FILES
41 C> WHICH ARE NOT EMPTY WILL NO LONGER GET
42 C> TRIPPED UP BY THIS (THIS AVOIDS THE NEED
43 C> FOR AN APPLICATION PROGRAM TO DISCONNECT
44 C> ANY EMPTY FILES VIA A CALL TO CLOSBF)
45 C> 2009-03-18 J. WOOLLEN -- ADDED LOGIC TO RESPOND TO THE CASES WHERE
46 C> AN INPUT FILE'S TABLES CHANGE IN MIDSTREAM.
47 C> THE NEW LOGIC MOSTLY ADDRESSES CASES WHERE
48 C> OTHER FILES ARE CONNECTED TO THE TABLES OF
49 C> THE FILE WHOSE TABLES HAVE CHANGED.
50 C> 2009-06-25 J. ATOR -- TWEAK WOOLLEN LOGIC TO HANDLE SPECIAL CASE
51 C> WHERE TABLE WAS RE-READ FOR A PARTICULAR
52 C> LOGICAL UNIT BUT IS STILL THE SAME ACTUAL
53 C> TABLE AS BEFORE AND IS STILL SHARING THAT
54 C> TABLE WITH A DIFFERENT LOGICAL UNIT
55 C> 2009-11-17 J. ATOR -- ADDED CHECK TO PREVENT WRITING OUT OF TABLE
56 C> INFORMATION WHEN A TABLE HAS BEEN RE-READ
57 C> WITHIN A SHARED LOGICAL UNIT BUT HASN'T
58 C> REALLY CHANGED
59 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
60 C> 2017-04-03 J. ATOR -- INCLUDE MODULE BITMAPS AND INITIALIZATION
61 C> OF NTAMC
62 C>
63 C> USAGE: CALL MAKESTAB
64 C>
65 C> REMARKS:
66 C> THIS ROUTINE CALLS: BORT CHEKSTAB CLOSMG CPBFDX
67 C> ERRWRT ICMPDX ISHRDX STRCLN
68 C> TABSUB WRDXTB
69 C> THIS ROUTINE IS CALLED BY: RDBFDX RDMEMM RDUSDX READDX
70 C> READERME READS3
71 C> Normally not called by any application
72 C> programs.
73 C>
74  SUBROUTINE makestab
75 
76  USE modv_bmiss
77  USE moda_usrint
78  USE moda_stbfr
79  USE moda_lushr
80  USE moda_xtab
81  USE moda_tababd
82  USE moda_tables
83  USE moda_nrv203
84  USE moda_bitmaps
85 
86  COMMON /quiet/ iprt
87 
88  CHARACTER*128 bort_str,errstr
89  CHARACTER*8 nemo
90  LOGICAL expand
91 
92 C-----------------------------------------------------------------------
93 C-----------------------------------------------------------------------
94 
95 C RESET POINTER TABLE AND STRING CACHE
96 C ------------------------------------
97 
98  ntab = 0
99  nnrv = 0
100  ntamc = 0
101  CALL strcln
102 
103 C FIGURE OUT WHICH UNITS SHARE TABLES
104 C -----------------------------------
105 
106 C The LUS array is static between calls to this subroutine, and it
107 C keeps track of which logical units share dictionary table
108 C information:
109 C if LUS(I) = 0, then IOLUN(I) does not share dictionary table
110 C information with any other logical unit
111 C if LUS(I) > 0, then IOLUN(I) shares dictionary table
112 C information with logical unit IOLUN(LUS(I))
113 C if LUS(I) < 0, then IOLUN(I) does not now, but at one point in
114 C the past, shared dictionary table information
115 C with logical unit IOLUN(ABS(LUS(I)))
116 
117 C The XTAB array is non-static and is recomputed within the below
118 C loop during each call to this subroutine:
119 C if XTAB(I) = .TRUE., then the dictionary table information
120 C has changed for IOLUN(I) since the last
121 C call to this subroutine
122 C if XTAB(I) = .FALSE., then the dictionary table information
123 C has not changed for IOLUN(I) since the
124 C last call to this subroutine
125 
126  DO lun=1,nfiles
127  xtab(lun) = .false.
128  IF(iolun(lun).EQ.0) THEN
129 
130 C Logical unit IOLUN(LUN) is not defined to the BUFRLIB.
131 
132  lus(lun) = 0
133  ELSE IF(mtab(1,lun).EQ.0) THEN
134 
135 C New dictionary table information has been read for logical
136 C unit IOLUN(LUN) since the last call to this subroutine.
137 
138  xtab(lun) = .true.
139  IF(lus(lun).NE.0) THEN
140  IF(iolun(abs(lus(lun))).EQ.0) THEN
141  lus(lun) = 0
142  ELSE IF(lus(lun).GT.0) THEN
143 
144 C IOLUN(LUN) was sharing table information with logical
145 C unit IOLUN(LUS(LUN)), so check whether the table
146 C information has really changed. If not, then IOLUN(LUN)
147 C just re-read a copy of the exact same table information
148 C as before, and therefore it can continue to share with
149 C logical unit IOLUN(LUS(LUN)).
150 
151  IF(icmpdx(lus(lun),lun).EQ.1) THEN
152  xtab(lun) = .false.
153  CALL cpbfdx(lus(lun),lun)
154  ELSE
155  lus(lun) = (-1)*lus(lun)
156  ENDIF
157  ELSE IF(icmpdx(abs(lus(lun)),lun).EQ.1) THEN
158 
159 C IOLUN(LUN) was not sharing table information with logical
160 C unit IOLUN(LUS(LUN)), but it did at one point in the past
161 C and now once again has the same table information as that
162 C logical unit. Since the two units shared table
163 C information at one point in the past, allow them to do
164 C so again.
165 
166  xtab(lun) = .false.
167  lus(lun) = abs(lus(lun))
168  CALL cpbfdx(lus(lun),lun)
169  ENDIF
170  ENDIF
171  ELSE IF(lus(lun).GT.0) THEN
172 
173 C Logical unit IOLUN(LUN) is sharing table information with
174 C logical unit IOLUN(LUS(LUN)), so make sure that the latter
175 C unit is still defined to the BUFRLIB.
176 
177  IF(iolun(lus(lun)).EQ.0) THEN
178  lus(lun) = 0
179  ELSE IF( xtab(lus(lun)) .AND.
180  + (icmpdx(lus(lun),lun).EQ.0) ) THEN
181 
182 C The table information for logical unit IOLUN(LUS(LUN))
183 C just changed (in midstream). If IOLUN(LUN) is an output
184 C file, then we will have to update it with the new table
185 C information later on in this subroutine. Otherwise,
186 C IOLUN(LUN) is an input file and is no longer sharing
187 C tables with IOLUN(LUS(LUN)).
188 
189  IF(iolun(lun).LT.0) lus(lun) = (-1)*lus(lun)
190  ENDIF
191  ELSE
192 
193 C Determine whether logical unit IOLUN(LUN) is sharing table
194 C information with any other logical units.
195 
196  lum = 1
197  DO WHILE ((lum.LT.lun).AND.(lus(lun).EQ.0))
198  IF(ishrdx(lum,lun).EQ.1) THEN
199  lus(lun) = lum
200  ELSE
201  lum = lum+1
202  ENDIF
203  ENDDO
204  ENDIF
205  ENDDO
206 
207 C INITIALIZE JUMP/LINK TABLES WITH SUBSETS/SEQUENCES/ELEMENTS
208 C -----------------------------------------------------------
209 
210  DO lun=1,nfiles
211 
212  IF(iolun(lun).NE.0 .AND. ntba(lun).GT.0) THEN
213 
214 C Reset any existing inventory pointers.
215 
216  IF(iomsg(lun).NE.0) THEN
217  IF(lus(lun).EQ.0) THEN
218  inc = (ntab+1)-mtab(1,lun)
219  ELSE
220  inc = mtab(1,lus(lun))-mtab(1,lun)
221  ENDIF
222  DO n=1,nval(lun)
223  inv(n,lun) = inv(n,lun)+inc
224  ENDDO
225  ENDIF
226 
227  IF(lus(lun).LE.0) THEN
228 
229 C The dictionary table information corresponding to logical
230 C unit IOLUN(LUN) has not yet been written into the internal
231 C jump/link table, so add it in now.
232 
233  CALL chekstab(lun)
234  DO itba=1,ntba(lun)
235  inod = ntab+1
236  nemo = taba(itba,lun)(4:11)
237  CALL tabsub(lun,nemo)
238  mtab(itba,lun) = inod
239  isc(inod) = ntab
240  ENDDO
241  ELSE IF( xtab(lus(lun)) .AND.
242  + (icmpdx(lus(lun),lun).EQ.0) ) THEN
243 
244 C Logical unit IOLUN(LUN) is an output file that is sharing
245 C table information with logical unit IOLUN(LUS(LUN)) whose
246 C table just changed (in midstream). Flush any existing data
247 C messages from IOLUN(LUN), then update the table information
248 C for this logical unit with the corresponding new table
249 C information from IOLUN(LUS(LUN)), then update IOLUN(LUN)
250 C itself with a copy of the new table information.
251 
252  lunit = abs(iolun(lun))
253  IF(iomsg(lun).NE.0) CALL closmg(lunit)
254  CALL cpbfdx(lus(lun),lun)
255  lundx = abs(iolun(lus(lun)))
256  CALL wrdxtb(lundx,lunit)
257  ENDIF
258 
259  ENDIF
260 
261  ENDDO
262 
263 C STORE TYPES AND INITIAL VALUES AND COUNTS
264 C -----------------------------------------
265 
266  DO node=1,ntab
267  IF(typ(node).EQ.'SUB') THEN
268  vali(node) = 0
269  knti(node) = 1
270  itp(node) = 0
271  ELSEIF(typ(node).EQ.'SEQ') THEN
272  vali(node) = 0
273  knti(node) = 1
274  itp(node) = 0
275  ELSEIF(typ(node).EQ.'RPC') THEN
276  vali(node) = 0
277  knti(node) = 0
278  itp(node) = 0
279  ELSEIF(typ(node).EQ.'RPS') THEN
280  vali(node) = 0
281  knti(node) = 0
282  itp(node) = 0
283  ELSEIF(typ(node).EQ.'REP') THEN
284  vali(node) = bmiss
285  knti(node) = irf(node)
286  itp(node) = 0
287  ELSEIF(typ(node).EQ.'DRS') THEN
288  vali(node) = 0
289  knti(node) = 1
290  itp(node) = 1
291  ELSEIF(typ(node).EQ.'DRP') THEN
292  vali(node) = 0
293  knti(node) = 1
294  itp(node) = 1
295  ELSEIF(typ(node).EQ.'DRB') THEN
296  vali(node) = 0
297  knti(node) = 0
298  itp(node) = 1
299  ELSEIF(typ(node).EQ.'NUM') THEN
300  vali(node) = bmiss
301  knti(node) = 1
302  itp(node) = 2
303  ELSEIF(typ(node).EQ.'CHR') THEN
304  vali(node) = bmiss
305  knti(node) = 1
306  itp(node) = 3
307  ELSE
308  goto 901
309  ENDIF
310  ENDDO
311 
312 C SET UP EXPANSION SEGMENTS FOR TYPE 'SUB', 'DRP', AND 'DRS' NODES
313 C ----------------------------------------------------------------
314 
315  newn = 0
316 
317  DO n=1,ntab
318  iseq(n,1) = 0
319  iseq(n,2) = 0
320  expand = typ(n).EQ.'SUB' .OR. typ(n).EQ.'DRP' .OR. typ(n).EQ.'DRS'
321  . .OR. typ(n).EQ.'REP' .OR. typ(n).EQ.'DRB'
322  IF(expand) THEN
323  iseq(n,1) = newn+1
324  noda = n
325  node = n+1
326  DO k=1,maxjl
327  knt(k) = 0
328  ENDDO
329  IF(typ(noda).EQ.'REP') knt(node) = knti(noda)
330  IF(typ(noda).NE.'REP') knt(node) = 1
331 
332 1 newn = newn+1
333  IF(newn.GT.maxjl) goto 902
334  jseq(newn) = node
335  knt(node) = max(knti(node),knt(node))
336 2 IF(jump(node)*knt(node).GT.0) THEN
337  node = jump(node)
338  goto 1
339  ELSE IF(link(node).GT.0) THEN
340  node = link(node)
341  goto 1
342  ELSE
343  node = jmpb(node)
344  IF(node.EQ.noda) goto 3
345  IF(node.EQ.0 ) goto 903
346  knt(node) = max(knt(node)-1,0)
347  goto 2
348  ENDIF
349 3 iseq(n,2) = newn
350  ENDIF
351  ENDDO
352 
353 C PRINT THE SEQUENCE TABLES
354 C ------------------------
355 
356  IF(iprt.GE.2) THEN
357  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
358  DO i=1,ntab
359  WRITE ( unit=errstr, fmt='(A,I5,2X,A10,A5,6I8)' )
360  . 'BUFRLIB: MAKESTAB ', i, tag(i), typ(i), jmpb(i), jump(i),
361  . link(i), ibt(i), irf(i), isc(i)
362  CALL errwrt(errstr)
363  ENDDO
364  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
365  CALL errwrt(' ')
366  ENDIF
367 
368 C EXITS
369 C -----
370 
371  RETURN
372 900 WRITE(bort_str,'("BUFRLIB: MAKESTAB - MNEMONIC ",A," IS '//
373  . 'DUPLICATED IN SUBSET: ",A)') nemo,tag(n1)
374  CALL bort(bort_str)
375 901 WRITE(bort_str,'("BUFRLIB: MAKESTAB - UNKNOWN TYPE ",A)')typ(node)
376  CALL bort(bort_str)
377 902 WRITE(bort_str,'("BUFRLIB: MAKESTAB - NUMBER OF JSEQ ENTRIES IN'//
378  . ' JUMP/LINK TABLE EXCEEDS THE LIMIT (",I6,")")') maxjl
379  CALL bort(bort_str)
380 903 WRITE(bort_str,'("BUFRLIB: MAKESTAB - NODE IS ZERO, FAILED TO '//
381  . 'CIRCULATE (TAG IS ",A,")")') tag(n)
382  CALL bort(bort_str)
383  END
subroutine cpbfdx(LUD, LUN)
THIS SUBROUTINE COPIES BUFR TABLE (DICTIONARY) MESSAGES FROM ONE LOCATION TO ANOTHER WITHIN INTERNAL ...
Definition: cpbfdx.f:35
This module contains array and variable declarations for use with any 2-03-YYY (change reference valu...
Definition: moda_nrv203.F:15
This module contains array and variable declarations used to store bitmaps internally within a data s...
Definition: moda_bitmaps.F:13
subroutine strcln
THIS SUBROUTINE RESETS THE MNEMONIC STRING CACHE IN THE BUFR INTERFACE (ARRAYS IN COMMON BLOCK /STCAC...
Definition: strcln.f:28
This module declares and initializes the BMISS variable.
Definition: modv_BMISS.f90:9
This module contains array and variable declarations used to store DX BUFR tables internally for mult...
Definition: moda_tababd.F:10
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
INTEGER function ishrdx(LUD, LUN)
This function determines whether the same DX BUFR Table is being shared between two Fortran logical u...
Definition: ishrdx.f:29
subroutine chekstab(LUN)
THIS SUBROUTINE CHECKS THAT AN INTERNAL BUFR TABLE REPRESENTATION IS SELF-CONSISTENT AND FULLY DEFINE...
Definition: chekstab.f:39
subroutine makestab
THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE WITHIN MODULE TABLES, USING THE INFORMATION WI...
Definition: makestab.f:74
subroutine wrdxtb(LUNDX, LUNOT)
THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES ASSOCIATED WITH THE BUFR FILE IN LUNDX TO THE...
Definition: wrdxtb.f:36
subroutine closmg(LUNIN)
This subroutine closes the BUFR message that is currently open for writing within internal arrays ass...
Definition: closmg.f:40
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:41
subroutine tabsub(LUN, NEMO)
THIS SUBROUTINE BUILDS THE ENTIRE JUMP/LINK TREE (I.E., INCLUDING RECURSIVELY RESOLVING ALL &quot;CHILD&quot; M...
Definition: tabsub.f:46
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
INTEGER function icmpdx(LUD, LUN)
This function determines whether the full set of associated DX BUFR Table information is identical be...
Definition: icmpdx.f:33