NCEPLIBS-bufr  11.7.0
 All Data Structures Files Functions Variables Pages
tabsub.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE BUILDS THE ENTIRE JUMP/LINK TREE (I.E.,
5 C> INCLUDING RECURSIVELY RESOLVING ALL "CHILD" MNEMONICS) FOR A TABLE
6 C> A MNEMONIC (NEMO) WITHIN THE INTERNAL JUMP/LINK TABLE.
7 C>
8 C> PROGRAM HISTORY LOG:
9 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
10 C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
11 C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
12 C> ROUTINE "BORT"
13 C> 2000-09-19 J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA
14 C> USING THE OPERATOR DESCRIPTORS (BUFR TABLE
15 C> C) FOR CHANGING WIDTH AND CHANGING SCALE
16 C> 2003-11-04 J. ATOR -- ADDED DOCUMENTATION
17 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
18 C> INTERDEPENDENCIES
19 C> 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
20 C> INCREASED FROM 15000 TO 16000 (WAS IN
21 C> VERIFICATION VERSION); UNIFIED/PORTABLE FOR
22 C> WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS
23 C> MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
24 C> TERMINATES ABNORMALLY
25 C> 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS
26 C> 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR
27 C> 2012-04-19 J. ATOR -- FIXED BUG FOR CASES WHERE A TABLE C OPERATOR
28 C> IMMEDIATELY FOLLOWS A TABLE D SEQUENCE
29 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
30 C> 2016-05-24 J. ATOR -- STORE TABLE C OPERATORS IN MODULE BITMAPS
31 C> 2017-04-03 J. ATOR -- ADD A DIMENSION TO ALL TCO ARRAYS SO THAT
32 C> EACH SUBSET DEFINITION IN THE JUMP/LINK
33 C> TABLE HAS ITS OWN SET OF TABLE C OPERATORS
34 C>
35 C> USAGE: CALL TABSUB (LUN, NEMO)
36 C> INPUT ARGUMENT LIST:
37 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
38 C> NEMO - CHARACTER*8: TABLE A MNEMONIC
39 C>
40 C> THIS ROUTINE CALLS: BORT INCTAB IOKOPER NEMTAB
41 C> NEMTBD TABENT
42 C> THIS ROUTINE IS CALLED BY: MAKESTAB
43 C> Normally not called by any application
44 C> programs.
45 C>
46  SUBROUTINE tabsub(LUN,NEMO)
47 
48  USE moda_tables
49  USE moda_nmikrp
50  USE moda_nrv203
51  USE moda_bitmaps
52 
53  COMMON /tabccc/ icdw,icsc,icrv,incw
54 
55  CHARACTER*128 bort_str
56  CHARACTER*8 nemo,nems
57  CHARACTER*1 tab
58  dimension drop(10),jmp0(10),nodl(10),ntag(10,2)
59  LOGICAL drop,ltamc
60 
61  DATA maxlim /10/
62 
63 C-----------------------------------------------------------------------
64 C-----------------------------------------------------------------------
65 
66 C CHECK THE MNEMONIC
67 C ------------------
68 
69 C Note that Table A mnemonics, in addition to being stored within
70 C internal BUFR Table A array TABA(*,LUN), are also stored as
71 C Table D mnemonics within internal BUFR Table D array TABD(*,LUN).
72 C Thus, the following test is valid.
73 
74  CALL nemtab(lun,nemo,idn,tab,itab)
75  IF(tab.NE.'D') goto 900
76 
77 C STORE A SUBSET NODE AND JUMP/LINK THE TREE
78 C ------------------------------------------
79 
80  CALL inctab(nemo,'SUB',node)
81  jump(node) = node+1
82  jmpb(node) = 0
83  link(node) = 0
84  ibt(node) = 0
85  irf(node) = 0
86  isc(node) = 0
87 
88  CALL nemtbd(lun,itab,nseq,nem(1,1),irp(1,1),krp(1,1))
89  ntag(1,1) = 1
90  ntag(1,2) = nseq
91  jmp0(1) = node
92  nodl(1) = node
93  limb = 1
94 
95  icdw = 0
96  icsc = 0
97  icrv = 1
98  incw = 0
99 
100  ibtnrv = 0
101  ipfnrv = 0
102 
103  IF(ntamc+1.GT.mxtamc) goto 913
104  inodtamc(ntamc+1) = node
105  ntco(ntamc+1) = 0
106  ltamc = .false.
107 
108 C THIS LOOP RESOLVES ENTITIES IN A SUBSET BY EMULATING RECURSION
109 C --------------------------------------------------------------
110 
111 1 DO n=ntag(limb,1),ntag(limb,2)
112 
113  ntag(limb,1) = n+1
114  drop(limb) = n.EQ.ntag(limb,2)
115 
116  CALL nemtab(lun,nem(n,limb),idn,tab,itab)
117  nems = nem(n,limb)
118 
119 C SPECIAL TREATMENT FOR CERTAIN OPERATOR DESCRIPTORS (TAB=C)
120 C ----------------------------------------------------------
121 
122  IF(tab.EQ.'C') THEN
123  READ(nems,'(3X,I3)') iyyy
124  IF(itab.EQ.1) THEN
125  IF(iyyy.NE.0) THEN
126  IF(icdw.NE.0) goto 907
127  icdw = iyyy-128
128  ELSE
129  icdw = 0
130  ENDIF
131  ELSEIF(itab.EQ.2) THEN
132  IF(iyyy.NE.0) THEN
133  IF(icsc.NE.0) goto 908
134  icsc = iyyy-128
135  ELSE
136  icsc = 0
137  ENDIF
138  ELSEIF(itab.EQ.3) THEN
139  IF(iyyy.EQ.0) THEN
140 
141 C Stop applying new reference values to subset nodes.
142 C Instead, revert to the use of standard Table B values.
143 
144  IF(ipfnrv.EQ.0) goto 911
145  DO jj=ipfnrv,nnrv
146  ienrv(jj) = ntab
147  ENDDO
148  ipfnrv = 0
149  ELSEIF(iyyy.EQ.255) THEN
150 
151 C End the definition of new reference values.
152 
153  ibtnrv = 0
154  ELSE
155 
156 C Begin the definition of new reference values.
157 
158  IF(ibtnrv.NE.0) goto 909
159  ibtnrv = iyyy
160  ENDIF
161  ELSEIF(itab.EQ.7) THEN
162  IF(iyyy.GT.0) THEN
163  IF(icdw.NE.0) goto 907
164  IF(icsc.NE.0) goto 908
165  icdw = ((10*iyyy)+2)/3
166  icsc = iyyy
167  icrv = 10**iyyy
168  ELSE
169  icsc = 0
170  icdw = 0
171  icrv = 1
172  ENDIF
173  ELSEIF(itab.EQ.8) THEN
174  incw = iyyy
175  ELSEIF((itab.GE.21).AND.(iokoper(nems).EQ.1)) THEN
176 
177 C Save the location of this operator within the
178 C jump/link table, for possible later use.
179 
180  IF(.NOT.ltamc) THEN
181  ltamc = .true.
182  ntamc = ntamc+1
183  END IF
184  IF(ntco(ntamc)+1.GT.mxtco) goto 912
185  ntco(ntamc) = ntco(ntamc)+1
186  ctco(ntamc,ntco(ntamc)) = nems(1:6)
187  inodtco(ntamc,ntco(ntamc)) = ntab
188  ENDIF
189  ELSE
190  nodl(limb) = ntab+1
191  irep = irp(n,limb)
192  iknt = krp(n,limb)
193  jum0 = jmp0(limb)
194  CALL tabent(lun,nems,tab,itab,irep,iknt,jum0)
195  ENDIF
196 
197  IF(tab.EQ.'D') THEN
198 
199 C Note here how a new tree "LIMB" is created (and is then
200 C immediately recursively resolved) whenever a Table D mnemonic
201 C contains another Table D mnemonic as one of its children.
202 
203  limb = limb+1
204  IF(limb.GT.maxlim) goto 901
205  CALL nemtbd(lun,itab,nseq,nem(1,limb),irp(1,limb),krp(1,limb))
206  ntag(limb,1) = 1
207  ntag(limb,2) = nseq
208  jmp0(limb) = ntab
209  goto 1
210  ELSEIF(drop(limb)) THEN
211 2 link(nodl(limb)) = 0
212  limb = limb-1
213  IF(limb.EQ.0 ) THEN
214  IF(icrv.NE.1) goto 904
215  IF(icdw.NE.0) goto 902
216  IF(icsc.NE.0) goto 903
217  IF(incw.NE.0) goto 905
218  IF(ibtnrv.NE.0) goto 910
219  IF(ipfnrv.NE.0) THEN
220 
221 C One or more new reference values were defined for this
222 C subset, but there was no subsequent 2-03-000 operator,
223 C so set all IENRV(*) values for this subset to point to
224 C the last element of the subset within the jump/link table.
225 C Note that, if there had been a subsequent 2-03-000
226 C operator, then these IENRV(*) values would have already
227 C been properly set above.
228 
229  DO jj=ipfnrv,nnrv
230  ienrv(jj) = ntab
231  ENDDO
232  ENDIF
233  goto 100
234  ENDIF
235  IF(drop(limb)) goto 2
236  link(nodl(limb)) = ntab+1
237  goto 1
238  ELSEIF(tab.NE.'C') THEN
239  link(nodl(limb)) = ntab+1
240  ENDIF
241 
242  ENDDO
243 
244  goto 906
245 
246 C EXITS
247 C -----
248 
249 100 RETURN
250 900 WRITE(bort_str,'("BUFRLIB: TABSUB - SUBSET NODE NOT IN TABLE D '//
251  . '(TAB=",A,") FOR INPUT MNEMONIC ",A)') tab,nemo
252  CALL bort(bort_str)
253 901 WRITE(bort_str,'("BUFRLIB: TABSUB - THERE ARE TOO MANY NESTED '//
254  . 'TABLE D SEQUENCES (TREES) WITHIN INPUT MNEMONIC ",A," - THE '//
255  . 'LIMIT IS",I4)') nemo,maxlim
256  CALL bort(bort_str)
257 902 WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-01-YYY OPERATOR WAS '//
258  . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
259  CALL bort(bort_str)
260 903 WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-02-YYY OPERATOR WAS '//
261  . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
262  CALL bort(bort_str)
263 904 WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-07-YYY OPERATOR WAS '//
264  . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
265  CALL bort(bort_str)
266 905 WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-08-YYY OPERATOR WAS '//
267  . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
268  CALL bort(bort_str)
269 906 WRITE(bort_str,'("BUFRLIB: TABSUB - ENTITIES WERE NOT '//
270  . 'SUCCESSFULLY RESOLVED (BY EMULATING RESURSION) FOR SUBSET '//
271  . 'DEFINED BY TBL A MNEM. ",A)') nemo
272  CALL bort(bort_str)
273 907 WRITE(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '//
274  . 'CHANGE DATA WIDTH OPERATIONS IN THE TREE BUILT FROM INPUT ' //
275  . 'MNEMONIC ",A)') nemo
276  CALL bort(bort_str)
277 908 WRITE(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '//
278  . 'CHANGE DATA SCALE OPERATIONS IN THE TREE BUILT FROM INPUT ' //
279  . 'MNEMONIC ",A)') nemo
280  CALL bort(bort_str)
281 909 WRITE(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '//
282  . 'CHANGE REF VALUE OPERATIONS IN THE TREE BUILT FROM INPUT ' //
283  . 'MNEMONIC ",A)') nemo
284  CALL bort(bort_str)
285 910 WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-03-YYY OPERATOR WAS '//
286  . 'APPLIED WITHOUT ANY SUBSEQUENT 2-03-255 OPERATOR FOR '//
287  . 'INPUT MNEMONIC ",A)') nemo
288  CALL bort(bort_str)
289 911 WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-03-000 OPERATOR WAS '//
290  . 'ENCOUNTERED WITHOUT ANY PRIOR 2-03-YYY OPERATOR FOR '//
291  . 'INPUT MNEMONIC ",A)') nemo
292  CALL bort(bort_str)
293 912 CALL bort('BUFRLIB: TABSUB - MXTCO OVERFLOW')
294 913 CALL bort('BUFRLIB: TABSUB - MXTAMC OVERFLOW')
295  END
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 tabent(LUN, NEMO, TAB, ITAB, IREP, IKNT, JUM0)
THIS SUBROUTINE BUILDS AND STORES AN ENTRY FOR A TABLE B OR TABLE D MNEMONIC (NEMO) WITHIN THE INTERN...
Definition: tabent.f:51
subroutine inctab(ATAG, ATYP, NODE)
THIS SUBROUTINE RETURNS THE NEXT AVAILABLE POSITIONAL INDEX FOR WRITING INTO THE INTERNAL JUMP/LINK T...
Definition: inctab.f:43
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
subroutine tabsub(LUN, NEMO)
THIS SUBROUTINE BUILDS THE ENTIRE JUMP/LINK TREE (I.E., INCLUDING RECURSIVELY RESOLVING ALL "CHILD" M...
Definition: tabsub.f:46
subroutine nemtab(LUN, NEMO, IDN, TAB, IRET)
This subroutine returns information about a descriptor from the internal DX BUFR tables, based on the mnemonic associated with that descriptor.
Definition: nemtab.f:44
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
subroutine nemtbd(LUN, ITAB, NSEQ, NEMS, IRPS, KNTS)
This subroutine returns information about a Table D descriptor from the internal DX BUFR tables...
Definition: nemtbd.f:54
INTEGER function iokoper(NEMO)
This function determines whether a specified mnemonic is a Table C operator supported by the BUFRLIB ...
Definition: iokoper.f:23