NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
igetrfel.f
Go to the documentation of this file.
1 C> @file
2 C> @author J @date 2016-05-27
3 
4 C> THIS FUNCTION CHECKS WHETHER THE INPUT ELEMENT REFERS TO
5 C> A PREVIOUS ELEMENT WITHIN THE SAME SUBSET VIA AN INTERNAL BITMAP.
6 C> IF SO, THEN THE REFERENCED ELEMENT IS RETURNED. IN ADDITION, IF
7 C> THE INPUT ELEMENT IS A 2-XX-255 MARKER OPERATOR, ITS SCALE FACTOR,
8 C> BIT WIDTH AND REFERENCE VALUE ARE SET INTERNALLY TO MATCH THOSE
9 C> OF THE REFERENCED ELEMENT.
10 C>
11 C> PROGRAM HISTORY LOG:
12 C> 2016-05-27 J. ATOR -- ORIGINAL AUTHOR
13 C> 2017-04-03 J. ATOR -- ADD A DIMENSION TO ALL TCO ARRAYS SO THAT
14 C> EACH SUBSET DEFINITION IN THE JUMP/LINK
15 C> TABLE HAS ITS OWN SET OF TABLE C OPERATORS
16 C>
17 C> USAGE: CALL IGETRFEL ( N, LUN )
18 C> INPUT ARGUMENT LIST:
19 C> N - INTEGER: SUBSET ELEMENT
20 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
21 C>
22 C> OUTPUT ARGUMENT LIST:
23 C> IGETRFEL - INTEGER: SUBSET ELEMENT REFERENCED BY ELEMENT N
24 C> WITHIN THE SAME SUBSET
25 C> 0 = INPUT ELEMENT DOES NOT REFER TO A PREVIOUS
26 C> ELEMENT, OR REFERENCED ELEMENT NOT FOUND
27 C>
28 C> REMARKS:
29 C> THIS ROUTINE CALLS: ADN30 BORT IBFMS IMRKOPR
30 C> LSTJPB NEMTAB
31 C> THIS ROUTINE IS CALLED BY: RCSTPL RDCMPS
32 C> Normally not called by any application
33 C> programs.
34 C>
35  INTEGER FUNCTION igetrfel ( N, LUN )
36 
37  USE moda_msgcwd
38  USE moda_usrint
39  USE moda_tables
40  USE moda_bitmaps
41  USE moda_nrv203
42 
43  character*128 bort_str
44  character*6 cflwopr,adn30,fxy
45  character*1 tab
46 
47 C-----------------------------------------------------------------------
48 C-----------------------------------------------------------------------
49 
50  igetrfel = 0
51 
52  node = inv( n, lun )
53 
54  IF ( itp(node) .GT. 1 ) THEN
55  IF ( node .EQ. lstnod ) THEN
56  lstnodct = lstnodct + 1
57  ELSE
58  lstnod = node
59  lstnodct = 1
60  END IF
61 C
62 C Does this subset definition contain any Table C operators
63 C with an X value of 21 or greater?
64 C
65  idxta = 0
66  IF ( ntamc .GT. 0 ) THEN
67  nodtam = lstjpb( node, lun, 'SUB' )
68  DO ii = 1, ntamc
69  IF ( nodtam .EQ. inodtamc(ii) ) THEN
70  idxta = ii
71  ntc = ntco(ii)
72  END IF
73  END DO
74  END IF
75  IF ( ( idxta .GT. 0 ) .AND. ( nbtm .GT. 0 ) ) THEN
76 
77 C Check whether this element references a previous element
78 C in the same subset via an internal bitmap. To do this,
79 C we first need to determine the appropriate "follow"
80 C operator (if any) corresponding to this element.
81 
82  cflwopr = 'XXXXXX'
83  IF ( imrkopr(tag(node)) .EQ. 1 ) THEN
84  cflwopr = tag(node)(1:3) // '000'
85  ELSE
86  CALL nemtab( lun, tag(node), idn, tab, nn )
87  IF ( tab .EQ. 'B' ) THEN
88  fxy = adn30(idn,6)
89  IF ( fxy(2:3) .EQ. '33' ) cflwopr = '222000'
90  END IF
91  END IF
92  IF ( cflwopr .EQ. 'XXXXXX' ) THEN
93  IF ( imrkopr(tag(node)) .EQ. 1 ) goto 900
94  RETURN
95  END IF
96 
97 C Now, check whether the appropriate "follow" operator was
98 C actually present in the subset. If there are multiple
99 C occurrences, we want the one that most recently precedes
100 C the element in question.
101 
102  nodflw = 0
103  DO jj = 1, ntc
104  IF ( ( ctco(idxta,jj) .EQ. cflwopr ) .AND.
105  . ( inodtco(idxta,jj) .GE. inode(lun) ) .AND.
106  . ( inodtco(idxta,jj) .LE. isc(inode(lun)) ) .AND.
107  . ( inodtco(idxta,jj) .LT. node ) )
108  . nodflw = inodtco(idxta,jj)
109  ENDDO
110  IF ( nodflw .EQ. 0 ) THEN
111  IF ( imrkopr(tag(node)) .EQ. 1 ) goto 901
112  RETURN
113  END IF
114 
115 C We found an appropriate corresponding "follow" operator,
116 C so now we need to look for a bitmap corresponding to
117 C this operator. First, look for a bitmap indicator.
118 
119  nodl236 = 0
120  nodbmap = 0
121  jj = 1
122  DO WHILE ( ( jj .LE. ntc ) .AND.
123  . ( inodtco(idxta,jj) .GE. inode(lun) ) .AND.
124  . ( inodtco(idxta,jj) .LE. isc(inode(lun)) ) .AND.
125  . ( nodbmap .EQ. 0 ) )
126  IF ( ctco(idxta,jj) .EQ. '236000' ) THEN
127  nodl236 = inodtco(idxta,jj)
128  IF ( inodtco(idxta,jj) .EQ. nodflw ) THEN
129  nodbmap = nodflw
130  END IF
131  ELSE IF ( ( ctco(idxta,jj) .EQ. '235000' ) .OR.
132  . ( ctco(idxta,jj) .EQ. '237255' ) ) THEN
133  nodl236 = 0
134  ELSE IF ( ( ctco(idxta,jj) .EQ. '237000' ) .AND.
135  . ( inodtco(idxta,jj) .EQ. nodflw ) .AND.
136  . ( nodl236 .NE. 0 ) ) THEN
137  nodbmap = nodl236
138  END IF
139  jj = jj + 1
140  END DO
141  IF ( nodbmap .EQ. 0 ) THEN
142 
143 C There was no valid bitmap indicator, so we'll just
144 C look for a bitmap after the "follow" indicator.
145 
146  nodbmap = nodflw
147  END IF
148 
149 C Find the corresponding bitmap.
150 
151  nn = 1
152  idxbtm = 0
153  DO WHILE ( ( idxbtm .EQ. 0 ) .AND.
154  . ( nn .LE. nval(lun) ) )
155  IF ( inv( nn, lun ) .GT. nodbmap ) THEN
156  ii = 1
157  DO WHILE ( ( idxbtm .EQ. 0 ) .AND.
158  . ( ii .LE. nbtm ) )
159  IF ( nn .EQ. istbtm(ii) ) THEN
160  idxbtm = ii
161  ELSE
162  ii = ii + 1
163  END IF
164  END DO
165  END IF
166  nn = nn + 1
167  END DO
168  IF ( idxbtm .EQ. 0 ) THEN
169  IF ( imrkopr(tag(node)) .EQ. 1 ) goto 902
170  RETURN
171  END IF
172 
173 C Use the bitmap to find the previous element in the
174 C subset that is referenced by the current element.
175 C Search backwards from the start of the bitmap, but
176 C make sure not to cross a 2-35-000 operator.
177 
178  IF ( lstnodct .GT. nbtmse(idxbtm) ) THEN
179  IF ( imrkopr(tag(node)) .EQ. 1 ) goto 903
180  RETURN
181  END IF
182  iemrk = iszbtm(idxbtm) - ibtmse(idxbtm,lstnodct) + 1
183  iect = 0
184  DO WHILE ( ( nn .GE. 1 ) .AND. ( igetrfel .EQ. 0 ) )
185  nodnn = inv( nn, lun )
186  IF ( nodnn .LE. nodbmap ) THEN
187  DO jj = 1, ntc
188  IF ( ( nodnn .EQ. inodtco(idxta,jj) ) .AND.
189  . ( ctco(idxta,jj) .EQ. '235000' ) ) THEN
190  IF ( imrkopr(tag(node)) .EQ. 1 ) goto 903
191  RETURN
192  END IF
193  END DO
194  IF ( itp(nodnn) .GT. 1 ) THEN
195  iect = iect + 1
196  IF ( iect .EQ. iemrk ) igetrfel = nn
197  END IF
198  END IF
199  nn = nn - 1
200  END DO
201  IF ( igetrfel .EQ. 0 ) THEN
202  IF ( imrkopr(tag(node)) .EQ. 1 ) goto 903
203  RETURN
204  END IF
205 
206  IF ( imrkopr(tag(node)) .EQ. 1 ) THEN
207 
208 C This element is a marker operator, so set the scale,
209 C reference value and bit width accordingly based on
210 C those of the previous referenced element.
211 
212  nodrfe = inv( igetrfel, lun )
213  isc(node) = isc(nodrfe)
214  IF ( tag(node)(1:3) .EQ. '225' ) THEN
215  ibt(node) = ibt(nodrfe) + 1
216  irf(node) = -1 * (2 ** ibt(nodrfe))
217  ELSE
218  ibt(node) = ibt(nodrfe)
219  irf(node) = irf(nodrfe)
220  IF ( nnrv .GT. 0 ) THEN
221  DO ii = 1, nnrv
222  IF ( ( nodrfe .NE. inodnrv(ii) ) .AND.
223  . ( tag(nodrfe)(1:8) .EQ. tagnrv(ii) ) .AND.
224  . ( nodrfe .GE. isnrv(ii) ) .AND.
225  . ( nodrfe .LE. ienrv(ii) ) ) THEN
226  irf(node) = nrv(ii)
227  RETURN
228  END IF
229  END DO
230  END IF
231  END IF
232  END IF
233 
234  END IF
235  END IF
236 
237  RETURN
238 900 WRITE(bort_str,'("BUFRLB: IGETRFEL - UNABLE TO DETERMINE '//
239  . 'FOLLOW OPERATOR FOR MARKER OPERATOR ",A)') tag(node)
240  CALL bort(bort_str)
241 901 WRITE(bort_str,'("BUFRLB: IGETRFEL - UNABLE TO FIND FOLLOW '//
242  . 'OPERATOR ",A," IN SUBSET")') cflwopr
243  CALL bort(bort_str)
244 902 WRITE(bort_str,'("BUFRLB: IGETRFEL - UNABLE TO FIND BITMAP '//
245  . 'FOR MARKER OPERATOR ",A)') tag(node)
246  CALL bort(bort_str)
247 903 WRITE(bort_str,'("BUFRLB: IGETRFEL - UNABLE TO FIND PREVIOUS '//
248  . 'ELEMENT REFERENCED BY MARKER OPERATOR ",A)') tag(node)
249  CALL bort(bort_str)
250  END
function lstjpb(NODE, LUN, JBTYP)
THIS FUNCTION SEARCHES BACKWARDS, BEGINNING FROM A GIVEN NODE WITHIN THE JUMP/LINK TABLE...
Definition: lstjpb.f:57
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
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
character *(*) function adn30(IDN, L30)
This function converts an FXY value from its bit-wise (integer) representation to its 5 or 6 characte...
Definition: adn30.f:28
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
INTEGER function igetrfel(N, LUN)
THIS FUNCTION CHECKS WHETHER THE INPUT ELEMENT REFERS TO A PREVIOUS ELEMENT WITHIN THE SAME SUBSET VI...
Definition: igetrfel.f:35
INTEGER function imrkopr(NEMO)
This function determines whether a specified mnemonic is a Table C marker operator.
Definition: imrkopr.f:21