NCEPLIBS-w3emc  2.11.0
w3fi88.f
Go to the documentation of this file.
1 C> @file
2 C> @brief BUFR message decoder
3 C> @author Bill Cavanaugh @date 1988-08-31
4 
5 C> This set of routines will decode a bufr message and
6 C> place information extracted from the bufr message into selected
7 C> arrays for the user. the array kdata can now be sized by the user
8 C> by indicating the maximum number of subsets and the maximum
9 C> number of descriptors that are expected in the course of decoding
10 C> selected input data. this allows for realistic sizing of kdata
11 C> and the mstack arrays. this version also allows for the inclusion
12 C> of the unit numbers for tables b and d into the
13 C> argument list. this routine does not include ifod processing.
14 C>
15 C> Program history log:
16 C> - Bill Cavanaugh 1988-08-31
17 C> - Bill Cavanaugh 1990-12-07 Now Utilizing gbyte routines to gather
18 C> and separate bit fields. this should improve
19 C> (decrease) the time it takes to decode any
20 C> bufr message. have entered coding that will
21 C> permit processing bufr editions 1 and 2.
22 C> improved and corrected the conversion into
23 C> ifod format of decoded bufr messages.
24 C> - Bill Cavanaugh 1991-01-18 Program/routines modified to properly handle
25 C> serial profiler data.
26 C> - Bill Cavanaugh 1991-04-04 Modified to handle text supplied thru
27 C> descriptor 2 05 yyy.
28 C> - Bill Cavanaugh 1991-04-17 Errors in extracting and scaling data
29 C> corrected. improved handling of nested
30 C> queue descriptors is added.
31 C> - Bill Cavanaugh 1991-05-10 Array 'data' has been enlarged to real*8
32 C> to better contain very large numbers more
33 C> accurately. the preious size real*4 could not
34 C> contain sufficient significant digits.
35 C> coding has been introduced to process new
36 C> table c descriptor 2 06 yyy which permits in
37 C> line processing of a local descriptor even if
38 C> the descriptor is not contained in the users
39 C> table b.
40 C> a second routine to process ifod messages
41 C> (ifod0) has been removed in favor of the
42 C> improved processing of the one
43 C> remaining (ifod1).
44 C> new coding has been introduced to permit
45 C> processing of bufr messages based on bufr
46 C> edition up to and including edition 2.
47 C> please note increased size requirements
48 C> for arrays ident(20) and iptr(40).
49 C> - Bill Cavanaugh 1991-07-26 Add Array mtime to calling sequence to
50 C> permit inclusion of receipt/transfer times
51 C> to ifod messages.
52 C> - Bill Cavanaugh 1991-09-25 All processing of decoded bufr data into
53 C> ifod (a local use reformat of bufr data)
54 C> has been isolated from this set of routines.
55 C> for those interested in the ifod form,
56 C> see w3fl05 in the w3lib routines.
57 C> processing of bufr messages containing
58 C> delayed replication has been altered so that
59 C> single subsets (reports) and and a matching
60 C> descriptor list for that particular subset
61 C> will be passed to the user will be passed to
62 C> the user one at a time to assure that each
63 C> subset can be fully defined with a minimum
64 C> of reprocessing.
65 C> processing of associated fields has been
66 C> tested with messages containing non-compressed
67 C> data.
68 C> in order to facilitate user processing
69 C> a matching list of scale factors are included
70 C> with the expanded descriptor list (mstack).
71 C> - Bill Cavanaugh 1991-11-21 Processing of descriptor 2 03 yyy
72 C> has corrected to agree with fm94 standards.
73 C> - Bill Cavanaugh 1991-12-19 Calls to fi8803 and fi8804 have been
74 C> corrected to agree called program argument
75 C> list. some additional entries have been
76 C> included for communicating with data access
77 C> routines. additional error exit provided for
78 C> the case where table b is damaged.
79 C> - Bill Cavanaugh 1992-01-24 Routines fi8801, fi8803 and fi8804
80 C> have been modified to handle associated fields
81 C> all descriptors are set to echo to mstack(1,n)
82 C> - Bill Cavanaugh 1992-05-21 Further expansion of information collected
83 C> from within upper air soundings has produced
84 C> the necessity to expand some of the processing
85 C> and output arrays. (see remarks below)
86 C> corrected descriptor denoting height of
87 C> each wind level for profiler conversions.
88 C> - Bill Cavanaugh 1992-07-23 Expansion of table b requires adjustment
89 C> of arrays to contain table b values needed to
90 C> assist in the decoding process.
91 C> arrays containing data from table b
92 C> - KFXY1 Descriptor
93 C> - ANAME1 Descriptor name
94 C> - AUNIT1 Units for descriptor
95 C> - ISCAL1 Scale for value of descriptor
96 C> - IRFVL1 Reference value for descriptor
97 C> - IWIDE1 Bit width for value of descriptor
98 C> - Bill Cavanaugh 1992-09-09 First encounter with operator descriptor
99 C> 2 05 yyy showed error in decoding. that error
100 C> is corrected with this implementation. further
101 C> testing of upper air data has encountered
102 C> the condition of large (many level) soundings
103 C> arrays in the decoder have been expanded (again)
104 C> to allow for this condition.
105 C> - Bill Cavanaugh 1992-10-02 Modified routine to reformat profiler data
106 C> (fi8809) to show descriptors, scale value and
107 C> data in proper order. corrected an error that
108 C> prevented user from assigning the second dimension
109 C> of kdata(500,*).
110 C> - Bill Cavanaugh 1992-10-20 Removed error that prevented full
111 C> implementation of previous corrections and
112 C> made corrections to table b to bring it up to
113 C> date. changes include proper reformat of profiler
114 C> data and user capability for assigning second
115 C> dimension of kdata array.
116 C> - Bill Cavanaugh 1992-12-09 Thanks to dennis keyser for the suggestions
117 C> and coding, this implementation will allow the
118 C> inclusion of unit numbers for tables b & d, and
119 C> in addition allows for realistic sizing of kdata
120 C> and mstack arrays by the user. as of this
121 C> implementation, the upper size limit for a bufr
122 C> message allows for a message size greater than
123 C> 15000 bytes.
124 C> - Bill Cavanaugh 1993-01-26 Routine fi8810 has been added to permit
125 C> reformatting of profiler data in edition 2.
126 C> - Bill Cavanaugh 1993-05-13 Routine fi8811 has been added to permit
127 C> processing of run-line encoding. this provides for
128 C> the handling of data for graphics products.
129 C> please note the addition of two arguments in the
130 C> calling sequence.
131 C> - Bill Cavanaugh 1993-12-01 Routine fi8803 to correct handling of
132 C> associated fields and arrays associated with
133 C> table b entries enlarged to handle larger table b
134 C> - Bill Cavanaugh 1994-05-25 Routines have been modified to construct a
135 C> modified table b i.e., it is tailored to contain o
136 C> those descriptors that will be used to decode
137 C> data in current and subsequent bufr messages.
138 C> table b and table d descriptors will be isolated
139 C> and merged with the main tables for use with
140 C> following bufr messages.
141 C> the descriptors indicating the replication of
142 C> descriptors and data are activated with this
143 C> implementation.
144 C> - Bill Cavanaugh 1994-08-30 Added statements that will allow use of
145 C> these routines directly on the cray with no
146 C> modification. handling od table d entries has been
147 C> modified to prevent loss of ancillary entries.
148 C> coding has been added to allow processing on
149 C> either an 8 byte word or 4 byte word machine.
150 C>
151 C> For those users of the bufr decoder that are
152 C> processing sets of bufr messages that include
153 C> type 11 messages, coding has been added to allow
154 C> the recovery of the added or modified table b
155 C> entries by writing them to a disk file available
156 C> to the user. this is accomplished with no change
157 C> to the calling sequence. table b entries will be
158 C> designated as follows:
159 C> IUNITB - Is the unit number for the master table b.
160 C> IUNITB+1 - Will be the unit number for the table b entries that are to be used
161 C> in the decoding of subsequent messages. this device will be formatted the same
162 C> the disk file on iunitb.
163 C>
164 C> - Dennis Keyser 1995-06-07 Corrected an error which required input
165 C> argument "maxd" to be nearly twice as large as
166 C> needed for decoding wind profiler reports (limit
167 C> upper bound for "iwork" array was set to "maxd",
168 C> now it is set to 15000). also, a correction was
169 C> made in the wind profiler processing to prevent
170 C> unnecessary looping when all requested
171 C> descriptors are missing. also corrected an
172 C> error which resulted in returned scale in
173 C> "mstack(2, ..)" always being set to zero for
174 C> compressed data.
175 C> - Bill Cavanaugh 1996-02-15 Modified identification of ascii/ebcdic
176 C> machine. modified handling of table b to permit
177 C> faster processing of multiple messages with
178 C> changing data types and/or subtypes.
179 C> - Bill Cavanaugh 1996-04-02 Deactivated extraneous write statement.
180 C> enlarged arrays for table b entries to contain
181 C> up to 1300 entries in preparation for new
182 C> additions to table b.
183 C> - Dennis Keyser 2001-02-01 The table b file will now be read whenever the
184 C> input argument "iunitb" (table b unit number)
185 C> changes from its value in the previous call to
186 C> this routine (normally it is only read the
187 C> first time this routine is called)
188 C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i
189 C>
190 C> @param[in] MSGA Array containing supposed bufr message
191 C> size is determined by user, can be greater
192 C> than 15000 bytes.
193 C> @param[in] MAXR Maximum number of reports/subsets that may be
194 C> contained in a bufr message
195 C> @param[in] MAXD Maximum number of descriptor combinations that
196 C> may be processed; upper air data and some satellite
197 C> data require a value for maxd of 1700, but for most
198 C> other data a value for maxd of 500 will suffice
199 C> @param[in] IUNITB Unit number of data set holding table b, this is the
200 C> number of a pair of data sets
201 C> -IUNITB+Unit number for a dataset to contain table b entries
202 C> from master table b and table b entries extracted
203 C> from type 11 bufr messages that were used to decode
204 C> current bufr messages.
205 C> @param[in] IUNITD Unit number of data set holding tab
206 C> @param[out] ISTACK Original array of descriptors extracted from
207 C> source bufr message.
208 C> @param[out] MSTACK (A,B)-LEVEL B Descriptor number (limited to value of
209 C> input argument maxd)
210 C> - Level A:
211 C> - = 1 Descriptor
212 C> - = 2 10**N scaling to return to original value
213 C> @param[out] IPTR Utility array (should have at last 42 entries)
214 C> - IPTR(1)- Error return
215 C> - IPTR(2)- Byte count section 1
216 C> - IPTR(3)- Pointer to start of section 1
217 C> - IPTR(4)- Byte count section 2
218 C> - IPTR(5)- Pointer to start of section 2
219 C> - IPTR(6)- Byte count section 3
220 C> - IPTR(7)- Pointer to start of section 3
221 C> - IPTR(8)- Byte count section 4
222 C> - IPTR(9)- Pointer to start of section 4
223 C> - IPTR(10)- Start of requested subset, reserved for dar
224 C> - IPTR(11)- Current descriptor ptr in iwork
225 C> - IPTR(12)- Last descriptor pos in iwork
226 C> - IPTR(13)- Last descriptor pos in istack
227 C> - IPTR(14)- Number of master table b entries
228 C> - IPTR(15)- Requested subset pointer, reserved for dar
229 C> - IPTR(16)- Indicator for existance of section 2
230 C> - IPTR(17)- Number of reports processed
231 C> - IPTR(18)- Ascii/text event
232 C> - IPTR(19)- Pointer to start of bufr message
233 C> - IPTR(20)- Number of entries from table d
234 C> - IPTR(21)- Nr table b entries
235 C> - IPTR(22)- Nr table b entries from current message
236 C> - IPTR(23)- Code/flag table switch
237 C> - IPTR(24)- Aditional words added by text info
238 C> - IPTR(25)- Current bit number
239 C> - IPTR(26)- Data width change - add to table b width
240 C> - IPTR(27)- Data scale change - modifies table b scale
241 C> - IPTR(28)- Data reference value change - ?????????
242 C> - IPTR(29)- Add data associated field
243 C> - IPTR(30)- Signify characters
244 C> - IPTR(31)- Number of expanded descriptors in mstack
245 C> - IPTR(32)- Current descriptor segment f
246 C> - IPTR(33)- Current descriptor segment x
247 C> - IPTR(34)- Current descriptor segment y
248 C> - IPTR(35)- Data/descriptor replication in progress
249 C> - 0 = No
250 C> - 1 = Yes
251 C> - IPTR(36)- Next descriptor may be undecipherable
252 C> - IPTR(37)- Machine text type flag
253 C> - 0 = EBCIDIC
254 C> - 1 = ASCII
255 C> - IPTR(38)- Data/descriptor replication flag
256 C> - 0 - Does not exist in current message
257 C> - 1 - Exists in current message
258 C> - IPTR(39)- Delayed replication flag
259 C> - 0 - No delayed replication
260 C> - 1 - Message contains delayed replication
261 C> - IPTR(40)- Number of characters in text for curr descriptor
262 C> - IPTR(41)- Number of ancillary table b entries
263 C> - IPTR(42)- Number of ancillary table d entries
264 C> - IPTR(43)- Number of added table b entries encountered while
265 C> processing a bufr message. these entries only
266 C> exist durng processing of current bufr message
267 C> IPTR(44)- Bits per word
268 C> IPTR(45)- Bytes per word
269 C> @param[out] IDENT Array contains message information extracted from BUFR message:
270 C> - IDENT(1) - Edition number (byte 4, section 1)
271 C> - IDENT(2) - Originating center (bytes 5-6, section 1)
272 C> - IDENT(3) - Update sequence (byte 7, section 1)
273 C> - IDENT(4) - Optional section (byte 8, section 1)
274 C> - IDENT(5) - Bufr message type (byte 9, section 1)
275 C> - 0 = Surface data (land)
276 C> - 1 = Surface data (ship)
277 C> - 2 = Vertical soundings (other than satellite)
278 C> - 3 = Vertical soundings (satellite)
279 C> - 4 = Single lvl upper-air data(other than satellite)
280 C> - 5 = Single level upper-air data (satellite)
281 C> - 6 = Radar data
282 C> - 7 = Synoptic features
283 C> - 8 = Physical/chemical constituents
284 C> - 9 = Dispersal and transport
285 C> - 10 = Radiological data
286 C> - 11 = Bufr tables (complete, replacement or update)
287 C> - 12 = Surface data (satellite)
288 C> - 21 = Radiances (satellite measured)
289 C> - 31 = Oceanographic data
290 C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
291 C> | TYPE | SBTYP |
292 C> | :--- | :---- |
293 C> | 2 | 7 = PROFILER |
294 C> - IDENT(7) - (bytes 11-12, section 1)
295 C> - IDENT(8) - Year of century (byte 13, section 1)
296 C> - IDENT(9) - Month of year (byte 14, section 1)
297 C> - IDENT(10) - Day of month (byte 15, section 1)
298 C> - IDENT(11) - Hour of day (byte 16, section 1)
299 C> - IDENT(12) - Minute of hour (byte 17, section 1)
300 C> - IDENT(13) - Rsvd by adp centers(byte 18, section 1)
301 C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
302 C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
303 C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
304 C> - IDENT(17) - Master table number(byte 4, section 1, ed 2 or gtr)
305 C> @param[out] KDATA Array containing decoded reports from bufr message.
306 C> KDATA(Report number,parameter number)
307 C> (Report number limited to value of input argument
308 C> maxr and parameter number limited to value of input
309 C> argument maxd)
310 C> @param[out] INDEX Pointer to available subset
311 C> @param KNR
312 C> @param LDATA
313 C> @param LSTACK
314 C>
315 C> ===========================================================
316 C> Arrays containing data from table b
317 C> new - base arrays containing data from table b
318 C> - KFXY1 - Decimal descriptor value of f x y values
319 C> - ANAME1 - Descriptor name
320 C> - AUNIT1 - Units for descriptor
321 C> - ISCAL1 - Scale for value of descriptor
322 C> - IRFVL1 - Reference value for descriptor
323 C> - IWIDE1 - Bit width for value of descriptor
324 C> ===========================================================
325 C> New - ancillary arrays containing data from table b
326 C> containing table b entries extracted
327 C> from type 11 bufr messages
328 C> - KFXY2 - Decimal descriptor value of f x y values
329 C> - ANAME2 - Descriptor name
330 C> - AUNIT2 - Units for descriptor
331 C> - ISCAL2 - Scale for value of descriptor
332 C> - IRFVL2 - Reference value for descriptor
333 C> - IWIDE2 - Bit width for value of descriptor
334 C> ===========================================================
335 C> New - added arrays containing data from table b
336 C> containing table b entries extracted
337 C> from non-type 11 bufr messages
338 C> these exist for the life of current bufr message
339 C> - KFXY3 - Decimal descriptor value of f x y values
340 C> - ANAME3 - Descriptor name
341 C> - AUNIT3 - Units for descriptor
342 C> - ISCAL3 - Scale for value of descriptor
343 C> - IRFVL3 - Reference value for descriptor
344 C> - IWIDE3 - Bit width for value of descriptor
345 C> ===========================================================
346 C>
347 C> Error returns:
348 C> IPTR(1)
349 C> - = 1 'BUFR' Not found in first 125 characters
350 C> - = 2 '7777' Not found in location determined by
351 C> by using counts found in each section. one or
352 C> more sections have an erroneous byte count or
353 C> characters '7777' are not in test message.
354 C> - = 3 Message contains a descriptor with f=0 that does
355 C> not exist in table b.
356 C> - = 4 Message contains a descriptor with f=3 that does
357 C> not exist in table d.
358 C> - = 5 Message contains a descriptor with f=2 with the
359 C> value of x outside the range 1-6.
360 C> - = 6 Descriptor element indicated to have a flag value
361 C> does not have an entry in the flag table.
362 C> (to be activated)
363 C> - = 7 Descriptor indicated to have a code value does
364 C> not have an entry in the code table.
365 C> (to be activated)
366 C> - = 8 Error reading table d
367 C> - = 9 Error reading table b
368 C> - = 10 Error reading code/flag table
369 C> - = 11 Descriptor 2 04 004 not followed by 0 31 021
370 C> - = 12 Data descriptor operator qualifier does not follow
371 C> delayed replication descriptor.
372 C> - = 13 Bit width on ascii characters not a multiple of 8
373 C> - = 14 Subsets = 0, no content bulletin
374 C> - = 20 Exceeded count for delayed replication pass
375 C> - = 21 Exceeded count for non-delayed replication pass
376 C> - = 22 Exceeded combined bit width, bit width > 32
377 C> - = 23 No element descriptors following 2 03 yyy
378 C> - = 27 Non zero lowest on text data
379 C> - = 28 Nbinc not nr of characters
380 C> - = 29 Table b appears to be damaged
381 C> - = 30 Table d entry with more than 18 in sequence
382 C> being entered from type 11 message
383 C> - = 99 No more subsets (reports) available in current
384 C> bufr mesage
385 C> - = 400 Number of subsets exceeds the value of input
386 C> argument maxr; must increase maxr to value of
387 C> ident(14) in calling program
388 C> - = 401 Number of parameters (and associated fields)
389 C> exceeds limits of this program.
390 C> - = 500 Value for nbinc has been found that exceeds
391 C> standard width plus any bit width change.
392 C> check all bit widths up to point of error.
393 C> - = 501 Corrected width for descriptor is 0 or less
394 C> - = 888 Non-numeric character in conversion request
395 C> - = 890 Class 0 element descriptor w/width of 0
396 C>
397 C> On the initial call to w3fi88 with a bufr message the argument
398 C> index must be set to zero (index = 0). on the return from w3fi88
399 C> 'index' will be set to the next available subset/report. when
400 C> there are no more subsets available a 99 err return will occur.
401 C>
402 C> If the original bufr message does not contain delayed replication
403 C> the bufr message will be completely decoded and 'index' will point
404 C> to the first decoded subset. the users will then have the option
405 C> of indexing through the subsets on their own or by recalling this
406 C> routine (without resetting 'index') to have the routine do the
407 C> indexing.
408 C>
409 C> If the original bufr message does contain delayed replication
410 C> one subset/report will be decoded at a time and passed back to
411 C> the user. this is not an option.
412 C>
413 C> =============================================
414 C> To use this routine
415 C> =============================================
416 C> the arrays to contain the output information are defined
417 C> as follows:
418 C>
419 C> KDATA(A,B) is the a data entry (integer value)
420 C> where a is the maximum number of reports/subsets
421 C> that may be contained in the bufr message (this
422 C> is now set to "maxr" which is passed as an input
423 C> argument to w3fi88), and where b is the maximum
424 C> number of descriptor combinations that may
425 C> be processed (this is now set to "maxd" which
426 C> is also passed as an input argument to w3fi88;
427 C> upper air data and some satellite data require
428 C> a value for maxd of 1700, but for most other
429 C> data a value for maxd of 500 will suffice)
430 C> MSTACK(1,B) contains the descriptor that matches the
431 C> data entry (max. value for b is now "maxd"
432 C> which is passed as an input argument to w3fi88)
433 C> MSTACK(2,B) is the scale (power of 10) to be applied to
434 C> the data (max. value for b is now "maxd"
435 C> which is passed as an input argument to w3fi88)
436 C>
437  SUBROUTINE w3fi88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
438  * LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD)
439 C
440 C
441 C
442 C THE MEMORY REQUIREMENTS FOR LSTACK AND LDATA ARE USED WITH
443 C RUN-LINE CODING PROVIDING FOR THE HANDLING OF DATA FOR
444 C GRAPHICS. I.E., RADAR DISPLAYS. IF THE DECODING PROCESS WILL
445 C NOT BE USED TO PROCESS THOSE TYPE OF MESSAGES, THEN THE
446 C VARIABLE SIZES FOR THE ARRAYS CAN BE MINIMIZED.
447 C IF THE DECODING PROCESS WILL BE USED TO DECODE THOSE MESSAGE
448 C TYPES, THEN MAXD MUST REFLECT THE MAXIMUM NUMBER OF
449 C DESCRIPTORS (FULLY EXPANDED LIST) TO BE EXPECTED IN THE
450 C MESSAGE.
451 C
452  INTEGER LDATA(MAXD)
453  INTEGER LSTACK(2,MAXD)
454 C
455  INTEGER MSGA(*)
456  INTEGER IPTR(*),KPTRB(16384),KPTRD(16384)
457  INTEGER KDATA(MAXR,MAXD)
458  INTEGER MSTACK(2,MAXD)
459 C
460  INTEGER IVALS(1000)
461  INTEGER KNR(MAXR)
462  INTEGER IDENT(*)
463  INTEGER ISTACK(*),IOLD11
464 cdak KEYSER fix 02/02/2001 VVVVV
465  INTEGER IOLDTB
466 cdak KEYSER fix 02/02/2001 AAAAA
467  INTEGER IWORK(15000)
468  INTEGER INDEX
469 C
470  INTEGER IIII
471  CHARACTER*1 BLANK
472  CHARACTER*4 DIRID(2)
473 C
474  LOGICAL SEC2
475 C ..................................................
476 C
477 C NEW BASE TABLE B
478 C MAY BE A COMBINATION OF MASTER TABLE B
479 C AND ANCILLARY TABLE B
480 C
481  INTEGER KFXY1(1300),ISCAL1(1300)
482  INTEGER IRFVL1(3,1300),IWIDE1(1300)
483  CHARACTER*40 ANAME1(1300)
484  CHARACTER*24 AUNIT1(1300)
485 C ..................................................
486 C
487 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
488 C
489  INTEGER KFXY2(200),ISCAL2(200),IRFVL2(200),IWIDE2(200)
490  CHARACTER*64 ANAME2(200)
491  CHARACTER*24 AUNIT2(200)
492 C ..................................................
493 C
494 C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE
495 C
496 C INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200)
497 C CHARACTER*64 ANAME3(200)
498 C CHARACTER*24 AUNIT3(200)
499 C ..................................................
500 C
501 C NEW BASE TABLE D
502 C
503  INTEGER ITBLD(20,400)
504 C ..................................................
505 C
506 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
507 C
508  INTEGER ITBLD2(20,50)
509 C ..................................................
510 C
511  SAVE
512 
513 cdak KEYSER fix 02/02/2001 VVVVV
514  DATA iold11/0/
515  DATA ioldtb/-99/
516 cdak KEYSER fix 02/02/2001 AAAAA
517 C
518  CALL w3fi01(lw)
519  iptr(45) = lw
520  iptr(44) = lw * 8
521 C
522  blank = ' '
523  IF (mova2i(blank).EQ.32) THEN
524  iptr(37) = 1
525 C PRINT *,'ASCII MACHINE'
526  ELSE
527  iptr(37) = 0
528 C PRINT *,'EBCDIC MACHINE'
529  END IF
530 C
531 C PRINT *,' W3FI88 DECODER'
532 C INITIALIZE ERROR RETURN
533  iptr(1) = 0
534  IF (index.GT.0) THEN
535 C HAVE RE-ENTRY
536  index = index + 1
537 C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
538  IF (index.GT.ident(14)) THEN
539 C ALL SUBSETS PROCESSED
540  iptr(1) = 99
541  iptr(38) = 0
542  iptr(39) = 0
543  ELSE IF (index.LE.ident(14)) THEN
544  IF (iptr(39).NE.0) THEN
545  DO 3000 j =1, iptr(13)
546  iwork(j) = istack(j)
547  3000 CONTINUE
548  iptr(12) = iptr(13)
549  CALL fi8801(iptr,ident,msga,istack,iwork,kdata,ivals,
550  * mstack,knr,index,maxr,maxd,
551  * kfxy1,aname1,aunit1,iscal1,irfvl1,iwide1,irf1sw,inewvl,
552  * kfxy2,aname2,aunit2,iscal2,irfvl2,iwide2,
553  * kfxy3,aname3,aunit3,iscal3,irfvl3,iwide3,
554  * iunitb,iunitd,itbld,itbld2,kptrb,kptrd)
555 C
556  END IF
557  END IF
558  RETURN
559  ELSE
560  index = 1
561 C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
562  END IF
563  iptr(39) = 0
564 C FIND 'BUFR' IN FIRST 125 CHARACTERS
565  DO 1000 knofst = 0, 999, 8
566  inofst = knofst
567  CALL gbyte (msga,ivals,inofst,8)
568  IF (ivals(1).EQ.66) THEN
569  iptr(19) = inofst
570  inofst = inofst + 8
571  CALL gbyte (msga,ivals,inofst,24)
572  IF (ivals(1).EQ.5588562) THEN
573 C PRINT *,'FOUND BUFR AT',IPTR(19)
574  inofst = inofst + 24
575  GO TO 1500
576  END IF
577  END IF
578  1000 CONTINUE
579  print *,'BUFR - START OF BUFR MESSAGE NOT FOUND'
580  iptr(1) = 1
581  RETURN
582  1500 CONTINUE
583  ident(1) = 0
584 C TEST FOR EDITION NUMBER
585 C ======================
586  CALL gbyte (msga,ident(1),inofst+24,8)
587 C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE'
588 C
589  IF (ident(1).GE.2) THEN
590 C GET TOTAL COUNT
591  CALL gbyte (msga,ivals,inofst,24)
592  itotal = ivals(1)
593  kender = itotal * 8 - 32 + iptr(19)
594  CALL gbyte (msga,ilast,kender,32)
595 C IF (ILAST.EQ.926365495) THEN
596 C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
597 C END IF
598  inofst = inofst + 32
599 C GET SECTION 1 COUNT
600  iptr(3) = inofst
601  CALL gbyte (msga,ivals,inofst,24)
602 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
603  inofst = inofst + 24
604  iptr( 2) = ivals(1)
605 C GET MASTER TABLE
606  CALL gbyte (msga,ivals,inofst,8)
607  inofst = inofst + 8
608  ident(17) = ivals(1)
609 C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
610  ELSE
611  iptr(3) = inofst
612 C GET SECTION 1 COUNT
613  CALL gbyte (msga,ivals,inofst,24)
614 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
615  inofst = inofst + 32
616  iptr( 2) = ivals(1)
617  END IF
618 C ======================
619 C ORIGINATING CENTER
620  CALL gbyte (msga,ivals,inofst,16)
621  inofst = inofst + 16
622  ident(2) = ivals(1)
623 C UPDATE SEQUENCE
624  CALL gbyte (msga,ivals,inofst,8)
625  inofst = inofst + 8
626  ident(3) = ivals(1)
627 C OPTIONAL SECTION FLAG
628  CALL gbyte (msga,ivals,inofst,1)
629  ident(4) = ivals(1)
630  IF (ident(4).GT.0) THEN
631  sec2 = .true.
632  ELSE
633 C PRINT *,' NO OPTIONAL SECTION 2'
634  sec2 = .false.
635  END IF
636  inofst = inofst + 8
637 C MESSAGE TYPE
638  CALL gbyte (msga,ivals,inofst,8)
639  ident(5) = ivals(1)
640  inofst = inofst + 8
641 C MESSAGE SUBTYPE
642  CALL gbyte (msga,ivals,inofst,8)
643  ident(6) = ivals(1)
644  inofst = inofst + 8
645 cdak KEYSER fix 02/02/2001 VVVVV
646  IF (iunitb.NE.ioldtb) THEN
647 C IF HAVE A CHANGE IN TABLE B UNIT NUMBER , READ TABLE B
648  IF(ioldtb.NE.-99) print *, 'W3FI88 - NEW TABLE B UNIT NUMBER'
649  ioldtb = iunitb
650  iptr(14) = 0
651  iptr(21) = 0
652  END IF
653 cdak KEYSER fix 02/02/2001 AAAAA
654 C IF HAVE CHANGE IN DATA TYPE , RESET TABLE B
655  IF (iold11.EQ.11) THEN
656  iold11 = ident(5)
657  ioldsb = ident(6)
658 C JUST CONTINUE PROCESSING
659  ELSE IF (iold11.NE.11) THEN
660  IF (ident(5).EQ.11) THEN
661  iold11 = ident(5)
662  iptr(21) = 0
663  ELSE IF (ident(5).NE.iold11) THEN
664  iold11 = ident(5)
665  iptr(21) = 0
666  ELSE IF (ident(5).EQ.iold11) THEN
667 C IF HAVE A CHANGE IN SUBTYPE, RESET TABLE B
668  IF (ioldsb.NE.ident(6)) THEN
669  ioldsb = ident(6)
670  iptr(21) = 0
671 C ELSE IF
672  END IF
673  END IF
674  END IF
675 C IF BUFR EDITION 0 OR 1 THEN
676 C NEXT 2 BYTES ARE BUFR TABLE VERSION
677 C ELSE
678 C BYTE 11 IS VER NR OF MASTER TABLE
679 C BYTE 12 IS VER NR OF LOCAL TABLE
680  IF (ident(1).LT.2) THEN
681  CALL gbyte (msga,ivals,inofst,16)
682  ident(7) = ivals(1)
683  inofst = inofst + 16
684  ELSE
685 C BYTE 11 IS VER NR OF MASTER TABLE
686  CALL gbyte (msga,ivals,inofst,8)
687  ident(18) = ivals(1)
688  inofst = inofst + 8
689 C BYTE 12 IS VER NR OF LOCAL TABLE
690  CALL gbyte (msga,ivals,inofst,8)
691  ident(19) = ivals(1)
692  inofst = inofst + 8
693 
694  END IF
695 C YEAR OF CENTURY
696  CALL gbyte (msga,ivals,inofst,8)
697  ident(8) = ivals(1)
698  inofst = inofst + 8
699 C MONTH
700  CALL gbyte (msga,ivals,inofst,8)
701  ident(9) = ivals(1)
702  inofst = inofst + 8
703 C DAY
704 C PRINT *,'DAY AT ',INOFST
705  CALL gbyte (msga,ivals,inofst,8)
706  ident(10) = ivals(1)
707  inofst = inofst + 8
708 C HOUR
709  CALL gbyte (msga,ivals,inofst,8)
710  ident(11) = ivals(1)
711  inofst = inofst + 8
712 C MINUTE
713  CALL gbyte (msga,ivals,inofst,8)
714  ident(12) = ivals(1)
715 C RESET POINTER (INOFST) TO START OF
716 C NEXT SECTION
717 C (SECTION 2 OR SECTION 3)
718  inofst = iptr(3) + iptr(2) * 8
719  iptr(4) = 0
720  iptr(5) = inofst
721  IF (sec2) THEN
722 C SECTION 2 COUNT
723  CALL gbyte (msga,iptr(4),inofst,24)
724  inofst = inofst + 32
725 C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
726  kentry = (iptr(4) - 4) / 14
727 C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS'
728  IF (ident(2).EQ.7) THEN
729  DO 2000 i = 1, kentry
730  CALL gbyte (msga,kdspl ,inofst,16)
731  inofst = inofst + 16
732  CALL gbyte (msga,lat ,inofst,16)
733  inofst = inofst + 16
734  CALL gbyte (msga,lon ,inofst,16)
735  inofst = inofst + 16
736  CALL gbyte (msga,kdahr ,inofst,16)
737  inofst = inofst + 16
738  CALL gbyte (msga,dirid(1),inofst,32)
739  inofst = inofst + 32
740  CALL gbyte (msga,dirid(2),inofst,16)
741  inofst = inofst + 16
742 C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
743  2000 CONTINUE
744  END IF
745 C RESET POINTER (INOFST) TO START OF
746 C SECTION 3
747  inofst = iptr(5) + iptr(4) * 8
748  END IF
749 C BIT OFFSET TO START OF SECTION 3
750  iptr( 7) = inofst
751 C SECTION 3 COUNT
752  CALL gbyte (msga,iptr(6),inofst,24)
753 C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6)
754  inofst = inofst + 24
755 C SKIP RESERVED BYTE
756  inofst = inofst + 8
757 C NUMBER OF DATA SUBSETS
758  CALL gbyte (msga,ident(14),inofst,16)
759 C
760  IF (ident(14).GT.maxr) THEN
761  print *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',maxr
762  print *,'PASSED INTO W3FI88; MAXR MUST BE INCREASED IN '
763  print *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF'
764  print *,ident(14),'TO BE ABLE TO PROCESS THIS DATA'
765 C
766  iptr(1) = 400
767  RETURN
768  END IF
769  inofst = inofst + 16
770 C OBSERVED DATA FLAG
771  CALL gbyte (msga,ivals,inofst,1)
772  ident(15) = ivals(1)
773  inofst = inofst + 1
774 C COMPRESSED DATA FLAG
775  CALL gbyte (msga,ivals,inofst,1)
776  ident(16) = ivals(1)
777  inofst = inofst + 7
778 C CALCULATE NUMBER OF DESCRIPTORS
779  nrdesc = (iptr( 6) - 8) / 2
780  iptr(12) = nrdesc
781  iptr(13) = nrdesc
782 C EXTRACT DESCRIPTORS
783  CALL gbytes (msga,istack,inofst,16,0,nrdesc)
784 C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
785  DO 10 l = 1, nrdesc
786  iwork(l) = istack(l)
787 C PRINT *,L,ISTACK(L)
788  10 CONTINUE
789  iptr(13) = nrdesc
790 C ===============================================================
791 C
792 C CONSTRUCT A TABLE B TO MATCH THE
793 C LIST OF DESCRIPTORS FOR THIS MESSAGE
794 C
795  IF (iptr(21).EQ.0) THEN
796  print *,'W3FI88- TABLE B NOT YET ENTERED'
797  CALL fi8812(iptr,iunitb,iunitd,istack,nrdesc,kptrb,kptrd,
798  * irf1sw,newref,itbld,itbld2,
799  * kfxy1,aname1,aunit1,iscal1,irfvl1,iwide1,
800  * kfxy2,aname2,aunit2,iscal2,irfvl2,iwide2)
801  ELSE
802 C PRINT *,'W3FI88- TABLE B ALL READY IN PLACE'
803  IF (iptr(41).NE.0) THEN
804 C PRINT *,'MERGE',IPTR(41),' ENTRIES INTO TABLE B'
805 C CALL FI8818(IPTR,KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
806 C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB)
807  END IF
808  END IF
809  IF (iptr(1).NE.0) RETURN
810 C ================================================================
811 C RESET POINTER TO START OF SECTION 4
812  inofst = iptr(7) + iptr(6) * 8
813 C BIT OFFSET TO START OF SECTION 4
814  iptr( 9) = inofst
815 C SECTION 4 COUNT
816  CALL gbyte (msga,ivals,inofst,24)
817 C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
818  iptr( 8) = ivals(1)
819  inofst = inofst + 32
820 C SET FOR STARTING BIT OF DATA
821  iptr(25) = inofst
822 C FIND OUT IF '7777' TERMINATOR IS THERE
823  inofst = iptr(9) + iptr(8) * 8
824  CALL gbyte (msga,ivals,inofst,32)
825 C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1)
826  IF (ivals(1).NE.926365495) THEN
827  print *,'BAD SECTION COUNT'
828  iptr(1) = 2
829  RETURN
830  ELSE
831  iptr(1) = 0
832  END IF
833 C
834  CALL fi8801(iptr,ident,msga,istack,iwork,kdata,ivals,
835  * mstack,knr,index,maxr,maxd,
836  * kfxy1,aname1,aunit1,iscal1,irfvl1,iwide1,irf1sw,inewvl,
837  * kfxy2,aname2,aunit2,iscal2,irfvl2,iwide2,
838  * kfxy3,aname3,aunit3,iscal3,irfvl3,iwide3,
839  * iunitb,iunitd,itbld,itbld2,kptrb,kptrd)
840 C
841 C PRINT *,'HAVE RETURNED FROM FI8801'
842  IF (iptr(1).NE.0) THEN
843  RETURN
844  END IF
845 C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
846  IF (ident(5).EQ.2) THEN
847  IF (ident(6).EQ.7) THEN
848 C PRINT *,'REFORMAT PROFILER DATA'
849 C
850 C DO 7151 I = 1, 40
851 C IF (I.LE.20) THEN
852 C PRINT *,'IPTR(',I,')=',IPTR(I),
853 C * ' IDENT(',I,')= ',IDENT(I)
854 C ELSE
855 C PRINT *,'IPTR(',I,')=',IPTR(I)
856 C END IF
857 C7151 CONTINUE
858 C DO 152 I = 1, IPTR(31)
859 C PRINT *,MSTACK(1,I),MSTACK(2,I),(KDATA(J,I),J=1,5)
860 C 152 CONTINUE
861  IF (ident(1).LT.2) THEN
862  CALL fi8809(ident,mstack,kdata,iptr,maxr,maxd)
863  ELSE
864  CALL fi8810(ident,mstack,kdata,iptr,maxr,maxd)
865  END IF
866 C DO 151 I = 1, 40
867 C IF (I.LE.20) THEN
868 C PRINT *,'IPTR(',I,')=',IPTR(I),
869 C * ' IDENT(',I,')= ',IDENT(I)
870 C ELSE
871 C PRINT *,'IPTR(',I,')=',IPTR(I)
872 C END IF
873 C 151 CONTINUE
874  IF (iptr(1).NE.0) THEN
875  RETURN
876  END IF
877 C
878 C DO 154 I = 1, IPTR(31)
879 C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
880 C 154 CONTINUE
881  END IF
882  END IF
883 C IF DATA/DESCRIPTOR REPLICATION FLAG IS ON,
884 C MUST COMPLETE EXPANSION OF DATA AND
885 C DESCRIPTORS.
886  IF (iptr(38).EQ.1) THEN
887  CALL fi8811(iptr,ident,mstack,kdata,knr,
888  * ldata,lstack,maxd,maxr)
889  END IF
890 C
891 C IF HAVE A LIST OF TABLE ENTRIES FROM
892 C A BUFR MESSAGE TYPE 11
893 C PRINT OUT THE ENTRIES
894 C
895  IF (ident(5).EQ.11) THEN
896 C DO 100 I = 1, IPTR(31)+IPTR(24)
897 C PRINT *,I,MSTACK(1,I),(KDATA(J,I),J=1,4)
898 C 100 CONTINUE
899  CALL fi8813 (iptr,maxr,maxd,mstack,kdata,ident,kptrd,kptrb,
900  * itbld,aname1,aunit1,kfxy1,iscal1,irfvl1,iwide1,iunitb)
901  END IF
902  RETURN
903  END
904 C> @brief Data extraction
905 C> @author Bill Cavanaugh @date 1988-09-01
906 
907 C> Control the extraction of data from section 4 based on data descriptors.
908 C>
909 C> Program history log:
910 C> - Bill Cavanaugh 1988-09-01\
911 C> - Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed
912 C> DATA.
913 C> - Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with
914 C> DELAYED REPLICATION.
915 C> - Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
916 C> - Dennis Keyser 1995-06-07 Corrected an error which required input
917 C> argument "maxd" to be nearly twice as large
918 C> as needed for decoding wind profiler reports
919 C> (limit upper bound for "iwork" array was set
920 C> to "maxd", now it is set to 15000)
921 C>
922 C> @param[in] IPTR See w3fi88() routine docblock
923 C> @param[in] IDENT See w3fi88() routine docblock
924 C> @param[in] MSGA Array containing bufr message
925 C> @param[inout] ISTACK Original array of descriptors extracted from
926 C> source bufr message.
927 C> @param[in] MSTACK Working array of descriptors (expanded)and scaling
928 C> factor
929 C> @param[inout] KFXY1+KFXY2+KFXY3 Image of current descriptor
930 C> @param[in] INDEX
931 C> @param[in] MAXR Maximum number of reports/subsets that may be
932 C> contained in a bufr message
933 C> @param[in] MAXD Maximum number of descriptor combinations that
934 C> may be processed; upper air data and some satellite
935 C> data require a value for maxd of 1700, but for most
936 C> other data a value for maxd of 500 will suffice
937 C> @param[in] IUNITB Unit number of data set holding table b
938 C> @param[in] IUNITD Unit number of data set holding table d
939 C> @param[out] IWORK Working descriptor list
940 C> @param[out] KDATA Array containing decoded reports from bufr message.
941 C> KDATA(Report number,parameter number)
942 C> (report number limited to value of input argument
943 C> maxr and parameter number limited to value of input
944 C> argument maxd)
945 C>
946 C> arrays containing data from table b
947 C> @param[out] AUNIT1+AUNIT2+AUNIT3 Units for descriptor
948 C> @param[out] ANAME1+ANAME2+ANAME3 Descriptor name
949 C> @param[out] ISCAL1+ISCAL2+ISCAL3 Scale for value of descriptor
950 C> @param[out] IRFVL1+IRFVL2+IRFVL3 Reference value for descriptor
951 C> @param[out] IWIDE1+IWIDE2+IWIDE3 Bit width for value of descriptor
952 C> @param ITBLD+ITBLD2
953 C> @param KPTRB
954 C> @param KPTRD
955 C> @param KNR
956 C> @param IVALS
957 C> @param IRF1SW
958 C> @param INEWVL
959 C>
960 C> Error return:
961 C> - IPTR(1)
962 C> - = 8 Error reading table b
963 C> - = 9 Error reading table d
964 C> - = 11 Error opening table b
965 C>
966 C> @author Bill Cavanaugh @date 1988-09-01
967  SUBROUTINE fi8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS,
968  * MSTACK,KNR,INDEX,MAXR,MAXD,
969  * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,
970  * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
971  * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3,
972  * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD)
973 C
974 
975 C ..................................................
976 C
977 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
978 C
979  INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
980  CHARACTER*64 ANAME2(*)
981  CHARACTER*24 AUNIT2(*)
982 C ..................................................
983 C
984 C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE
985 C
986  INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200)
987  CHARACTER*64 ANAME3(200)
988  CHARACTER*24 AUNIT3(200)
989 C ..................................................
990 C
991 C NEW BASE TABLE B
992 C MAY BE A COMBINATION OF MASTER TABLE B
993 C AND ANCILLARY TABLE B
994 C
995  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
996  CHARACTER*40 ANAME1(*)
997  CHARACTER*24 AUNIT1(*)
998 C ..................................................
999 C
1000 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
1001 C
1002  INTEGER ITBLD2(20,*)
1003 C ..................................................
1004 C
1005 C NEW BASE TABLE D
1006 C
1007  INTEGER ITBLD(20,*)
1008 C ..................................................
1009 C
1010 C
1011  INTEGER MAXD, MAXR
1012 C
1013  INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*)
1014 C
1015  INTEGER KNR(MAXR)
1016  INTEGER LX,LY,LL,J
1017 C INTEGER IHOLD(33)
1018  INTEGER IPTR(*),KPTRB(*),KPTRD(*)
1019  INTEGER IDENT(*)
1020  INTEGER ISTACK(*),IWORK(*)
1021 C
1022  INTEGER MSTACK(2,MAXD)
1023 C
1024  INTEGER JDESC
1025  INTEGER INDEX
1026 C
1027  SAVE
1028 C
1029 C PRINT *,' DECOLL FI8801'
1030  IF (index.GT.1) THEN
1031  GO TO 1000
1032  END IF
1033 C --------- DECOLL ---------------
1034  iptr(23) = 0
1035  iptr(26) = 0
1036  iptr(27) = 0
1037  iptr(28) = 0
1038  iptr(29) = 0
1039  iptr(30) = 0
1040  iptr(36) = 0
1041 C INITIALIZE OUTPUT AREA
1042 C SET POINTER TO BEGINNING OF DATA
1043 C SET BIT
1044  iptr(17) = 1
1045  1000 CONTINUE
1046 C IPTR(12) = IPTR(13)
1047  ll = 0
1048  iptr(11) = 1
1049  IF (iptr(10).EQ.0) THEN
1050 C RE-ENTRY POINT FOR MULTIPLE
1051 C NON-COMPRESSED REPORTS
1052  ELSE
1053  index = iptr(15)
1054  iptr(17) = index
1055  iptr(25) = iptr(10)
1056  iptr(10) = 0
1057  iptr(15) = 0
1058  END IF
1059 C PRINT *,'FI8801 - RPT',IPTR(17),' STARTS AT',IPTR(25)
1060  iptr(24) = 0
1061  iptr(31) = 0
1062 C POINTING AT NEXT AVAILABLE DESCRIPTOR
1063  mm = 0
1064  IF (iptr(21).EQ.0) THEN
1065  nrdesc = iptr(13)
1066  CALL fi8812(iptr,iunitb,iunitd,istack,nrdesc,kptrb,kptrd,
1067  * irf1sw,newref,itbld,itbld2,
1068  * kfxy1,aname1,aunit1,iscal1,irfvl1,iwide1,
1069  * kfxy2,aname2,aunit2,iscal2,irfvl2,iwide2)
1070  END IF
1071  10 CONTINUE
1072 C PROCESS THRU THE FOLLOWING
1073 C DEPENDING UPON THE VALUE OF 'F' (LF)
1074  mm = mm + 1
1075  12 CONTINUE
1076  IF (mm.GT.maxd) THEN
1077  GO TO 200
1078  END IF
1079 C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
1080  IF (iptr(11).GT.iptr(12)) THEN
1081 C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
1082  IF (ident(16).NE.0) THEN
1083 C PRINT *,' PROCESSING COMPRESSED REPORTS'
1084 C REFORMAT DATA FROM DESCRIPTOR
1085 C FORM TO USER FORM
1086  RETURN
1087  ELSE
1088 C WRITE (6,1)
1089 C 1 FORMAT (1H1)
1090 C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25)
1091  iptr(17) = iptr(17) + 1
1092  IF (iptr(17).GT.ident(14)) THEN
1093  iptr(17) = iptr(17) - 1
1094  GO TO 200
1095  END IF
1096  DO 300 i = 1, iptr(13)
1097  iwork(i) = istack(i)
1098  300 CONTINUE
1099 C RESET POINTERS
1100  ll = 0
1101  iptr(1) = 0
1102  iptr(11) = 1
1103  iptr(12) = iptr(13)
1104 C IS THIS LAST REPORT ?
1105 C PRINT *,'READY',IPTR(39),INDEX
1106  IF (iptr(39).GT.0) THEN
1107  IF (index.GT.0) THEN
1108 C PRINT *,'HERE IS SUBSET NR',INDEX
1109  RETURN
1110  END IF
1111  END IF
1112  GO TO 1000
1113  END IF
1114  END IF
1115  14 CONTINUE
1116 C GET NEXT DESCRIPTOR
1117  CALL fi8808 (iptr,iwork,lf,lx,ly,jdesc)
1118 C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
1119 C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
1120 C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
1121 C * ' FOR LOC',IPTR(17),IPTR(25)
1122 CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994
1123 C NOTE: THIS FIX NEEDED BECAUSE IWORK ARRAY DOES NOT HAVE TO BE
1124 C LIMITED TO SIZE OF "MAXD" -- WASTES SPACE BECAUSE "MAXD"
1125 C MUST BECOME OVER TWICE AS LARGE AS NEEDED FOR PROFILERS
1126 C IN ORDER TO AVOID SATISFYING THIS BELOW IF TEST
1127 CDAK IF (IPTR(11).GT.MAXD) THEN
1128  IF (iptr(11).GT.15000) THEN
1129 CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994
1130  iptr(1) = 401
1131  RETURN
1132  END IF
1133 C
1134  kprm = iptr(31) + iptr(24)
1135  IF (kprm.GT.maxd) THEN
1136  IF (kprm.GT.kold) THEN
1137  print *,'EXCEEDED ARRAY SIZE',kprm,iptr(31),
1138  * iptr(24)
1139  kold = kprm
1140  END IF
1141  END IF
1142 C REPLICATION PROCESSING
1143  IF (lf.EQ.1) THEN
1144 C ---------- F1 ---------
1145  iptr(31) = iptr(31) + 1
1146  kprm = iptr(31) + iptr(24)
1147  mstack(1,kprm) = jdesc
1148  mstack(2,kprm) = 0
1149  kdata(iptr(17),kprm) = 0
1150 C PRINT *,'FI8801-1',KPRM,MSTACK(1,KPRM),
1151 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1152  CALL fi8805(iptr,ident,msga,iwork,lx,ly,
1153  * kdata,ll,knr,mstack,maxr,maxd)
1154 C * KDATA,LL,KNR,MSTACK,MAXR,MAXD)
1155  IF (iptr(1).NE.0) THEN
1156  RETURN
1157  ELSE
1158  GO TO 12
1159  END IF
1160 C
1161 C DATA DESCRIPTION OPERATORS
1162  ELSE IF (lf.EQ.2)THEN
1163  IF (lx.EQ.4) THEN
1164  iptr(31) = iptr(31) + 1
1165  kprm = iptr(31) + iptr(24)
1166  mstack(1,kprm) = jdesc
1167  mstack(2,kprm) = 0
1168  kdata(iptr(17),kprm) = 0
1169 C PRINT *,'FI8801-2',KPRM,MSTACK(1,KPRM),
1170 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1171  END IF
1172  CALL fi8806 (iptr,lx,ly,ident,msga,kdata,ivals,mstack,
1173  * iwide1,irfvl1,iscal1,j,ll,kfxy1,iwork,jdesc,maxr,maxd,
1174  * kptrb)
1175  IF (iptr(1).NE.0) THEN
1176  RETURN
1177  END IF
1178  GO TO 12
1179 C DESCRIPTOR SEQUENCE STRINGS
1180  ELSE IF (lf.EQ.3) THEN
1181 C PRINT *,'F3 SEQUENCE DESCRIPTOR'
1182 C READ IN TABLE D, BUT JUST ONCE
1183  IF (iptr(20).EQ.0) THEN
1184  CALL fi8820 (itbld,iunitd,iptr,itbld2,kptrd)
1185  IF (iptr(1).GT.0) THEN
1186  RETURN
1187  END IF
1188 C ELSE
1189 C IF (IPTR(42).NE.0) THEN
1190 C PRINT *,'MERGE',IPTR(42),' ENTRIES INTO TABLE D'
1191 C CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
1192 C END IF
1193  END IF
1194  CALL fi8807(iptr,iwork,itbld,itbld2,jdesc,kptrd)
1195  IF (iptr(1).GT.0) THEN
1196  RETURN
1197  END IF
1198  GO TO 14
1199 C
1200 C ELEMENT DESCRIPTOR PROCESSING
1201 C
1202  ELSE
1203  kprm = iptr(31) + iptr(24)
1204  CALL fi8802(iptr,ident,msga,kdata,kfxy1,ll,mstack,
1205  * aunit1,iwide1,irfvl1,iscal1,jdesc,ivals,j,maxr,maxd,
1206  * kptrb)
1207 C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR
1208  iptr(36) = 0
1209  IF (iptr(1).GT.0) THEN
1210  RETURN
1211  ELSE
1212 C
1213 C IF ENCOUNTER CLASS 0 DESCRIPTOR
1214 C NOT CONTAINED WITHIN A BUFR
1215 C MESSAGE OF TYPE 11, THEN COLLECT
1216 C ALL TABLE B ENTRIES FOR USE ON
1217 C CURRENT BUFR MESSAGE
1218 C
1219  IF (jdesc.LE.20.AND.jdesc.GE.10) THEN
1220  IF (ident(5).NE.11) THEN
1221 C COLLECT TABLE B ENTRIES
1222  CALL fi8815(iptr,ident,jdesc,kdata,
1223  * kfxy3,maxr,maxd,aname3,aunit3,
1224  * iscal3,irfvl3,iwide3,
1225  * keyset,ibflag,ierr)
1226  IF (ierr.NE.0) THEN
1227  END IF
1228  IF (iand(ibflag,16).NE.0) THEN
1229  IF (iand(ibflag,8).NE.0) THEN
1230  IF (iand(ibflag,4).NE.0) THEN
1231  IF (iand(ibflag,2).NE.0) THEN
1232  IF (iand(ibflag,1).NE.0) THEN
1233 C HAVE A COMPLETE TABLE B ENTRY
1234  iptr(43) = iptr(43) + ident(14)
1235  keyset = 0
1236  ibflag = 0
1237  GO TO 1000
1238  END IF
1239  END IF
1240  END IF
1241  END IF
1242  END IF
1243  END IF
1244  END IF
1245  IF (ident(16).EQ.0) THEN
1246  knr(iptr(17)) = iptr(31)
1247  ELSE
1248  DO 310 kj = 1, maxr
1249  knr(kj) = iptr(31)
1250  310 CONTINUE
1251  END IF
1252  GO TO 10
1253  END IF
1254  END IF
1255 C END IF
1256 C END DO WHILE
1257  200 CONTINUE
1258 C IF (IDENT(16).NE.0) THEN
1259 C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
1260 C ELSE
1261 C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS'
1262 C END IF
1263  RETURN
1264  END
1265 C> @brief Process element descriptor.
1266 C> @author Bill Cavanaugh @date 1988-09-01
1267 
1268 C> Process an element descriptor (f = 0) and store data
1269 C> in output array.
1270 C>
1271 C> Program history log:
1272 C> 88-09-01
1273 C> 91-04-04 Changed to pass width of text fields in bytes
1274 C>
1275 C> @param[in] IPTR See w3fi88 routine docblock
1276 C> @param[in] IDENT See w3fi88 routine docblock
1277 C> @param[in] MSGA Array containing bufr message
1278 C> @param[inout] KDATA Array containing decoded reports from bufr message.
1279 C> KDATA(Report number,parameter number)
1280 C> (report number limited to value of input argument
1281 C> maxr and parameter number limited to value of input
1282 C> argument maxd)
1283 C> @param[inout] KFXY1 Image of current descriptor
1284 C> @param[in] MSTACK
1285 C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
1286 C> a bufr message
1287 C> @param[in] MAXD Maximum number of descriptor combinations that
1288 C> may be processed; upper air data and some satellite
1289 C> data require a value for maxd of 1700, but for most
1290 C> other data a value for maxd of 500 will suffice
1291 C> arrays containing data from table b
1292 C> @param[out] AUNIT1 Units for descriptor
1293 C> @param[out] ISCAL1 Scale for value of descriptor
1294 C> @param[out] IRFVL1 Reference value for descriptor
1295 C> @param[out] IWIDE1 Bit width for value of descriptor
1296 C> @param LL
1297 C> @param JDESC
1298 C> @param IVALS
1299 C> @param J
1300 C> @param KPTRB
1301 C>
1302 C> Error return:
1303 C> IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist
1304 C> in table b.
1305 C>
1306 C> @author Bill Cavanaugh @date 1988-09-01
1307  SUBROUTINE fi8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1,
1308  * IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,KPTRB)
1309 
1310 C TABLE B ENTRY
1311  CHARACTER*24 ASKEY
1312  INTEGER MSGA(*)
1313  INTEGER IPTR(*)
1314  INTEGER KPTRB(*)
1315  INTEGER IDENT(*)
1316  INTEGER J
1317  INTEGER JDESC
1318  INTEGER MSTACK(2,MAXD)
1319  INTEGER KDATA(MAXR,MAXD),IVALS(*)
1320 C ..................................................
1321 C
1322 C NEW BASE TABLE B
1323 C MAY BE A COMBINATION OF MASTER TABLE B
1324 C AND ANCILLARY TABLE B
1325 C
1326  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
1327 C CHARACTER*40 ANAME1(*)
1328  CHARACTER*24 AUNIT1(*)
1329 C ..................................................
1330  SAVE
1331 C
1332  DATA ASKEY /'CCITT IA5 '/
1333 C
1334 C PRINT *,' FI8802 - ELEMENT DESCRIPTOR ',JDESC,KPTRB(JDESC)
1335 C FIND TABLE B ENTRY
1336  j = kptrb(jdesc)
1337 C HAVE A MATCH
1338 C SET FLAG IF TEXT EVENT
1339 C PRINT *,'ASKEY=',ASKEY,'AUNIT1(',J,')=',AUNIT1(J),JDESC
1340  IF (askey(1:9).EQ.aunit1(j)(1:9)) THEN
1341  iptr(18) = 1
1342  iptr(40) = iwide1(j) / 8
1343  ELSE
1344  iptr(18) = 0
1345  END IF
1346 C PRINT *,'FI8802 - BIT WIDTH =',IWIDE1(J),IPTR(18),' FOR',JDESC
1347  IF (ident(16).NE.0) THEN
1348 C COMPRESSED
1349  CALL fi8803(iptr,ident,msga,kdata,ivals,mstack,
1350  * iwide1,irfvl1,iscal1,j,jdesc,maxr,maxd)
1351 C IF (IPTR(1).NE.0) THEN
1352 C RETURN
1353 C END IF
1354  ELSE
1355 C NOT COMPRESSED
1356 C PRINT *,' FROM FI8802',J
1357  CALL fi8804(iptr,msga,kdata,ivals,mstack,
1358  * iwide1,irfvl1,iscal1,j,ll,jdesc,maxr,maxd)
1359 C IF (IPTR(1).NE.0) THEN
1360 C RETURN
1361 C END IF
1362  END IF
1363  RETURN
1364  END
1365 C> @brief Process compressed data
1366 C> @author Bill Cavanaugh @date 1988-09-01
1367 
1368 C> Process compressed data and place individual elements
1369 C> into output array.
1370 C>
1371 C> Program history log:
1372 C> - Bill Cavanaugh 1988-09-01
1373 C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
1374 C> modified to hanle width of fields in bytes.
1375 C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
1376 C> and uncompressed form gave different results.
1377 C> this has been corrected.
1378 C> - Bill Cavanaugh 1991-06-21 Processing of text data has been changed to
1379 C> provide exact reproduction of all characters.
1380 C> - Bill Cavanaugh 1994-04-11 Corrected processing of data when all values
1381 C> the same (nbinc = 0). corrected test of lowest
1382 C> value against proper bit mask.
1383 C> - Dennis Keyser 1995-06-07 Corrected an error which resulted in
1384 C> returned scale in "mstack(2, ..)" always
1385 C> being set to zero for compressed data. also,
1386 C> scale changes were not being recognized.
1387 C>
1388 C> @param[in] IPTR See w3fi88 routine docblock
1389 C> @param[in] IDENT See w3fi88 routine docblock
1390 C> @param[in] MSGA Array containing bufr message,mstack,
1391 C> @param[in] IVALS Array of single parameter values
1392 C> @param[inout] J
1393 C> @param[in] MAXR Maximum number of reports/subsets that may be
1394 C> contained in a bufr message
1395 C> @param[in] MAXD Maximum number of descriptor combinations that
1396 C> may be processed; upper air data and some satellite
1397 C> data require a value for maxd of 1700, but for most
1398 C> other data a value for maxd of 500 will suffice
1399 C> @param[out] KDATA Array containing decoded reports from bufr message.
1400 C> KDATA(Report number,parameter number)
1401 C> (report number limited to value of input argument
1402 C> maxr and parameter number limited to value of input
1403 C> argument maxd)
1404 C> arrays containing data from table b
1405 C> @param[out] ISCAL1 Scale for value of descriptor
1406 C> @param[out] IRFVL1 Reference value for descriptor
1407 C> @param[out] IWIDE1 Bit width for value of descriptor
1408 C> @param MSTACK
1409 C> @param JDESC
1410 C>
1411 C> @author Bill Cavanaugh @date 1988-09-01
1412  SUBROUTINE fi8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
1413  * IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD)
1414 
1415 C
1416 C ..................................................
1417 C
1418 C NEW BASE TABLE B
1419 C MAY BE A COMBINATION OF MASTER TABLE B
1420 C AND ANCILLARY TABLE B
1421 C
1422 C INTEGER KFXY1(*)
1423  INTEGER ISCAL1(*)
1424  INTEGER IRFVL1(3,*)
1425  INTEGER IWIDE1(*)
1426 C CHARACTER*40 ANAME1(*)
1427 C CHARACTER*24 AUNIT1(*)
1428 C ..................................................
1429  INTEGER MAXD,MAXR
1430  INTEGER MSGA(*),JDESC,MSTACK(2,MAXD)
1431  INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD)
1432  INTEGER NRVALS,JWIDE,IDATA
1433  INTEGER IDENT(*)
1434  INTEGER J
1435  INTEGER KLOW(256)
1436 C
1437  LOGICAL TEXT
1438 C
1439  INTEGER MSK(32)
1440 C
1441  SAVE
1442 C
1443  DATA msk /1, 3, 7, 15, 31, 63, 127,
1444 C 1 2 3 4 5 6 7
1445  * 255, 511, 1023, 2047, 4095,
1446 C 8 9 10 11 12
1447  * 8191, 16383, 32767, 65535,
1448 C 13 14 15 16
1449  * 131071, 262143, 524287,
1450 C 17 18 19
1451  * 1048575, 2097151, 4194303,
1452 C 20 21 22
1453  * 8388607, 16777215, 33554431,
1454 C 23 24 25
1455  * 67108863, 134217727, 268435455,
1456 C 26 27 28
1457  * 536870911, 1073741823, 2147483647,-1 /
1458 C 29 30 31 32
1459  CALL w3fi01(lw)
1460  mwdbit = iptr(44)
1461  IF (iptr(45).EQ.8) THEN
1462  i = 2147483647
1463  msk(32) = i + i + 1
1464  END IF
1465 C
1466 C PRINT *,' FI8803 COMPR J=',J,' IWIDE1(J) =',IWIDE1(J),
1467 C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25)
1468  IF (iptr(18).EQ.0) THEN
1469  text = .false.
1470  ELSE
1471  text = .true.
1472  END IF
1473 C PRINT *,'DESCRIPTOR',KPRM,JDESC
1474  IF (.NOT.text) THEN
1475  IF (iptr(29).GT.0.AND.jdesc.NE.7957) THEN
1476 C PRINT *,'ASSOCIATED FIELD AT',IPTR(25)
1477 C WORKING WITH ASSOCIATED FIELDS HERE
1478  iptr(31) = iptr(31) + 1
1479  kprm = iptr(31) + iptr(24)
1480 C GET LOWEST
1481  CALL gbyte (msga,lowest,iptr(25),iptr(29))
1482  iptr(25) = iptr(25) + iptr(29)
1483 C GET NBINC
1484  CALL gbyte (msga,nbinc,iptr(25),6)
1485  iptr(25) = iptr(25) + 6
1486 C PRINT *,'LOWEST=',LOWEST,' NBINC=',NBINC
1487  IF (nbinc.GT.32) THEN
1488  iptr(1) = 22
1489  RETURN
1490  END IF
1491 C EXTRACT DATA FOR ASSOCIATED FIELD
1492  IF (nbinc.GT.0) THEN
1493  CALL gbytes (msga,ivals,iptr(25),nbinc,0,iptr(21))
1494  iptr(25) = iptr(25) + nbinc * iptr(21)
1495  DO 50 i = 1, ident(14)
1496  kdata(i,kprm) = ivals(i) + lowest
1497  IF (nbinc.EQ.32) THEN
1498  IF (kdata(i,kprm).EQ.msk(nbinc)) THEN
1499  kdata(i,kprm) = 999999
1500  END IF
1501  ELSE IF (kdata(i,kprm).GE.msk(nbinc)) THEN
1502  kdata(i,kprm) = 999999
1503  END IF
1504  50 CONTINUE
1505  ELSE
1506  DO 51 i = 1, ident(14)
1507  kdata(i,kprm) = lowest
1508  IF (nbinc.EQ.32) THEN
1509  IF (lowest.EQ.msk(32)) THEN
1510  kdata(i,kprm) = 999999
1511  END IF
1512  ELSE IF(lowest.GE.msk(nbinc)) THEN
1513  kdata(i,kprm) = 999999
1514  END IF
1515  51 CONTINUE
1516  END IF
1517  END IF
1518 C SET PARAMETER
1519 C ISOLATE COMBINED BIT WIDTH
1520  jwide = iwide1(j) + iptr(26)
1521 C
1522  IF (jwide.GT.32) THEN
1523 C TOO MANY BITS IN COMBINED
1524 C BIT WIDTH
1525  print *,'ERR 22 - HAVE EXCEEDED COMBINED BIT WIDTH'
1526  iptr(1) = 22
1527  RETURN
1528  END IF
1529 C SINGLE VALUE FOR LOWEST
1530  nrvals = 1
1531 C LOWEST
1532 C PRINT *,'PARAM',KPRM
1533  CALL gbyte (msga,lowest,iptr(25),jwide)
1534 C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
1535  iptr(25) = iptr(25) + jwide
1536 C ISOLATE COMPRESSED BIT WIDTH
1537  CALL gbyte (msga,nbinc,iptr(25),6)
1538 C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25)
1539  IF (nbinc.GT.32) THEN
1540 C NBINC TOO LARGE
1541  iptr(1) = 22
1542  RETURN
1543  END IF
1544  IF (iptr(32).EQ.2.AND.iptr(33).EQ.5) THEN
1545  ELSE
1546  IF (nbinc.GT.jwide) THEN
1547 C PRINT *,'FOR DESCRIPTOR',JDESC
1548 C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' IWIDE1(J)=',
1549 C * IWIDE1(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
1550 C DO 110 I = 1, KPRM
1551 C WRITE (6,111)I,(KDATA(J,I),J=1,6)
1552 C 110 CONTINUE
1553 C 111 FORMAT (1X,5HDATA ,I3,6(2X,I10))
1554  iptr(1) = 500
1555  print *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE',
1556  * ' B PLUS WIDTH CHANGES'
1557  END IF
1558  END IF
1559  iptr(25) = iptr(25) + 6
1560 C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
1561 C IF TEXT EVENT, PROCESS TEXT
1562 C GET COMPRESSED VALUES
1563 C PRINT *,'COMPRESSED VALUES - NONTEXT'
1564  nrvals = ident(14)
1565  iptr(31) = iptr(31) + 1
1566  kprm = iptr(31) + iptr(24)
1567  IF (nbinc.NE.0) THEN
1568  CALL gbytes (msga,ivals,iptr(25),nbinc,0,nrvals)
1569  iptr(25) = iptr(25) + nbinc * nrvals
1570 C RECALCULATE TO ORIGINAL VALUES
1571  DO 100 i = 1, nrvals
1572 C PRINT *,IVALS(I),MSK(NBINC),NBINC
1573  IF (ivals(i).GE.msk(nbinc)) THEN
1574  kdata(i,kprm) = 999999
1575  ELSE
1576  IF (irfvl1(2,j).EQ.0) THEN
1577  jrv = irfvl1(1,j)
1578  ELSE
1579  jrv = irfvl1(3,j)
1580  END IF
1581  kdata(i,kprm) = ivals(i) + lowest + jrv
1582  END IF
1583  100 CONTINUE
1584 C PRINT *,I,JDESC,LOWEST,IRFVL1(1,J),IRFVL1(3,J)
1585  ELSE
1586  IF (lowest.EQ.msk(jwide)) THEN
1587  DO 105 i = 1, nrvals
1588  kdata(i,kprm) = 999999
1589  105 CONTINUE
1590  ELSE
1591  IF (irfvl1(2,j).EQ.0) THEN
1592  jrv = irfvl1(1,j)
1593  ELSE
1594  jrv = irfvl1(3,j)
1595  END IF
1596  icomb = lowest + jrv
1597  DO 106 i = 1, nrvals
1598  kdata(i,kprm) = icomb
1599  106 CONTINUE
1600  END IF
1601  END IF
1602 C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25)
1603  mstack(1,kprm) = jdesc
1604 C WRITE (6,80) (KDATA(I,KPRM),I=1,10)
1605  80 FORMAT(2x,10(f10.2,1x))
1606 CVVVVVCHANGE#3 FIX BY KEYSER -- 12/06/1994
1607 C NOTE: THIS FIX NEEDED BECAUSE THE RETURNED SCALE IN MSTACK(2,..)
1608 C WAS ALWAYS '0' FOR COMPRESSED DATA, INCL. CHANGED SCALES)
1609  mstack(2,kprm) = iscal1(j) + iptr(27)
1610 CAAAAACHANGE#3 FIX BY KEYSER -- 12/06/1994
1611  ELSE IF (text) THEN
1612 C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
1613 C GET LOWEST
1614 C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40))
1615  DO 1906 k = 1, iptr(40)
1616  CALL gbyte (msga,klow,iptr(25),8)
1617  iptr(25) = iptr(25) + 8
1618  IF (klow(k).NE.0) THEN
1619  iptr(1) = 27
1620  print *,'NON-ZERO LOWEST ON TEXT DATA'
1621  RETURN
1622  END IF
1623  1906 CONTINUE
1624 C PRINT *,'TEXT - LOWEST = 0'
1625 C GET NBINC
1626  CALL gbyte (msga,nbinc,iptr(25),6)
1627  iptr(25) = iptr(25) + 6
1628  IF (nbinc.NE.iptr(40)) THEN
1629  iptr(1) = 28
1630  print *,'NBINC IS NOT THE NUMBER OF CHARACTERS',nbinc
1631  RETURN
1632  END IF
1633 C PRINT *,'TEXT NBINC =',NBINC
1634 C FOR NUMBER OF OBSERVATIONS
1635  iptr(31) = iptr(31) + 1
1636  kprm = iptr(31) + iptr(24)
1637  istart = kprm
1638  i24 = iptr(24)
1639  DO 1900 n = 1, ident(14)
1640  kprm = istart
1641  iptr(24) = i24
1642  nbits = iptr(40) * 8
1643  1700 CONTINUE
1644 C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS
1645  IF (nbits.GT.mwdbit) THEN
1646  CALL gbyte (msga,idata,iptr(25),mwdbit)
1647  iptr(25) = iptr(25) + mwdbit
1648  nbits = nbits - mwdbit
1649  IF (iptr(37).EQ.0) THEN
1650 C CONVERTS ASCII TO EBCIDIC
1651  CALL w3ai39 (idata,lw)
1652  END IF
1653  mstack(1,kprm) = jdesc
1654  mstack(2,kprm) = 0
1655  kdata(n,kprm) = idata
1656 C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
1657 C SET FOR NEXT PART
1658  kprm = kprm + 1
1659  iptr(24) = iptr(24) + 1
1660 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
1661 C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,I12)
1662  GO TO 1700
1663  ELSE IF (nbits.GT.0) THEN
1664  CALL gbyte (msga,idata,iptr(25),nbits)
1665  iptr(25) = iptr(25) + nbits
1666  ibuf = (iptr(44) - nbits) / 8
1667  IF (ibuf.GT.0) THEN
1668  DO 1750 mp = 1, ibuf
1669  idata = idata * 256 + 32
1670  1750 CONTINUE
1671  END IF
1672 C CONVERTS ASCII TO EBCIDIC
1673  IF (iptr(37).EQ.0) THEN
1674  CALL w3ai39 (idata,lw)
1675  END IF
1676  mstack(1,kprm) = jdesc
1677  mstack(2,kprm) = 0
1678  kdata(n,kprm) = idata
1679 C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
1680 C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
1681  nbits = 0
1682  END IF
1683 C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
1684 C1800 FORMAT (2X,I4,2X,3A4)
1685  1900 CONTINUE
1686  END IF
1687  RETURN
1688  END
1689 C> @brief Process serial data
1690 C> @author Bill Cavanaugh @date 1988-09-01
1691 
1692 C> Process data that is not compressed
1693 C>
1694 C> Program history log:
1695 C> - Bill cavanaugh 1988-09-01
1696 C> - Bill cavanaugh 1991-01-18 Modified to properly handle non-compressed
1697 C> data.
1698 C> - Bill cavanaugh 1991-04-04 Text handling portion of this routine
1699 C> modified to handle field width in bytes.
1700 C> - Bill cavanaugh 1991-04-17 ests showed that the same data in compressed
1701 C> and uncompressed form gave different results.
1702 C> this has been corrected.
1703 C>
1704 C> @param[in] IPTR See w3fi88() routine docblock
1705 C> @param[in] MSGA Array containing bufr message
1706 C> @param[inout] IVALS Array of single parameter values
1707 C> @param[inout] J
1708 C> @param[in] MAXR Maximum number of reports/subsets that may be
1709 C> contained in a bufr message
1710 C> @param[in] MAXD Maximum number of descriptor combinations that
1711 C> may be processed; upper air data and some satellite
1712 C> data require a value for maxd of 1700, but for most
1713 C> other data a value for maxd of 500 will suffice
1714 C> @param[out] KDATA Array containing decoded reports from bufr message.
1715 C> KDATA(Report number,parameter number)
1716 C> (report number limited to value of input argument
1717 C> maxr and parameter number limited to value of input
1718 C> argument maxd)
1719 C> Arrays containing data from table b
1720 C> @param[out] ISCAL1 Scale for value of descriptor
1721 C> @param[out] IRFVL1 Reference value for descriptor
1722 C> @param[out] IWIDE1 Bit width for value of descriptorE
1723 C> @param MSTACK
1724 C> @param LL
1725 C> @param JDESC
1726 C>
1727 C> Error return:
1728 C> IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
1729 C>
1730 C> @author Bill Cavanaugh @date 1988-09-01
1731  SUBROUTINE fi8804(IPTR,MSGA,KDATA,IVALS,MSTACK,
1732  * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD)
1733 
1734 C ..................................................
1735 C
1736 C NEW BASE TABLE B
1737 C MAY BE A COMBINATION OF MASTER TABLE B
1738 C AND ANCILLARY TABLE B
1739 C
1740 C INTEGER KFXY1(*)
1741  INTEGER ISCAL1(*)
1742  INTEGER IRFVL1(3,*)
1743  INTEGER IWIDE1(*)
1744 C CHARACTER*40 ANAME1(*)
1745 C CHARACTER*24 AUNIT1(*)
1746 C ..................................................
1747 C
1748  INTEGER MSGA(*),MAXD,MAXR
1749  INTEGER IPTR(*)
1750  INTEGER JDESC
1751  INTEGER IVALS(*)
1752 C INTEGER LSTBLK(3)
1753  INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD)
1754  INTEGER J,LL
1755 C LOGICAL LKEY
1756 C
1757 C
1758  INTEGER ITEST(32)
1759 C
1760  SAVE
1761 C
1762  DATA itest /1,3,7,15,31,63,127,255,
1763  * 511,1023,2047,4095,8191,16383,
1764  * 32767, 65535,131071,262143,524287,
1765  * 1048575,2097151,4194303,8388607,
1766  * 16777215,33554431,67108863,134217727,
1767  * 268435455,536870911,1073741823,
1768  * 2147483647,-1/
1769 C
1770  mwdbit = iptr(44)
1771  IF (iptr(45).NE.4) THEN
1772  i = 2147483647
1773  itest(32) = i + i + 1
1774  END IF
1775 C
1776 C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)
1777 C -------- NOCMP --------
1778 C IF NOT TEXT EVENT, PROCESS
1779  IF (iptr(18).EQ.0) THEN
1780 C PRINT *,' NOT TEXT'
1781  IF ((iptr(26)+iwide1(j)).LT.1) THEN
1782 C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)
1783  iptr(1) = 501
1784  RETURN
1785  END IF
1786 C ISOLATE BIT WIDTH
1787  jwide = iwide1(j) + iptr(26)
1788 C IF ASSOCIATED FIELD SW ON
1789  IF (iptr(29).GT.0) THEN
1790  IF (jdesc.NE.7957.AND.jdesc.NE.7937) THEN
1791  iptr(31) = iptr(31) + 1
1792  kprm = iptr(31) + iptr(24)
1793  mstack(1,kprm) = 33792 + iptr(29)
1794  mstack(2,kprm) = 0
1795  CALL gbyte (msga,ivals,iptr(25),iptr(29))
1796  iptr(25) = iptr(25) + iptr(29)
1797  kdata(iptr(17),kprm) = ivals(1)
1798 C PRINT *,'FI8804-A',KPRM,MSTACK(1,KPRM),
1799 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
1800  END IF
1801  END IF
1802  iptr(31) = iptr(31) + 1
1803  kprm = iptr(31) + iptr(24)
1804  mstack(1,kprm) = jdesc
1805 C IF (IPTR(27).NE.0) THEN
1806 C MSTACK(2,KPRM) = IPTR(27)
1807 C ELSE
1808  mstack(2,kprm) = iscal1(j) + iptr(27)
1809 C END IF
1810 C GET VALUES
1811 C CALL TO GET DATA OF GIVEN BIT WIDTH
1812  CALL gbyte (msga,ivals,iptr(25),jwide)
1813 C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
1814  iptr(25) = iptr(25) + jwide
1815 C RETURN WITH SINGLE VALUE
1816  IF (irfvl1(2,j).EQ.0) THEN
1817  jrv = irfvl1(1,j)
1818  ELSE
1819  jrv = irfvl1(3,j)
1820  END IF
1821  IF (jwide.EQ.32) THEN
1822  IF (ivals(1).EQ.itest(jwide)) THEN
1823  kdata(iptr(17),kprm) = 999999
1824  ELSE
1825  kdata(iptr(17),kprm) = ivals(1) + jrv
1826  END IF
1827  ELSE IF (ivals(1).GE.itest(jwide)) THEN
1828  kdata(iptr(17),kprm) = 999999
1829  ELSE
1830  kdata(iptr(17),kprm) = ivals(1) + jrv
1831  END IF
1832 C PRINT *,'FI8804-B',KPRM,MSTACK(1,KPRM),
1833 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
1834 C IF(JDESC.EQ.2049) THEN
1835 C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
1836 C END IF
1837 C PRINT *,'FI8804 ',KPRM,MSTACK(1,KPRM),
1838 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1839  ELSE
1840 C PRINT *,' TEXT'
1841 C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
1842  jwide = iptr(40) * 8
1843 C PRINT *,' WIDTH =',JWIDE,IPTR(40)
1844  nrchrs = iptr(40)
1845  nrbits = jwide
1846 C PRINT *,' CHARS =',NRCHRS,' BITS =',NRBITS
1847  iptr(31) = iptr(31) + 1
1848  kany = 0
1849  1800 CONTINUE
1850  kany = kany + 1
1851 C PRINT *,' NR BITS THIS PASS',NRBITS
1852  IF (nrbits.GT.mwdbit) THEN
1853  CALL gbyte (msga,idata,iptr(25),mwdbit)
1854 C PRINT 1801,KANY,IDATA,IPTR(17),KPRM,NRBITS
1855  1801 FORMAT (1x,i2,4x,z8,2(4x,i4))
1856 C CONVERTS ASCII TO EBCIDIC
1857 C COMMENT OUT IF NOT IBM370 COMPUTER
1858  IF (iptr(37).EQ.0) THEN
1859  CALL w3ai39 (idata,iptr(45))
1860  END IF
1861  kprm = iptr(31) + iptr(24)
1862  kdata(iptr(17),kprm) = idata
1863  mstack(1,kprm) = jdesc
1864  mstack(2,kprm) = 0
1865 C PRINT *,'BODY ',KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
1866 C * KDATA(IPTR(17),KPRM)
1867  iptr(25) = iptr(25) + mwdbit
1868  nrbits = nrbits - mwdbit
1869  iptr(24) = iptr(24) + 1
1870  GO TO 1800
1871  ELSE IF (nrbits.GT.0) THEN
1872  CALL gbyte (msga,idata,iptr(25),nrbits)
1873  iptr(25) = iptr(25) + nrbits
1874 C CONVERTS ASCII TO EBCIDIC
1875 C COMMENT OUT IF NOT IBM370 COMPUTER
1876  IF (iptr(37).EQ.0) THEN
1877  CALL w3ai39 (idata,iptr(45))
1878  END IF
1879  kprm = iptr(31) + iptr(24)
1880  kshft = mwdbit - nrbits
1881  IF (kshft.GT.0) THEN
1882  ktry = kshft / 8
1883  DO 1722 lak = 1, ktry
1884  IF (iptr(37).EQ.0) THEN
1885  idata = idata * 256 + 64
1886  ELSE
1887  idata = idata * 256 + 32
1888  END IF
1889 C PRINT 1723,IDATA
1890 C1723 FORMAT (12X,Z8)
1891  1722 CONTINUE
1892  END IF
1893  kdata(iptr(17),kprm) = idata
1894 C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
1895  mstack(1,kprm) = jdesc
1896  mstack(2,kprm) = 0
1897 C PRINT *,'TAIL ',KPRM,MSTACK(1,KPRM),
1898 C * KDATA(IPTR(17),KPRM)
1899  END IF
1900  END IF
1901  RETURN
1902  END
1903 C> @brief Process a replication descriptor
1904 C> @author Bill Cavanaugh @date 1988-09-01
1905 
1906 C> Process a replication descriptor, must extract number
1907 C> of replications of n descriptors from the data stream.
1908 C>
1909 C> Program history log:
1910 C> - Bill Cavanaugh 1988-09-01
1911 C>
1912 C> @param[in] IWORK Working descriptor list
1913 C> @param[in] IPTR See w3fi88 routine docblock
1914 C> @param[in] IDENT See w3fi88 routine docblock
1915 C> @param[inout] LX X portion of current descriptor
1916 C> @param[inout] LY Y portion of current descriptor
1917 C> @param[in] MAXR Maximum number of reports/subsets that may be
1918 C> contained in a bufr message
1919 C> @param[in] MAXD Maximum number of descriptor combinations that
1920 C> may be processed; upper air data and some satellite
1921 C> data require a value for maxd of 1700, but for most
1922 C> other data a value for maxd of 500 will suffice
1923 C> @param[out] KDATA Array containing decoded reports from bufr message.
1924 C> KDATA(Report number,parameter number)
1925 C> (report number limited to value of input argument
1926 C> maxr and parameter number limited to value of input
1927 C> argument maxd)
1928 C> @param MSGA
1929 C> @param LL
1930 C> @param KNR
1931 C> @param MSTACK
1932 C>
1933 C> Error return:
1934 C> - IPTR(1)
1935 C> - = 12 Data descriptor qualifier does not follow delayed replication descriptor
1936 C> - = 20 Exceeded count for delayed replication pass
1937 C>
1938 C> @author Bill Cavanaugh @date 1988-09-01
1939  SUBROUTINE fi8805(IPTR,IDENT,MSGA,IWORK,LX,LY,
1940  * KDATA,LL,KNR,MSTACK,MAXR,MAXD)
1941 
1942 C
1943  INTEGER IPTR(*)
1944  INTEGER KNR(MAXR)
1945  INTEGER ITEMP(2000)
1946  INTEGER LL
1947  INTEGER KTEMP(2000)
1948  INTEGER KDATA(MAXR,MAXD)
1949  INTEGER LX,MSTACK(2,MAXD)
1950  INTEGER LY
1951  INTEGER MSGA(*)
1952  INTEGER KVALS(1300)
1953 CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994
1954 C NOTE: THIS FIX JUST CLEANS UP CODE SINCE IWORK ARRAY IS EARLIER
1955 C DEFINED AS 15000 WORDS
1956  INTEGER IWORK(*)
1957 CDAK INTEGER IWORK(MAXD)
1958 CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994
1959  INTEGER IDENT(*)
1960 C
1961  SAVE
1962 C
1963 C PRINT *,' REPLICATION FI8805'
1964 C DO 7100 I = 1, IPTR(13)
1965 C PRINT *,I,IWORK(I)
1966 C7100 CONTINUE
1967 C NUMBER OF DESCRIPTORS
1968  nrset = lx
1969 C NUMBER OF REPLICATIONS
1970  nrreps = ly
1971  icurr = iptr(11) - 1
1972  ipick = iptr(11) - 1
1973 C
1974  IF (nrreps.EQ.0) THEN
1975  iptr(39) = 1
1976 C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
1977 C IPTR(31) = IPTR(31) + 1
1978 C KPRM = IPTR(31) + IPTR(24)
1979 C MSTACK(1,KPRM) = JDESC
1980 C MSTACK(2,KPRM) = 0
1981 C KDATA(IPTR(17),KPRM) = 0
1982 C PRINT *,'FI8805-1',KPRM,MSTACK(1,KPRM),
1983 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1984 C DELAYED REPLICATION - MUST GET NUMBER OF
1985 C REPLICATIONS FROM DATA.
1986 C GET NEXT DESCRIPTOR
1987  CALL fi8808(iptr,iwork,lf,lx,ly,jdesc)
1988 C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
1989 C MUST BE DATA DESCRIPTION
1990 C OPERATION QUALIFIER
1991  IF (jdesc.EQ.7937.OR.jdesc.EQ.7947) THEN
1992  jwide = 8
1993  ELSE IF (jdesc.EQ.7938.OR.jdesc.EQ.7948) THEN
1994  jwide = 16
1995  ELSE IF (jdesc.EQ.7936) THEN
1996  jwide = 1
1997  ELSE
1998  iptr(1) = 12
1999  RETURN
2000  END IF
2001 C THIS IF BLOCK IS SET TO HANDLE
2002 C DATA/DESCRIPTOR REPLICATION
2003  IF (jdesc.EQ.7947.OR.jdesc.EQ.7948) THEN
2004 C SET DATA/DESCRIPTOR REPLICATION FLAG = ON
2005  iptr(38) = 1
2006 C SAVE AS NEXT ENTRY IN KDATA, MSTACK
2007  iptr(31) = iptr(31) + 1
2008  kprm = iptr(31) + iptr(24)
2009  mstack(1,kprm) = jdesc
2010  mstack(2,kprm) = 0
2011  CALL gbyte (msga,kvals,iptr(25),jwide)
2012  iptr(25) = iptr(25) + jwide
2013  kdata(iptr(17),kprm) = kvals(1)
2014  RETURN
2015  END IF
2016 
2017 C SET SINGLE VALUE FOR SEQUENTIAL,
2018 C MULTIPLE VALUES FOR COMPRESSED
2019  IF (ident(16).EQ.0) THEN
2020 
2021 C NON COMPRESSED
2022  CALL gbyte (msga,kvals,iptr(25),jwide)
2023 C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1)
2024  iptr(25) = iptr(25) + jwide
2025  iptr(31) = iptr(31) + 1
2026  kprm = iptr(31) + iptr(24)
2027  mstack(1,kprm) = jdesc
2028  mstack(2,kprm) = 0
2029  kdata(iptr(17),kprm) = kvals(1)
2030  nrreps = kvals(1)
2031 C PRINT *,'FI8805-2',KPRM,MSTACK(1,KPRM),
2032 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
2033  ELSE
2034  nrvals = ident(14)
2035  CALL gbytes (msga,kvals,iptr(25),jwide,0,nrvals)
2036  iptr(25) = iptr(25) + jwide * nrvals
2037  iptr(31) = iptr(31) + 1
2038  kprm = iptr(31) + iptr(24)
2039  mstack(1,kprm) = jdesc
2040  mstack(2,kprm) = 0
2041  kdata(iptr(17),kprm) = kvals(1)
2042  DO 100 i = 1, nrvals
2043  kdata(i,kprm) = kvals(i)
2044  100 CONTINUE
2045  nrreps = kvals(1)
2046  END IF
2047  ELSE
2048 C PRINT *,'NOT DELAYED REPLICATION'
2049  END IF
2050 C RESTRUCTURE WORKING STACK W/REPLICATIONS
2051  IF (nrreps.EQ.0) THEN
2052 C PRINT *,'RESTRUCTURING - NO REPLICATION'
2053  iptr(11) = ipick + nrset + 2
2054  GO TO 9999
2055  END IF
2056 C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
2057 C PICK UP DESCRIPTORS TO BE REPLICATED
2058  DO 1000 i = 1, nrset
2059  CALL fi8808(iptr,iwork,lf,lx,ly,jdesc)
2060  itemp(i) = jdesc
2061 C PRINT *,'REPLICATION ',I,ITEMP(I)
2062  1000 CONTINUE
2063 C MOVE TRAILING DESCRIPTORS TO HOLD AREA
2064  lax = iptr(12) - iptr(11) + 1
2065 C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12)
2066  DO 2000 i = 1, lax
2067  CALL fi8808(iptr,iwork,lf,lx,ly,jdesc)
2068  ktemp(i) = jdesc
2069 C PRINT *,' ',I,KTEMP(I)
2070  2000 CONTINUE
2071 C REPLICATIONS INTO ISTACK
2072 C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
2073 C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
2074  DO 4000 i = 1, nrreps
2075  DO 3000 j = 1, nrset
2076  iwork(icurr) = itemp(j)
2077 C PRINT *,'FI8805 A',ICURR,IWORK(ICURR)
2078  icurr = icurr + 1
2079  3000 CONTINUE
2080  4000 CONTINUE
2081 C PRINT *,' TO LOC',ICURR-1
2082 C RESTORE TRAILING DESCRIPTORS
2083 C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
2084  DO 5000 i = 1, lax
2085  iwork(icurr) = ktemp(i)
2086 C PRINT *,'FI8805 B',ICURR,IWORK(ICURR)
2087  icurr = icurr + 1
2088  5000 CONTINUE
2089  iptr(12) = icurr - 1
2090  iptr(11) = ipick
2091  9999 CONTINUE
2092 C DO 5500 I = 1, IPTR(12)
2093 C PRINT *,'FI8805 B',I,IWORK(I),IPTR(11)
2094 C5500 CONTINUE
2095  RETURN
2096  END
2097 C> @brief Process operator descriptors
2098 C> @author Bill Cavanaugh @date 1988-09-01
2099 
2100 C> Extract and save indicated change values for use
2101 C> until changes are rescinded, or extract text strings indicated
2102 C> through 2 05 yyy.
2103 C>
2104 C> Program history log:
2105 C> - Bill Cavanaugh 1988-09-01
2106 C> - Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
2107 C> - Bill Cavanaugh 1991-05-10 Coding has been added to process properly
2108 C> table c descriptor 2 06 yyy.
2109 C> - Bill Cavanaugh 1991-11-21 Coding has been added to properly process
2110 C> table c descriptor 2 03 yyy, the change
2111 C> to new reference value for selected
2112 C> descriptors.
2113 C>
2114 C> @param[in] IPTR See w3fi88 routine docblock
2115 C> @param[in] LX X portion of current descriptor
2116 C> @param[in] LY Y portion of current descriptor
2117 C> @param[in] MAXR Maximum number of reports/subsets that may be
2118 C> contained in a bufr message
2119 C> @param[in] MAXD Maximum number of descriptor combinations that
2120 C> may be processed; upper air data and some satellite
2121 C> data require a value for maxd of 1700, but for most
2122 C> other data a value for maxd of 500 will suffice
2123 C> @param[out] KDATA Array containing decoded reports from bufr message.
2124 C> KDATA(Report number,parameter number)
2125 C> (report number limited to value of input argument
2126 C> maxr and parameter number limited to value of input
2127 C> argument maxd)
2128 C> Arrays containing data from table b
2129 C> @param[out] ISCAL1 Scale for value of descriptor
2130 C> @param[out] IRFVL1 Reference value for descriptor
2131 C> @param[out] IWIDE1 Bit width for value of descriptor
2132 C> @param IDENT
2133 C> @param MSGA
2134 C> @param IVALS
2135 C> @param MSTACK
2136 C> @param J
2137 C> @param LL
2138 C> @param KFXY1
2139 C> @param IWORK
2140 C> @param JDESC
2141 C> @param KPTRB
2142 C>
2143 C> Error return:
2144 C> IPTR(1) = 5 - Erroneous x value in data descriptor operator
2145 C>
2146 C> @author Bill Cavanaugh @date 1988-09-01
2147  SUBROUTINE fi8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
2148  * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,KPTRB)
2149 
2150 C ..................................................
2151 C
2152 C NEW BASE TABLE B
2153 C MAY BE A COMBINATION OF MASTER TABLE B
2154 C AND ANCILLARY TABLE B
2155 C
2156  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
2157 C CHARACTER*40 ANAME1(*)
2158 C CHARACTER*24 AUNIT1(*)
2159 C ..................................................
2160  INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*)
2161  INTEGER IDENT(*),IWORK(*),KPTRB(*)
2162  INTEGER MSGA(*),MSTACK(2,MAXD)
2163  INTEGER J,JDESC
2164  INTEGER LL
2165  INTEGER LX
2166  INTEGER LY
2167 C
2168  SAVE
2169 C
2170 C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
2171  IF (lx.EQ.1) THEN
2172 C CHANGE BIT WIDTH
2173  IF (ly.EQ.0) THEN
2174 C PRINT *,' RETURN TO NORMAL WIDTH'
2175  iptr(26) = 0
2176  ELSE
2177 C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
2178  iptr(26) = ly - 128
2179  END IF
2180  ELSE IF (lx.EQ.2) THEN
2181 C CHANGE SCALE
2182  IF (ly.EQ.0) THEN
2183 C RESET TO STANDARD SCALE
2184  iptr(27) = 0
2185  ELSE
2186 C SET NEW SCALE
2187  iptr(27) = ly - 128
2188  END IF
2189  ELSE IF (lx.EQ.3) THEN
2190 C CHANGE REFERENCE VALUE
2191 C FOR EACH OF THOSE DESCRIPTORS BETWEEN
2192 C 2 03 YYY WHERE Y LT 255 AND
2193 C 2 03 255, EXTRACT THE NEW REFERENCE
2194 C VALUE (BIT WIDTH YYY) AND PLACE
2195 C IN TERTIARY TABLE B REF VAL POSITION,
2196 C SET FLAG IN SECONDARY REFVAL POSITION
2197 C THOSE DESCRIPTORS DO NOT HAVE DATA
2198 C ASSOCIATED WITH THEM, BUT ONLY
2199 C IDENTIFY THE TABLE B ENTRIES THAT
2200 C ARE GETTING NEW REFERENCE VALUES.
2201  kyyy = ly
2202  IF (kyyy.GT.0.AND.kyyy.LT.255) THEN
2203 C START CYCLING THRU DESCRIPTORS UNTIL
2204 C TERMINATE NEW REF VALS IS FOUND
2205  300 CONTINUE
2206  CALL fi8808 (iptr,iwork,lf,lx,ly,jdesc)
2207  IF (jdesc.EQ.33791) THEN
2208 C IF 2 03 255 THEN RETURN
2209  RETURN
2210  END IF
2211 C FIND MATCHING TABLE B ENTRY
2212  lj = kptrb(jdesc)
2213  IF (lj.LT.1) THEN
2214 C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR
2215  print *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND'
2216  iptr(1) = 23
2217  RETURN
2218  END IF
2219 C TURN ON SWITCH
2220  irfvl1(2,lj) = 1
2221 C INSERT NEW REFERENCE VALUE
2222  CALL gbyte (msga,irfvl1(3,lj),iptr(25),kyyy)
2223  GO TO 300
2224  ELSE IF (kyyy.EQ.0) THEN
2225 C MUST TURN OFF ALL NEW
2226 C REFERENCE VALUES
2227  DO 400 i = 1, iptr(21)
2228  irfvl1(2,i) = 0
2229  400 CONTINUE
2230  END IF
2231 C LX = 3
2232 C MUST BE CONCLUDED WITH Y=255
2233  ELSE IF (lx.EQ.4) THEN
2234 C ASSOCIATED VALUES
2235  IF (ly.EQ.0) THEN
2236  iptr(29) = 0
2237 C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29)
2238  ELSE
2239  iptr(29) = ly
2240  IF (iwork(iptr(11)).NE.7957) THEN
2241  print *,'2 04 YYY NOT FOLLOWED BY 0 31 021'
2242  iptr(1) = 11
2243  END IF
2244 C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
2245  END IF
2246  ELSE IF (lx.EQ.5) THEN
2247  mwdbit = iptr(44)
2248 C PROCESS TEXT DATA
2249  iptr(40) = ly
2250  iptr(18) = 1
2251  j = kptrb(jdesc)
2252  IF (ident(16).EQ.0) THEN
2253 C PRINT *,'FROM FI8806 - 2 05 YYY - NONCOMPRESSED TEXT',J
2254  CALL fi8804(iptr,msga,kdata,ivals,mstack,
2255  * iwide1,irfvl1,iscal1,j,ll,jdesc,maxr,maxd)
2256  ELSE
2257 C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE YYY=',LY
2258 C PRINT *,'TEXT - LOWEST = 0'
2259  iptr(25) = iptr(25) + iptr(40) * 8
2260 C GET NBINC
2261 C CALL GBYTE (MSGA,NBINC,IPTR(25),6)
2262  iptr(25) = iptr(25) + 6
2263  nbinc = iptr(40)
2264 C PRINT *,'TEXT NBINC =',NBINC,IPTR(40)
2265 C FOR NUMBER OF OBSERVATIONS
2266  iptr(31) = iptr(31) + 1
2267  kprm = iptr(31) + iptr(24)
2268  istart = kprm
2269  DO 1900 n = 1, ident(14)
2270  kprm = istart
2271  nbits = iptr(40) * 8
2272  1700 CONTINUE
2273 C PRINT *,'1700',KDATA(N,KPRM),N,KPRM,NBITS
2274  IF (nbits.GT.mwdbit) THEN
2275  CALL gbyte (msga,idata,iptr(25),mwdbit)
2276  iptr(25) = iptr(25) + mwdbit
2277  nbits = nbits - mwdbit
2278 C CONVERTS ASCII TO EBCIDIC
2279 C COMMENT OUT IF NOT IBM370 COMPUTER
2280  IF (iptr(37).EQ.0) THEN
2281  CALL w3ai39 (idata,iptr(45))
2282  END IF
2283  mstack(1,kprm) = jdesc
2284  mstack(2,kprm) = 0
2285  kdata(n,kprm) = idata
2286 C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
2287 C SET FOR NEXT PART
2288  kprm = kprm + 1
2289 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
2290 C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,
2291 C * I10)
2292  GO TO 1700
2293  ELSE IF (nbits.EQ.mwdbit) THEN
2294  CALL gbyte (msga,idata,iptr(25),mwdbit)
2295  iptr(25) = iptr(25) + mwdbit
2296  nbits = nbits - mwdbit
2297 C CONVERTS ASCII TO EBCIDIC
2298 C COMMENT OUT IF NOT IBM370 COMPUTER
2299  IF (iptr(37).EQ.0) THEN
2300  CALL w3ai39 (idata,iptr(45))
2301  END IF
2302  mstack(1,kprm) = jdesc
2303  mstack(2,kprm) = 0
2304  kdata(n,kprm) = idata
2305 C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
2306 C SET FOR NEXT PART
2307  kprm = kprm + 1
2308 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
2309  ELSE IF (nbits.GT.0) THEN
2310  CALL gbyte (msga,idata,iptr(25),nbits)
2311  iptr(25) = iptr(25) + nbits
2312  ibuf = (mwdbit - nbits) / 8
2313  IF (ibuf.GT.0) THEN
2314  DO 1750 mp = 1, ibuf
2315  idata = idata * 256 + 32
2316  1750 CONTINUE
2317  END IF
2318 C CONVERTS ASCII TO EBCIDIC
2319 C COMMENT OUT IF NOT IBM370 COMPUTER
2320  IF (iptr(37).EQ.0) THEN
2321  CALL w3ai39 (idata,iptr(45))
2322  END IF
2323  mstack(1,kprm) = jdesc
2324  mstack(2,kprm) = 0
2325  kdata(n,kprm) = idata
2326 C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
2327 C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
2328  END IF
2329 C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
2330 C1800 FORMAT (2X,I4,2X,3A4)
2331  1900 CONTINUE
2332 
2333  iptr(24) = iptr(24) + iptr(40) / 4 - 1
2334  IF (mod(iptr(40),4).NE.0) iptr(24) = iptr(24) + 1
2335  END IF
2336  iptr(18) = 0
2337 C ---------------------------
2338  ELSE IF (lx.EQ.6) THEN
2339 C SKIP NEXT DESCRIPTOR
2340 C SET TO PASS OVER DESCRIPTOR AND DATA
2341 C IF DESCRIPTOR NOT IN TABLE B
2342  iptr(36) = ly
2343 C PRINT *,'SET TO SKIP',LY,' BIT FIELD'
2344  iptr(31) = iptr(31) + 1
2345  kprm = iptr(31) + iptr(24)
2346  mstack(1,kprm) = 34304 + ly
2347  mstack(2,kprm) = 0
2348  ELSE
2349  iptr(1) = 5
2350  ENDIF
2351  RETURN
2352  END
2353 C> @brief Process queue descriptor.
2354 C> @author Bill Cavanaugh @date 1988-09-01
2355 
2356 C> Substitute descriptor queue for queue descriptor.
2357 C>
2358 C> Program history log:
2359 C> - Bill Cavanaugh 1988-09-01
2360 C> - Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors
2361 C> - Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors
2362 C> based on tests with live data.
2363 C>
2364 C> @param[in] IWORK Working descriptor list
2365 C> @param[in] IPTR See w3fi88 routine docblock
2366 C> @param[in] ITBLD+ITBLD2 Array containing descriptor queues
2367 C> @param[in] JDESC Queue descriptor to be expanded
2368 C> @param KPTRD
2369 C>
2370 C> @author Bill Cavanaugh @date 1988-09-01
2371  SUBROUTINE fi8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD)
2372 
2373 C ..................................................
2374 C
2375 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
2376 C
2377  INTEGER ITBLD2(20,*)
2378 C ..................................................
2379 C
2380 C NEW BASE TABLE D
2381 C
2382  INTEGER ITBLD(20,*)
2383 C ..................................................
2384 C
2385  INTEGER IPTR(*),JDESC,KPTRD(*)
2386  INTEGER IWORK(*),IHOLD(15000)
2387 C
2388  SAVE
2389 C PRINT *,' FI8807 F3 ENTRY',IPTR(11),IPTR(12)
2390 C SET FOR BINARY SEARCH IN TABLE D
2391  jlo = 1
2392  jhi = iptr(20)
2393 C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC,IPTR(11),IPTR(12)
2394 C
2395  jmid = kptrd(mod(jdesc,16384))
2396  IF (jmid.LT.0) THEN
2397  iptr(1) = 4
2398  RETURN
2399  END IF
2400 C HAVE TABLE D MATCH
2401 C PRINT *,'D ',(ITBLD(LL,JMID),LL=1,20)
2402 C PRINT *,'TABLE D TO IHOLD'
2403  ik = 0
2404  jk = 0
2405  DO 200 ki = 2, 20
2406  IF (itbld(ki,jmid).NE.0) THEN
2407  ik = ik + 1
2408  ihold(ik) = itbld(ki,jmid)
2409 C PRINT *,IK,IHOLD(IK)
2410  ELSE
2411  GO TO 300
2412  END IF
2413  200 CONTINUE
2414  300 CONTINUE
2415  kk = iptr(11)
2416  IF (kk.GT.iptr(12)) THEN
2417 C NOTHING MORE TO APPEND
2418 C PRINT *,'NOTHING MORE TO APPEND'
2419  ELSE
2420 C APPEND TRAILING IWORK TO IHOLD
2421 C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12)
2422  DO 500 i = kk, iptr(12)
2423  ik = ik + 1
2424  ihold(ik) = iwork(i)
2425  500 CONTINUE
2426  END IF
2427 C RESET IHOLD TO IWORK
2428 C PRINT *,' RESET IWORK STACK'
2429  kk = iptr(11) - 2
2430  DO 1000 i = 1, ik
2431  kk = kk + 1
2432  iwork(kk) = ihold(i)
2433  1000 CONTINUE
2434  iptr(12) = kk
2435 C PRINT *,' FI8807 F3 EXIT ',IPTR(11),IPTR(12)
2436 C DO 2000 I = 1, IPTR(12)
2437 C PRINT *,'EXIT IWORK',I,IWORK(I)
2438 C2000 CONTINUE
2439 C RESET POINTERS
2440  iptr(11) = iptr(11) - 1
2441  RETURN
2442  END
2443 C> @brief
2444 C> @author Bill Cavanaugh @date 1988-09-01
2445 
2446 C>
2447 C> Program history log:
2448 C> - Bill Cavanaugh 1988-09-01
2449 C>
2450 C> @param[inout] IPTR See w3fi88 routine docblock
2451 C> @param[in] IWORK Working descriptor list
2452 C> @param LF
2453 C> @param LX
2454 C> @param LY
2455 C> @param JDESC
2456 C>
2457 C> @author Bill Cavanaugh @date 1988-09-01
2458  SUBROUTINE fi8808(IPTR,IWORK,LF,LX,LY,JDESC)
2459 
2460  INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC
2461  SAVE
2462 C
2463 C PRINT *,' FI8808 NEW DESCRIPTOR PICKUP'
2464  JDESC = iwork(iptr(11))
2465  ly = mod(jdesc,256)
2466  iptr(34) = ly
2467  lx = mod((jdesc/256),64)
2468  iptr(33) = lx
2469  lf = jdesc / 16384
2470  iptr(32) = lf
2471 C PRINT *,' TEST DESCRIPTOR',LF,LX,LY,' AT',IPTR(11)
2472  iptr(11) = iptr(11) + 1
2473  RETURN
2474  END
2475 C> @brief Reformat profiler w hgt increments
2476 C> @author Bill Cavanaugh @date 1990-02-14
2477 
2478 C> Reformat decoded profiler data to show heights instead of
2479 C> height increments.
2480 C>
2481 C> Program history log:
2482 C> - Bill Cavanaugh 1990-02-14
2483 C>
2484 C> @param[in] IDENT Array contains message information extracted from BUFR message
2485 C> - IDENT(1) - Edition number (byte 4, section 1)
2486 C> - IDENT(2) - Originating center (bytes 5-6, section 1)
2487 C> - IDENT(3) - Update sequence (byte 7, section 1)
2488 C> - IDENT(4) - (byte 8, section 1)
2489 C> - IDENT(5) - Bufr message type (byte 9, section 1)
2490 C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
2491 C> - IDENT(7) - (bytes 11-12, section 1)
2492 C> - IDENT(8) - Year of century (byte 13, section 1)
2493 C> - IDENT(9) - Month of year (byte 14, section 1)
2494 C> - IDENT(10) - Day of month (byte 15, section 1)
2495 C> - IDENT(11) - Hour of day (byte 16, section 1)
2496 C> - IDENT(12) - Minute of hour (byte 17, section 1)
2497 C> - IDENT(13) - Rsvd by adp centers (byte 18, section 1)
2498 C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
2499 C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
2500 C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
2501 C> @param[in] MSTACK Working descriptor list and scaling factor
2502 C> @param[in] KDATA Array containing decoded reports from bufr message.
2503 C> KDATA(Report number,parameter number)
2504 C> (report number limited to value of input argument
2505 C> maxr and parameter number limited to value of input
2506 C> argument maxd)
2507 C> @param[in] IPTR See w3fi88
2508 C> @param[in] MAXR Maximum number of reports/subsets that may be
2509 C> contained in a bufr message
2510 C> @param[in] MAXD Maximum number of descriptor combinations that
2511 C> may be processed; upper air data and some satellite
2512 C> data require a value for maxd of 1700, but for most
2513 C> other data a value for maxd of 500 will suffice
2514 C>
2515 C> @author Bill Cavanaugh @date 1990-02-14
2516  SUBROUTINE fi8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
2517 
2518 C ----------------------------------------------------------------
2519 C
2520  INTEGER ISW
2521  INTEGER IDENT(*),KDATA(MAXR,MAXD)
2522  INTEGER MSTACK(2,MAXD),IPTR(*)
2523  INTEGER KPROFL(1700)
2524  INTEGER KPROF2(1700)
2525  INTEGER KSET2(1700)
2526 C
2527 C ----------------------------------------------------------
2528  SAVE
2529 C PRINT *,'FI8809'
2530 C LOOP FOR NUMBER OF SUBSETS/REPORTS
2531  DO 3000 i = 1, ident(14)
2532 C INIT FOR DATA INPUT ARRAY
2533  mk = 1
2534 C INIT FOR DESC OUTPUT ARRAY
2535  jk = 0
2536 C LOCATION
2537  isw = 0
2538  DO 200 j = 1, 3
2539 C LATITUDE
2540  IF (mstack(1,mk).EQ.1282) THEN
2541  isw = isw + 1
2542  GO TO 100
2543 C LONGITUDE
2544  ELSE IF (mstack(1,mk).EQ.1538) THEN
2545  isw = isw + 2
2546  GO TO 100
2547 C HEIGHT ABOVE SEA LEVEL
2548  ELSE IF (mstack(1,mk).EQ.1793) THEN
2549  ihgt = kdata(i,mk)
2550  isw = isw + 4
2551  GO TO 100
2552  END IF
2553  GO TO 200
2554  100 CONTINUE
2555  jk = jk + 1
2556 C SAVE DESCRIPTOR
2557  kprofl(jk) = mstack(1,mk)
2558 C SAVE SCALE
2559  kprof2(jk) = mstack(2,mk)
2560 C SAVE DATA
2561  kset2(jk) = kdata(i,mk)
2562  mk = mk + 1
2563  200 CONTINUE
2564  IF (isw.NE.7) THEN
2565  print *,'LOCATION ERROR PROCESSING PROFILER'
2566  iptr(1) = 200
2567  RETURN
2568  END IF
2569 C TIME
2570  isw = 0
2571  DO 400 j = 1, 7
2572 C YEAR
2573  IF (mstack(1,mk).EQ.1025) THEN
2574  isw = isw + 1
2575  GO TO 300
2576 C MONTH
2577  ELSE IF (mstack(1,mk).EQ.1026) THEN
2578  isw = isw + 2
2579  GO TO 300
2580 C DAY
2581  ELSE IF (mstack(1,mk).EQ.1027) THEN
2582  isw = isw + 4
2583  GO TO 300
2584 C HOUR
2585  ELSE IF (mstack(1,mk).EQ.1028) THEN
2586  isw = isw + 8
2587  GO TO 300
2588 C MINUTE
2589  ELSE IF (mstack(1,mk).EQ.1029) THEN
2590  isw = isw + 16
2591  GO TO 300
2592 C TIME SIGNIFICANCE
2593  ELSE IF (mstack(1,mk).EQ.2069) THEN
2594  isw = isw + 32
2595  GO TO 300
2596  ELSE IF (mstack(1,mk).EQ.1049) THEN
2597  isw = isw + 64
2598  GO TO 300
2599  END IF
2600  GO TO 400
2601  300 CONTINUE
2602  jk = jk + 1
2603 C SAVE DESCRIPTOR
2604  kprofl(jk) = mstack(1,mk)
2605 C SAVE SCALE
2606  kprof2(jk) = mstack(2,mk)
2607 C SAVE DATA
2608  kset2(jk) = kdata(i,mk)
2609  mk = mk + 1
2610  400 CONTINUE
2611  IF (isw.NE.127) THEN
2612  print *,'TIME ERROR PROCESSING PROFILER',isw
2613  iptr(1) = 201
2614  RETURN
2615  END IF
2616 C SURFACE DATA
2617  krg = 0
2618  isw = 0
2619  DO 600 j = 1, 10
2620 C WIND SPEED
2621  IF (mstack(1,mk).EQ.2818) THEN
2622  isw = isw + 1
2623  GO TO 500
2624 C WIND DIRECTION
2625  ELSE IF (mstack(1,mk).EQ.2817) THEN
2626  isw = isw + 2
2627  GO TO 500
2628 C PRESS REDUCED TO MSL
2629  ELSE IF (mstack(1,mk).EQ.2611) THEN
2630  isw = isw + 4
2631  GO TO 500
2632 C TEMPERATURE
2633  ELSE IF (mstack(1,mk).EQ.3073) THEN
2634  isw = isw + 8
2635  GO TO 500
2636 C RAINFALL RATE
2637  ELSE IF (mstack(1,mk).EQ.3342) THEN
2638  isw = isw + 16
2639  GO TO 500
2640 C RELATIVE HUMIDITY
2641  ELSE IF (mstack(1,mk).EQ.3331) THEN
2642  isw = isw + 32
2643  GO TO 500
2644 C 1ST RANGE GATE OFFSET
2645  ELSE IF (mstack(1,mk).EQ.1982.OR.
2646  * mstack(1,mk).EQ.1983) THEN
2647 C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
2648 C VALUE FOR LATER USE
2649  IF (mstack(1,mk).EQ.1983) THEN
2650  ihgt = kdata(i,mk)
2651  mk = mk + 1
2652  krg = 1
2653  ELSE
2654  IF (krg.EQ.0) THEN
2655  incrht = kdata(i,mk)
2656  mk = mk + 1
2657  krg = 1
2658 C PRINT *,'INITIAL INCR =',INCRHT
2659  ELSE
2660  lhgt = 500 + ihgt - kdata(i,mk)
2661  isw = isw + 64
2662 C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
2663  END IF
2664  END IF
2665 C MODE #1
2666  ELSE IF (mstack(1,mk).EQ.8128) THEN
2667  isw = isw + 128
2668  GO TO 500
2669 C MODE #2
2670  ELSE IF (mstack(1,mk).EQ.8129) THEN
2671  isw = isw + 256
2672  GO TO 500
2673  END IF
2674  GO TO 600
2675  500 CONTINUE
2676 C SAVE DESCRIPTOR
2677  jk = jk + 1
2678  kprofl(jk) = mstack(1,mk)
2679 C SAVE SCALE
2680  kprof2(jk) = mstack(2,mk)
2681 C SAVE DATA
2682  kset2(jk) = kdata(i,mk)
2683 C IF (I.EQ.1) THEN
2684 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
2685 C END IF
2686  mk = mk + 1
2687  600 CONTINUE
2688  IF (isw.NE.511) THEN
2689  print *,'SURFACE ERROR PROCESSING PROFILER',isw
2690  iptr(1) = 202
2691  RETURN
2692  END IF
2693 C 43 LEVELS
2694  DO 2000 l = 1, 43
2695  2020 CONTINUE
2696  isw = 0
2697 C HEIGHT INCREMENT
2698  IF (mstack(1,mk).EQ.1982) THEN
2699 C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK)
2700  incrht = kdata(i,mk)
2701  mk = mk + 1
2702  IF (lhgt.LT.(9250+ihgt)) THEN
2703  lhgt = ihgt + 500 - incrht
2704  ELSE
2705  lhgt = ihgt + 9250 - incrht
2706  END IF
2707  END IF
2708 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
2709 C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
2710  lhgt = lhgt + incrht
2711 C PRINT *,'LEVEL ',L,LHGT
2712  IF (l.EQ.37) THEN
2713  lhgt = lhgt + incrht
2714  END IF
2715  jk = jk + 1
2716 C SAVE DESCRIPTOR
2717  kprofl(jk) = 1798
2718 C SAVE SCALE
2719  kprof2(jk) = 0
2720 C SAVE DATA
2721  kset2(jk) = lhgt
2722 C IF (I.EQ.10) THEN
2723 C PRINT *,' '
2724 C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
2725 C END IF
2726  isw = 0
2727  DO 800 j = 1, 9
2728  750 CONTINUE
2729  IF (mstack(1,mk).EQ.1982) THEN
2730  GO TO 2020
2731 C U VECTOR VALUE
2732  ELSE IF (mstack(1,mk).EQ.3008) THEN
2733  isw = isw + 1
2734  IF (kdata(i,mk).GE.2047) THEN
2735  vectu = 32767
2736  ELSE
2737  vectu = kdata(i,mk)
2738  END IF
2739  mk = mk + 1
2740  GO TO 800
2741 C V VECTOR VALUE
2742  ELSE IF (mstack(1,mk).EQ.3009) THEN
2743  isw = isw + 2
2744  IF (kdata(i,mk).GE.2047) THEN
2745  vectv = 32767
2746  ELSE
2747  vectv = kdata(i,mk)
2748  END IF
2749  mk = mk + 1
2750 C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
2751 C DESCRIPTORS AND DATA
2752  IF (iand(isw,1).NE.0) THEN
2753  IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
2754 C SAVE DD DESCRIPTOR
2755  jk = jk + 1
2756  kprofl(jk) = 2817
2757 C SAVE SCALE
2758  kprof2(jk) = 0
2759 C SAVE DD DATA
2760  kset2(jk) = 32767
2761 C SAVE FFF DESCRIPTOR
2762  jk = jk + 1
2763  kprofl(jk) = 2818
2764 C SAVE SCALE
2765  kprof2(jk) = 1
2766 C SAVE FFF DATA
2767  kset2(jk) = 32767
2768  ELSE
2769 C GENERATE DDFFF
2770  CALL w3fc05 (vectu,vectv,dir,spd)
2771  ndir = dir
2772  spd = spd
2773  nspd = spd
2774 C PRINT *,' ',NDIR,NSPD
2775 C SAVE DD DESCRIPTOR
2776  jk = jk + 1
2777  kprofl(jk) = 2817
2778 C SAVE SCALE
2779  kprof2(jk) = 0
2780 C SAVE DD DATA
2781  kset2(jk) = dir
2782 C IF (I.EQ.1) THEN
2783 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
2784 C END IF
2785 C SAVE FFF DESCRIPTOR
2786  jk = jk + 1
2787  kprofl(jk) = 2818
2788 C SAVE SCALE
2789  kprof2(jk) = 1
2790 C SAVE FFF DATA
2791  kset2(jk) = spd
2792 C IF (I.EQ.1) THEN
2793 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
2794 C END IF
2795  END IF
2796  END IF
2797  GO TO 800
2798 C W VECTOR VALUE
2799  ELSE IF (mstack(1,mk).EQ.3010) THEN
2800  isw = isw + 4
2801  GO TO 700
2802 C Q/C TEST RESULTS
2803  ELSE IF (mstack(1,mk).EQ.8130) THEN
2804  isw = isw + 8
2805  GO TO 700
2806 C U,V QUALITY IND
2807  ELSE IF(iand(isw,16).EQ.0.AND.mstack(1,mk).EQ.2070) THEN
2808  isw = isw + 16
2809  GO TO 700
2810 C W QUALITY IND
2811  ELSE IF(iand(isw,32).EQ.0.AND.mstack(1,mk).EQ.2070) THEN
2812  isw = isw + 32
2813  GO TO 700
2814 C SPECTRAL PEAK POWER
2815  ELSE IF (mstack(1,mk).EQ.5568) THEN
2816  isw = isw + 64
2817  GO TO 700
2818 C U,V VARIABILITY
2819  ELSE IF (mstack(1,mk).EQ.3011) THEN
2820  isw = isw + 128
2821  GO TO 700
2822 C W VARIABILITY
2823  ELSE IF (mstack(1,mk).EQ.3013) THEN
2824  isw = isw + 256
2825  GO TO 700
2826  ELSE IF ((mstack(1,mk)/16384).NE.0) THEN
2827  mk = mk + 1
2828  GO TO 750
2829  END IF
2830  GO TO 800
2831  700 CONTINUE
2832  jk = jk + 1
2833 C SAVE DESCRIPTOR
2834  kprofl(jk) = mstack(1,mk)
2835 C SAVE SCALE
2836  kprof2(jk) = mstack(2,mk)
2837 C SAVE DATA
2838  kset2(jk) = kdata(i,mk)
2839  mk = mk + 1
2840 C IF (I.EQ.1) THEN
2841 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
2842 C END IF
2843  800 CONTINUE
2844  IF (isw.NE.511) THEN
2845  print *,'LEVEL ERROR PROCESSING PROFILER',isw
2846  iptr(1) = 203
2847  RETURN
2848  END IF
2849  2000 CONTINUE
2850 C MOVE DATA BACK INTO KDATA ARRAY
2851  DO 4000 ll = 1, jk
2852  kdata(i,ll) = kset2(ll)
2853  4000 CONTINUE
2854  3000 CONTINUE
2855 C PRINT *,'REBUILT ARRAY'
2856  DO 5000 ll = 1, jk
2857 C DESCRIPTOR
2858  mstack(1,ll) = kprofl(ll)
2859 C SCALE
2860  mstack(2,ll) = kprof2(ll)
2861 C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
2862  5000 CONTINUE
2863 C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
2864  iptr(31) = jk
2865  RETURN
2866  END
2867 C> @brief Reformat profiler edition 2 data
2868 C> @author Bill Cavanaugh @date 1993-01-27
2869 
2870 C> Reformat profiler data in edition 2
2871 C>
2872 C> Program history log:
2873 C> - Bill Cavanaugh 1993-01-27
2874 C> - Dennis Keyser 1995-06-07 A correction was made to prevent
2875 C> unnecessary looping when all requested
2876 C> descriptors are missing.
2877 C>
2878 C> @param[in] IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM BUFR MESSAGE -
2879 C> - IDENT(1) - Edition number (byte 4, section 1)
2880 C> - IDENT(2) - Originating center (bytes 5-6, section 1)
2881 C> - IDENT(3) - Update sequence (byte 7, section 1)
2882 C> - IDENT(4) - (byte 8, section 1)
2883 C> - IDENT(5) - Bufr message type (byte 9, section 1)
2884 C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
2885 C> - IDENT(7) - (bytes 11-12, section 1)
2886 C> - IDENT(8) - Year of century (byte 13, section 1)
2887 C> - IDENT(9) - Month of year (byte 14, section 1)
2888 C> - IDENT(10) - Day of month (byte 15, section 1)
2889 C> - IDENT(11) - Hour of day (byte 16, section 1)
2890 C> - IDENT(12) - Minute of hour (byte 17, section 1)
2891 C> - IDENT(13) - Rsvd by adp centers(byte 18, section 1)
2892 C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
2893 C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
2894 C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
2895 C> @param[in] MSTACK Working descriptor list and scaling factor
2896 C> @param[in] KDATA Array containing decoded reports from bufr message.
2897 C> KDATA(Report number,parameter number)
2898 C> (report number limited to value of input argument
2899 C> maxr and parameter number limited to value of input
2900 C> argument maxd)
2901 C> @param[in] IPTR See w3fi88
2902 C> @param[in] MAXR Maximum number of reports/subsets that may be
2903 C> contained in a bufr message
2904 C> @param[in] MAXD Maximum number of descriptor combinations that
2905 C> may be processed; upper air data and some satellite
2906 C> data require a value for maxd of 1700, but for most
2907 C> other data a value for maxd of 500 will suffice
2908 C>
2909 C> @author Bill Cavanaugh @date 1993-01-27
2910  SUBROUTINE fi8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
2911 
2912  INTEGER ISW
2913  INTEGER IDENT(*),KDATA(MAXR,MAXD)
2914  INTEGER MSTACK(2,MAXD),IPTR(*)
2915  INTEGER KPROFL(1700)
2916  INTEGER KPROF2(1700)
2917  INTEGER KSET2(1700)
2918 C
2919  SAVE
2920 C LOOP FOR NUMBER OF SUBSETS
2921  DO 3000 i = 1, ident(14)
2922  mk = 1
2923  jk = 0
2924  isw = 0
2925 C PRINT *,'IDENTIFICATION'
2926  DO 200 j = 1, 5
2927  IF (mstack(1,mk).EQ.257) THEN
2928 C BLOCK NUMBER
2929  isw = isw + 1
2930  ELSE IF (mstack(1,mk).EQ.258) THEN
2931 C STATION NUMBER
2932  isw = isw + 2
2933  ELSE IF (mstack(1,mk).EQ.1282) THEN
2934 C LATITUDE
2935  isw = isw + 4
2936  ELSE IF (mstack(1,mk).EQ.1538) THEN
2937 C LONGITUDE
2938  isw = isw + 8
2939  ELSE IF (mstack(1,mk).EQ.1793) THEN
2940 C HEIGHT OF STATION
2941  isw = isw + 16
2942  ihgt = kdata(i,mk)
2943  ELSE
2944  mk = mk + 1
2945  GO TO 200
2946  END IF
2947  jk = jk + 1
2948  kprofl(jk) = mstack(1,mk)
2949  kprof2(jk) = mstack(2,mk)
2950  kset2(jk) = kdata(i,mk)
2951 C PRINT *,JK,KPROFL(JK),KSET2(JK)
2952  mk = mk + 1
2953  200 CONTINUE
2954 C PRINT *,'LOCATION ',ISW
2955  IF (isw.NE.31) THEN
2956  print *,'LOCATION ERROR PROCESSING PROFILER'
2957  iptr(10) = 200
2958  RETURN
2959  END IF
2960 C PROCESS TIME ELEMENTS
2961  isw = 0
2962  DO 400 j = 1, 7
2963  IF (mstack(1,mk).EQ.1025) THEN
2964 C YEAR
2965  isw = isw + 1
2966  ELSE IF (mstack(1,mk).EQ.1026) THEN
2967 C MONTH
2968  isw = isw + 2
2969  ELSE IF (mstack(1,mk).EQ.1027) THEN
2970 C DAY
2971  isw = isw + 4
2972  ELSE IF (mstack(1,mk).EQ.1028) THEN
2973 C HOUR
2974  isw = isw + 8
2975  ELSE IF (mstack(1,mk).EQ.1029) THEN
2976 C MINUTE
2977  isw = isw + 16
2978  ELSE IF (mstack(1,mk).EQ.2069) THEN
2979 C TIME SIGNIFICANCE
2980  isw = isw + 32
2981  ELSE IF (mstack(1,mk).EQ.1049) THEN
2982 C TIME DISPLACEMENT
2983  isw = isw + 64
2984  ELSE
2985  mk = mk + 1
2986  GO TO 400
2987  END IF
2988  jk = jk + 1
2989  kprofl(jk) = mstack(1,mk)
2990  kprof2(jk) = mstack(2,mk)
2991  kset2(jk) = kdata(i,mk)
2992 C PRINT *,JK,KPROFL(JK),KSET2(JK)
2993  mk = mk + 1
2994  400 CONTINUE
2995 C PRINT *,'TIME ',ISW
2996  IF (isw.NE.127) THEN
2997  print *,'TIME ERROR PROCESSING PROFILER'
2998  iptr(1) = 201
2999  RETURN
3000  END IF
3001 C SURFACE DATA
3002  isw = 0
3003 C PRINT *,'SURFACE'
3004  DO 600 k = 1, 8
3005 C PRINT *,MK,MSTACK(1,MK),JK,ISW
3006  IF (mstack(1,mk).EQ.2817) THEN
3007  isw = isw + 1
3008  ELSE IF (mstack(1,mk).EQ.2818) THEN
3009  isw = isw + 2
3010  ELSE IF (mstack(1,mk).EQ.2611) THEN
3011  isw = isw + 4
3012  ELSE IF (mstack(1,mk).EQ.3073) THEN
3013  isw = isw + 8
3014  ELSE IF (mstack(1,mk).EQ.3342) THEN
3015  isw = isw + 16
3016  ELSE IF (mstack(1,mk).EQ.3331) THEN
3017  isw = isw + 32
3018  ELSE IF (mstack(1,mk).EQ.1797) THEN
3019  incrht = kdata(i,mk)
3020  isw = isw + 64
3021 C PRINT *,'INITIAL INCREMENT = ',INCRHT
3022  mk = mk + 1
3023 C PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW
3024  GO TO 600
3025  ELSE IF (mstack(1,mk).EQ.6433) THEN
3026  isw = isw + 128
3027  END IF
3028  jk = jk + 1
3029  kprofl(jk) = mstack(1,mk)
3030  kprof2(jk) = mstack(2,mk)
3031  kset2(jk) = kdata(i,mk)
3032 C PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW
3033  mk = mk + 1
3034  600 CONTINUE
3035  IF (isw.NE.255) THEN
3036  print *,'ERROR PROCESSING PROFILER',isw
3037  iptr(1) = 204
3038  RETURN
3039  END IF
3040  IF (mstack(1,mk).NE.1797) THEN
3041  print *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER'
3042  iptr(1) = 205
3043  RETURN
3044  END IF
3045 C MUST SAVE THIS HEIGHT VALUE
3046  lhgt = 500 + ihgt - kdata(i,mk)
3047 C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT
3048  mk = mk + 1
3049  IF (mstack(1,mk).GE.16384) THEN
3050  mk = mk + 1
3051  END IF
3052 C PROCESS LEVEL DATA
3053 C PRINT *,'LEVEL DATA'
3054  DO 2000 l = 1, 43
3055  2020 CONTINUE
3056 C PRINT *,'DESC',MK,MSTACK(1,MK),JK
3057  isw = 0
3058 C HEIGHT INCREMENT
3059  IF (mstack(1,mk).EQ.1797) THEN
3060  incrht = kdata(i,mk)
3061 C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT
3062  mk = mk + 1
3063 C IF (LHGT.LT.(9250+IHGT)) THEN
3064 C LHGT = IHGT + 500 - INCRHT
3065 C ELSE
3066 C LHGT = IHGT + 9250 -INCRHT
3067 C END IF
3068  END IF
3069 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
3070 C AT THIS POINT
3071  lhgt = lhgt + incrht
3072 C PRINT *,'LEVEL ',L,LHGT
3073 C IF (L.EQ.37) THEN
3074 C LHGT = LHGT + INCRHT
3075 C END IF
3076  jk = jk + 1
3077 C SAVE DESCRIPTOR
3078  kprofl(jk) = 1798
3079 C SAVE SCALE
3080  kprof2(jk) = 0
3081 C SAVE DATA
3082  kset2(jk) = lhgt
3083 C PRINT *,KPROFL(JK),KSET2(JK),JK
3084  isw = 0
3085  icon = 1
3086  DO 800 j = 1, 10
3087 750 CONTINUE
3088  IF (mstack(1,mk).EQ.1797) THEN
3089  GO TO 2020
3090  ELSE IF (mstack(1,mk).EQ.6432) THEN
3091 C HI/LO MODE
3092  isw = isw + 1
3093  ELSE IF (mstack(1,mk).EQ.6434) THEN
3094 C Q/C TEST
3095  isw = isw + 2
3096  ELSE IF (mstack(1,mk).EQ.2070) THEN
3097  IF (icon.EQ.1) THEN
3098 C FIRST PASS - U,V CONSENSUS
3099  isw = isw + 4
3100  icon = icon + 1
3101  ELSE
3102 C SECOND PASS - W CONSENSUS
3103  isw = isw + 64
3104  END IF
3105  ELSE IF (mstack(1,mk).EQ.2819) THEN
3106 C U VECTOR VALUE
3107  isw = isw + 8
3108  IF (kdata(i,mk).GE.2047) THEN
3109  vectu = 32767
3110  ELSE
3111  vectu = kdata(i,mk)
3112  END IF
3113  mk = mk + 1
3114  GO TO 800
3115  ELSE IF (mstack(1,mk).EQ.2820) THEN
3116 C V VECTOR VALUE
3117  isw = isw + 16
3118  IF (kdata(i,mk).GE.2047) THEN
3119  vectv = 32767
3120  ELSE
3121  vectv = kdata(i,mk)
3122  END IF
3123  IF (iand(isw,1).NE.0) THEN
3124  IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
3125 C SAVE DD DESCRIPTOR
3126  jk = jk + 1
3127  kprofl(jk) = 2817
3128  kprof2(jk) = 0
3129  kset2(jk) = 32767
3130 C SAVE FFF DESCRIPTOR
3131  jk = jk + 1
3132  kprofl(jk) = 2818
3133  kprof2(jk) = 1
3134  kset2(jk) = 32767
3135  ELSE
3136  CALL w3fc05 (vectu,vectv,dir,spd)
3137  ndir = dir
3138  spd = spd
3139  nspd = spd
3140 C PRINT *,' ',NDIR,NSPD
3141 C SAVE DD DESCRIPTOR
3142  jk = jk + 1
3143  kprofl(jk) = 2817
3144  kprof2(jk) = 0
3145  kset2(jk) = ndir
3146 C IF (I.EQ.1) THEN
3147 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
3148 C ENDIF
3149 C SAVE FFF DESCRIPTOR
3150  jk = jk + 1
3151  kprofl(jk) = 2818
3152  kprof2(jk) = 1
3153  kset2(jk) = nspd
3154 C IF (I.EQ.1) THEN
3155 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
3156 C ENDIF
3157  END IF
3158  mk = mk + 1
3159  GO TO 800
3160  END IF
3161  ELSE IF (mstack(1,mk).EQ.2866) THEN
3162 C SPEED STD DEVIATION
3163  isw = isw + 32
3164 C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568
3165  ELSE IF (mstack(1,mk).EQ.5568) THEN
3166 C SIGNAL POWER
3167  isw = isw + 128
3168  ELSE IF (mstack(1,mk).EQ.2822) THEN
3169 C W COMPONENT
3170  isw = isw + 256
3171  ELSE IF (mstack(1,mk).EQ.2867) THEN
3172 C VERT STD DEVIATION
3173  isw = isw + 512
3174 CVVVVVCHANGE#1 FIX BY KEYSER -- 12/06/1994
3175 C NOTE: THIS FIX PREVENTS UNNECESSARY LOOPING WHEN ALL REQ. DESCR.
3176 C ARE MISSING. WOULD GO INTO INFINITE LOOP EXCEPT EVENTUALLY
3177 C MSTACK ARRAY SIZE IS EXCEEDED AND GET FORTRAN ERROR INTERRUPT
3178 CDAK ELSE
3179  ELSE IF ((mstack(1,mk)/16384).NE.0) THEN
3180 CAAAAACHANGE#1 FIX BY KEYSER -- 12/06/1994
3181  mk = mk + 1
3182  GO TO 750
3183  END IF
3184  jk = jk + 1
3185 C SAVE DESCRIPTOR
3186  kprofl(jk) = mstack(1,mk)
3187 C SAVE SCALE
3188  kprof2(jk) = mstack(2,mk)
3189 C SAVE DATA
3190  kset2(jk) = kdata(i,mk)
3191  mk = mk + 1
3192 C PRINT *,L,'TEST ',JK,KPROFL(JK),KSET2(JK)
3193  800 CONTINUE
3194  IF (isw.NE.1023) THEN
3195  print *,'LEVEL ERROR PROCESSING PROFILER',isw
3196  iptr(1) = 202
3197  RETURN
3198  END IF
3199  2000 CONTINUE
3200 C MOVE DATA BACK INTO KDATA ARRAY
3201  DO 5000 ll = 1, jk
3202 C DATA
3203  kdata(i,ll) = kset2(ll)
3204  5000 CONTINUE
3205  3000 CONTINUE
3206  DO 5005 ll = 1, jk
3207 C DESCRIPTOR
3208  mstack(1,ll) = kprofl(ll)
3209 C SCALE
3210  mstack(2,ll) = kprof2(ll)
3211 C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP
3212 C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4)
3213  5005 CONTINUE
3214  iptr(31) = jk
3215  RETURN
3216  END
3217 C> @brief Expand data/descriptor replication
3218 C> @author Bill Cavanaugh @date 1993-05-12
3219 
3220 C> Expand data and descriptor strings
3221 C>
3222 C> Program history log:
3223 C> - Bill Cavanaugh 1993-05-12
3224 C>
3225 C> @param[in] IPTR See w3fi88 routine docblock
3226 C> @param[in] IDENT See w3fi88 routine docblock
3227 C> @param[in] MAXR Maximum number of reports/subsets that may be
3228 C> contained in a bufr message
3229 C> @param[in] MAXD Maximum number of descriptor combinations that
3230 C> may be processed; upper air data and some satellite
3231 C> data require a value for maxd of 1700, but for most
3232 C> other data a value for maxd of 500 will suffice
3233 C> @param[inout] KDATA Array containing decoded reports from bufr message.
3234 C> kdata(report number,parameter number)
3235 C> (report number limited to value of input argument
3236 C> maxr and parameter number limited to value of input
3237 C> argument maxd)
3238 C> @param[inout] MSTACK List of descriptors and scale values
3239 C> @param KNR
3240 C> @param LDATA
3241 C> @param LSTACK
3242 C>
3243 C> Error return:
3244 C> - IPTR(1)
3245 C>
3246 C> @author Bill Cavanaugh @date 1993-05-12
3247  SUBROUTINE fi8811(IPTR,IDENT,MSTACK,KDATA,KNR,
3248  * LDATA,LSTACK,MAXD,MAXR)
3249 
3250  INTEGER IPTR(*)
3251  INTEGER KNR(MAXR)
3252  INTEGER KDATA(MAXR,MAXD),LDATA(MAXD)
3253  INTEGER MSTACK(2,MAXD),LSTACK(2,MAXD)
3254  INTEGER IDENT(*)
3255 C
3256  SAVE
3257 C
3258 C PRINT *,' DATA/DESCRIPTOR REPLICATION '
3259  DO 1000 i = 1, knr(1)
3260 C IF NOT REPLICATION DESCRIPTOR
3261  IF ((mstack(1,i)/16384).NE.1) THEN
3262  GO TO 1000
3263  END IF
3264 C IF DELAYED REPLICATION DESCRIPTOR
3265  IF (mod(mstack(1,i),256).EQ.0) THEN
3266 C SAVE KX VALUE (NR DESC'S TO REPLICATE)
3267  kx = mod((mstack(1,i)/256),64)
3268 C IF NEXT DESC IS NOT 7947 OR 7948
3269 C (I.E., 0 31 011 OR 0 31 012)
3270  IF (mstack(1,i+1).NE.7947.AND.mstack(1,i+1).NE.7948) THEN
3271 C SKIP IT
3272  GO TO 1000
3273  END IF
3274 C GET NR REPS FROM KDATA
3275  nrreps = kdata(1,i+1)
3276  last = i + 1 + kx
3277 C SAVE OFF TRAILING DESCS AND DATA
3278  ktrail = knr(1) - i - 1 - kx
3279  DO 100 l = 1, ktrail
3280  nx = i + l + kx + 1
3281  ldata(l) = kdata(1,nx)
3282  lstack(1,l) = mstack(1,nx)
3283  lstack(2,l) = mstack(2,nx)
3284  100 CONTINUE
3285 C INSERT FX DESCS/DATA NR REPS TIMES
3286  last = i + 1
3287  DO 400 j = 1, nrreps
3288  nx = i + 2
3289  DO 300 k = 1, kx
3290  last = last + 1
3291  kdata(1,last) = kdata(1,nx)
3292  mstack(1,last) = mstack(1,nx)
3293  mstack(2,last) = mstack(2,nx)
3294  nx = nx + 1
3295  300 CONTINUE
3296 
3297  400 CONTINUE
3298 C RESTORE TRAILING DATA/DESCS
3299  DO 500 l = 1, ktrail
3300  last = last + 1
3301  kdata(1,last) = ldata(l)
3302  mstack(1,last) = lstack(1,l)
3303  mstack(2,last) = lstack(2,l)
3304  500 CONTINUE
3305 C RESET KNR(1)
3306  knr(1) = last
3307  END IF
3308  1000 CONTINUE
3309  RETURN
3310  END
3311  SUBROUTINE fi8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
3312  * IRF1SW,NEWREF,ITBLD,ITBLD2,
3313  * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
3314  * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
3315 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
3316 C . . . .
3317 C SUBPROGRAM: FI8812 BUILD TABLE B SUBSET BASED ON BUFR SEC 3
3318 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-23
3319 C
3320 C ABSTRACT: BUILD A SUBSET OF TABLE B ENTRIES THAT CORRESPOND TO
3321 C THE DESCRIPTORS NEEDED FOR THIS MESSAGE
3322 C
3323 C PROGRAM HISTORY LOG:
3324 C 93-05-12 CAVANAUGH
3325 C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
3326 C
3327 C USAGE: CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
3328 C * IRF1SW,NEWREF,ITBLD,ITBLD2,
3329 C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
3330 C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
3331 C INPUT ARGUMENT LIST:
3332 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
3333 C IDENT - SEE W3FI88 ROUTINE DOCBLOCK
3334 C ISTACK - LIST OF DESCRIPTORS AND SCALE VALUES
3335 C IUNITB -
3336 C IUNITD -
3337 C ISTACK -
3338 C NRDESC -
3339 C KFXY2 -
3340 C ANAME2 -
3341 C AUNIT2 -
3342 C ISCAL2 -
3343 C IRFVL2 -
3344 C IWIDE2 -
3345 C IRF1SW -
3346 C NEWREF -
3347 C ITBLD2 -
3348 C
3349 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
3350 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
3351 C KDATA(REPORT NUMBER,PARAMETER NUMBER)
3352 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
3353 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
3354 C ARGUMENT MAXD)
3355 C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES
3356 C KFXY1 -
3357 C ANAME1 -
3358 C AUNIT1 -
3359 C ISCAL1 -
3360 C IRFVL1 -
3361 C IWIDE1 -
3362 C ITBLD -
3363 C
3364 C SUBPROGRAMS CALLED:
3365 C LIBRARY:
3366 C W3LIB -
3367 C
3368 C REMARKS: ERROR RETURN:
3369 C IPTR(1) =
3370 C
3371 C ATTRIBUTES:
3372 C LANGUAGE: FORTRAN 77
3373 C MACHINE: NAS
3374 C
3375 C$$$
3376 C ..................................................
3377 C
3378 C NEW BASE TABLE B
3379 C MAY BE A COMBINATION OF MASTER TABLE B
3380 C AND ANCILLARY TABLE B
3381 C
3382  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
3383  CHARACTER*40 ANAME1(*)
3384  CHARACTER*24 AUNIT1(*)
3385 C ..................................................
3386 C
3387 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
3388 C
3389  INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
3390  CHARACTER*64 ANAME2(*)
3391  CHARACTER*24 AUNIT2(*)
3392 C ..................................................
3393 C
3394 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
3395 C
3396  INTEGER ITBLD2(20,*)
3397 C ..................................................
3398 C
3399 C NEW BASE TABLE D
3400 C
3401  INTEGER ITBLD(20,*)
3402 C ..................................................
3403  INTEGER IPTR(*),ISTACK(*),NRDESC,NWLIST(200)
3404  INTEGER NEWREF(*),KPTRB(*),KPTRD(*)
3405  INTEGER IUNITB,IUNITD,ICOPY(20000),NRCOPY,IELEM,IPOS
3406  CHARACTER*64 AHLD64
3407  CHARACTER*24 AHLD24
3408 C
3409  SAVE
3410 C
3411 C SCAN AND DISCARD REPLICATION AND OPERATOR DESCRIPTORS
3412 C REPLACING SEQUENCE DESCRIPTORS WITH THEIR CORRESPONDING
3413 C SET OF DESCRIPTORS ALSO ELIMINATING DUPLICATES.
3414 C
3415 C-----------------------------------------------------------
3416 C PRINT *,'ENTER FI8812'
3417 C
3418  DO 10 i = 1, 16384
3419  kptrb(i) = -1
3420  10 CONTINUE
3421 C
3422 C
3423 C
3424  IF (iptr(14).NE.0) THEN
3425  DO i = 1, iptr(14)
3426  kptrb(kfxy1(i)) = i
3427  ENDDO
3428  GO TO 9000
3429  END IF
3430 C
3431 C READ IN TABLE B
3432  print *,'FI8812 - READING TABLE B'
3433  rewind iunitb
3434  i = 1
3435  4000 CONTINUE
3436 C
3437  READ(unit=iunitb,fmt=20,err=9999,END=9000)MF,
3438  * mx,my,
3439  * (aname1(i)(k:k),k=1,40),
3440  * (aunit1(i)(k:k),k=1,24),
3441  * iscal1(i),irfvl1(1,i),iwide1(i)
3442  20 FORMAT(i1,i2,i3,40a1,24a1,i5,i15,1x,i4)
3443  kfxy1(i) = mf*16384 + mx*256 + my
3444 C PRINT *,MF,MX,MY,KFXY1(I)
3445  5000 CONTINUE
3446  kptrb(kfxy1(i)) = i
3447  iptr(14) = i
3448 C PRINT *,I
3449 C WRITE(6,21) MF,MX,MY,KFXY1(I),
3450 C * (ANAME1(I)(K:K),K=1,40),
3451 C * (AUNIT1(I)(K:K),K=1,24),
3452 C * ISCAL1(I),IRFVL1(1,I),IWIDE1(I)
3453  21 FORMAT(1x,i1,i2,i3,1x,i6,1x,40a1,
3454  * 2x,24a1,2x,i5,2x,i15,1x,i4)
3455  i = i + 1
3456  GO TO 4000
3457 C ======================================================
3458  9999 CONTINUE
3459 C ERROR READING TABLE B
3460  print *,'FI8812 - ERROR READING TABLE B - RECORD ',i
3461  iptr(1) = 9
3462  9000 CONTINUE
3463  iptr(21) = iptr(14)
3464 C PRINT *,'EXIT FI8812 - IPTR(21) =',IPTR(21),' IPTR(1) =',IPTR(1)
3465  RETURN
3466  END
3467  SUBROUTINE fi8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,KPTRB,
3468  * ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
3469 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
3470 C . . . .
3471 C SUBPROGRAM: FI8813 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES
3472 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
3473 C
3474 C ABSTRACT: EXTRACT TABLE A, TABLE B, TABLE D ENTRIES FROM A
3475 C DECODED BUFR MESSAGE.
3476 C
3477 C PROGRAM HISTORY LOG:
3478 C 94-03-04 CAVANAUGH
3479 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
3480 C
3481 C USAGE: CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,
3482 C * KPTRB,ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
3483 C INPUT ARGUMENT LIST:
3484 C IPTR
3485 C MAXR
3486 C MAXD
3487 C MSTACK
3488 C KDATA
3489 C IDENT
3490 C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
3491 C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
3492 C
3493 C OUTPUT ARGUMENT LIST:
3494 C IUNITB
3495 C ITBLD1
3496 C ANAME1
3497 C AUNIT1
3498 C KFXY1
3499 C ISCAL1
3500 C IRFVL1
3501 C IWIDE1
3502 C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
3503 C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
3504 C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
3505 C
3506 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
3507 C
3508 C ATTRIBUTES:
3509 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
3510 C MACHINE: NAS, CYBER, WHATEVER
3511 C
3512 C$$$
3513 C ..................................................
3514 C
3515 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
3516 C
3517  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(*),IWIDE1(*)
3518  CHARACTER*40 ANAME1(*)
3519  CHARACTER*24 AUNIT1(*)
3520 C ..................................................
3521 C
3522 C TABLE D
3523 C
3524  INTEGER ITBLD(20,*)
3525 C ..................................................
3526  CHARACTER*32 SPACES
3527  CHARACTER*8 ASCCHR
3528  CHARACTER*32 AAAA
3529 C
3530  INTEGER I1(20),I2(20),I3(20),KPTRB(*)
3531  INTEGER IPTR(*),MAXR,MAXD,MSTACK(2,MAXD)
3532  INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD)
3533  INTEGER IEXTRA,KPTRD(*)
3534  INTEGER KEYSET,ISCSGN(200),IRFSGN(200)
3535  INTEGER IDENT(*),IHOLD,JHOLD(8),IUNITB
3536  EQUIVALENCE (IHOLD,ASCCHR),(JHOLD,AAAA)
3537  SAVE
3538  DATA SPACES/' '/
3539  DATA IEXTRA/0/
3540  DATA keyset/0/
3541 
3542 C ==============================================================
3543 C PRINT *,'FI8813',IPTR(41),IPTR(42),IPTR(31),IPTR(21)
3544 C BUILD SPACE CONSTANT
3545 C INITIALIZE ENTRY COUNTS
3546  ixa = 0
3547 C NUMBER IN TABLE B
3548  ixb = iptr(21)
3549 C
3550 C
3551 C SET FOR COMPRESSED OR NON COMPRESSED
3552 C PROCESSING
3553 C
3554 C PRINT *,'FI8813 - 2',IDENT(16),IDENT(14)
3555  IF (ident(16).EQ.0) THEN
3556  jk = 1
3557  ELSE
3558  jk = ident(14)
3559  END IF
3560 C PRINT *,'FI8813 - 3, JK=',JK
3561 C
3562 C
3563 C START PROCESSING ENTRIES
3564 C PRINT *,'START PROCESSING ENTRIES'
3565 C
3566 C DO 995 I = 1, IPTR(31)
3567 C IF (IPTR(45).EQ.4) THEN
3568 C PRINT 9958,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I)
3569 C9958 FORMAT (1X,I5,2X,I5,2X,Z8,2X,A4)
3570 C ELSE
3571 C PRINT 9959,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I)
3572 C9959 FORMAT (1X,I5,2X,I5,2X,Z16,2X,A8)
3573 C END IF
3574 C 995 CONTINUE
3575 C PRINT *,' '
3576  i = 0
3577  iextra = 0
3578  1000 CONTINUE
3579 C
3580 C SET POINTER TO CORRECT DATA POSITION
3581 C I IS THE NUMBER OF DESCRIPTORS
3582 C IEXTRA IS THE NUMBER OF WORDS ADDED
3583 C FOR TEXT DATA
3584 C
3585  i = i + 1
3586  IF (i.GT.iptr(31)) THEN
3587 C RETURN IF COMPLETED SEARCH
3588  GO TO 9000
3589  END IF
3590  klk = i + iextra
3591 C PRINT *,'ENTRY',KLK,I,IPTR(31),IEXTRA,MSTACK(1,KLK)
3592 C
3593 C IF TABLE A ENTRY OR EDITION NUMBER
3594 C OR IF DESCRIPTOR IS NOT IN CLASS 0
3595 C SKIP OVER
3596 C
3597  IF (mstack(1,klk).EQ.1) THEN
3598 C PRINT *,'A ENTRY'
3599  GO TO 1000
3600  ELSE IF (mstack(1,klk).EQ.2) THEN
3601 C PRINT *,'A ENTRY LINE 1'
3602  iextra = iextra + 32 / iptr(45) - 1
3603  GO TO 1000
3604  ELSE IF (mstack(1,klk).EQ.3) THEN
3605 C PRINT *,'A ENTRY LINE 2'
3606  iextra = iextra + 32 / iptr(45) - 1
3607  GO TO 1000
3608  ELSE IF (mstack(1,klk).GE.34048.AND.mstack(1,klk).LE.34303) THEN
3609  ly = mod(mstack(1,klk),256)
3610 C PRINT *,'CLASS C - HAVE',LY,' BYTES OF TEXT'
3611  IF (mod(ly,iptr(45)).EQ.0) THEN
3612  iwds = ly / iptr(45)
3613  ELSE
3614  iwds = ly / iptr(45) + 1
3615  END IF
3616  iextra = iextra + iwds - 1
3617  GO TO 1000
3618  ELSE IF (mstack(1,klk).LT.10.OR.mstack(1,klk).GT.255) THEN
3619 C PRINT *,MSTACK(1,KLK),' NOT CLASS 0'
3620  GO TO 1000
3621  END IF
3622 C
3623 C MUST FIND F X Y KEY FOR TABLE B
3624 C OR TABLE D ENTRY
3625 C
3626  iz = 1
3627  keyset = 0
3628  10 CONTINUE
3629  IF (i.GT.iptr(31)) THEN
3630  GO TO 9000
3631  END IF
3632  klk = i + iextra
3633  IF (mstack(1,klk).GE.34048.AND.mstack(1,klk).LE.34303) THEN
3634  ly = mod(mstack(1,klk),256)
3635 C PRINT *,'TABLE C - HAVE',LY,' TEXT BYTES'
3636  IF (mod(ly,4).EQ.0) THEN
3637  iwds = ly / iptr(45)
3638  ELSE
3639  iwds = ly / iptr(45) + 1
3640  END IF
3641  iextra = iextra + iwds - 1
3642  i = i + 1
3643  GO TO 10
3644  ELSE IF (mstack(1,klk)/16384.NE.0) THEN
3645  IF (mod(mstack(1,klk),256).EQ.0) THEN
3646  i = i + 1
3647  END IF
3648  i = i + 1
3649  GO TO 10
3650  END IF
3651  IF (mstack(1,klk).GE.10.AND.mstack(1,klk).LE.12) THEN
3652 C PRINT *,'FIND KEY'
3653 C
3654 C MUST INCLUDE PROCESSING FOR COMPRESSED DATA
3655 C
3656 C BUILD DESCRIPTOR SEGMENT
3657 C
3658  IF (mstack(1,klk).EQ.10) THEN
3659  CALL fi8814 (kdata(iz,klk),1,mf,ierr,iptr)
3660 C PRINT *,'F =',MF,KDATA(IZ,KLK),IPTR(31),I,IEXTRA
3661  keyset = ior(keyset,4)
3662  ELSE IF (mstack(1,klk).EQ.11) THEN
3663  CALL fi8814 (kdata(iz,klk),2,mx,ierr,iptr)
3664 C PRINT *,'X =',MX,KDATA(IZ1,KLK)
3665  keyset = ior(keyset,2)
3666  ELSE IF (mstack(1,klk).EQ.12) THEN
3667  CALL fi8814 (kdata(iz,klk),3,my,ierr,iptr)
3668 C PRINT *,'Y =',MY,KDATA(IZ,KLK)
3669  keyset = ior(keyset,1)
3670  END IF
3671 C PRINT *,' KEYSET =',KEYSET
3672  i = i + 1
3673  GO TO 10
3674  END IF
3675  IF (keyset.EQ.7) THEN
3676 C PRINT *,'HAVE KEY DESCRIPTOR',MF,MX,MY
3677 C
3678 C TEST NEXT DESCRIPTOR FOR TABLE B
3679 C OR TABLE D ENTRY, PROCESS ACCORDINGLY
3680 C
3681  klk = i + iextra
3682 C PRINT *,'DESC ',MSTACK(1,KLK),KLK,I,IEXTRA,KDATA(1,KLK)
3683  IF (mstack(1,klk).EQ.30) THEN
3684  ixd = iptr(20) + 1
3685  itbld(1,ixd) =16384 * mf + 256 * mx + my
3686 C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD)
3687  GO TO 300
3688  ELSE IF (mstack(1,klk).GE.13.AND.mstack(1,klk).LE.20) THEN
3689  kfxy1(ixb+iz) = 16384 * mf + 256 * mx + my
3690 C PRINT *,'ELEMENT DESCRIPTOR',MF,MX,MY,KFXY1(IXB+IZ),IXB+IZ
3691  kptrb(kfxy1(ixb+iz)) = ixb+iz
3692  GO TO 200
3693  ELSE
3694  END IF
3695 C I = I + 1
3696 C IF (I.GT.IPTR(31)) THEN
3697 C GO TO 9000
3698 C END IF
3699 C GO TO 10
3700  END IF
3701  GO TO 1000
3702 C ==================================================================
3703  200 CONTINUE
3704  ibflag = 1
3705  20 CONTINUE
3706  klk = i + iextra
3707 C PRINT *,'ZZZ',KLK,I,IEXTRA,MSTACK(1,KLK),KDATA(IZ,KLK)
3708  IF (mstack(1,klk).LT.13.OR.mstack(1,klk).GT.20) THEN
3709  print *,'IMPROPER SEQUENCE OF DESCRIPTORS IN LIST'
3710 C ===============================================================
3711  ELSE IF (mstack(1,klk).EQ.13) THEN
3712 C PRINT *,'13 NAME',KLK
3713 C
3714 C ELEMENT NAME PART 1 - 32 BYTES
3715 C FOR THIS PARAMETER
3716  jj = iextra
3717  DO 21 ll = 1, 32, iptr(45)
3718  lll = ll + iptr(45) - 1
3719  kqk = i + jj
3720  ihold = kdata(iz,kqk)
3721  IF (iptr(37).EQ.0) THEN
3722 C CALL W3AI39 (IDATA,IPTR(45))
3723  END IF
3724  aname1(ixb+iz)(ll:lll) = ascchr
3725  jj = jj + 1
3726  21 CONTINUE
3727  iextra = iextra + (32 / iptr(45)) - 1
3728  ibflag = ior(ibflag,64)
3729 C ===============================================================
3730  ELSE IF (mstack(1,klk).EQ.14) THEN
3731 C PRINT *,'14 NAME2',KLK
3732 C
3733 C ELEMENT NAME PART 2 - 32 BYTES
3734 C
3735 C FOR THIS PARAMETER
3736  jj = iextra
3737  DO 22 ll = 33, 64, iptr(45)
3738  lll = ll + iptr(45) - 1
3739  kqk = i + jj
3740  ihold = kdata(iz,kqk)
3741  IF (iptr(37).EQ.0) THEN
3742 C CALL W3AI39 (ASCCHR,IPTR(45))
3743  END IF
3744  aname1(ixb+iz)(ll:lll) = ascchr
3745  jj = jj + 1
3746  22 CONTINUE
3747  iextra = iextra + (32 / iptr(45)) - 1
3748  ibflag = ior(ibflag,32)
3749 C ===============================================================
3750  ELSE IF (mstack(1,klk).EQ.15) THEN
3751 C PRINT *,'15 UNITS',KLK
3752 C
3753 C UNITS NAME - 24 BYTES
3754 C
3755 C FOR THIS PARAMETER
3756  jj = iextra
3757  DO 23 ll = 1, 24, iptr(45)
3758  lll = ll + iptr(45) - 1
3759  kqk = i + jj
3760  ihold = kdata(iz,kqk)
3761  IF (iptr(37).EQ.0) THEN
3762 C CALL W3AI39 (ASCCHR,IPTR(45))
3763  END IF
3764  aunit1(ixb+iz)(ll:lll) = ascchr
3765  jj = jj + 1
3766  23 CONTINUE
3767  iextra = iextra + (24 / iptr(45)) - 1
3768  ibflag = ior(ibflag,16)
3769 C ===============================================================
3770  ELSE IF (mstack(1,klk).EQ.16) THEN
3771 C PRINT *,'16 SCALE SIGN'
3772 C
3773 C SCALE SIGN - 1 BYTE
3774 C 0 = POS, 1 = NEG
3775  ihold = kdata(iz,klk)
3776  klk = i + iextra
3777  IF (index(ascchr,'-').EQ.0) THEN
3778  iscsgn(iz) = 1
3779  ELSE
3780  iscsgn(iz) = -1
3781  END IF
3782 C ===============================================================
3783  ELSE IF (mstack(1,klk).EQ.17) THEN
3784 C PRINT *,'17 SCALE',KLK
3785 C
3786 C SCALE - 3 BYTES
3787 C
3788  klk = i + iextra
3789  CALL fi8814(kdata(iz,klk),3,iscal1(ixb+iz),ierr,iptr)
3790  IF (ierr.NE.0) THEN
3791  print *,'NON-NUMERIC CHAR - CANNOT CONVERT'
3792  iptr(1) = 888
3793  GO TO 9000
3794  END IF
3795  iscal1(ixb+iz) = iscal1(ixb+iz) * iscsgn(iz)
3796  ibflag = ior(ibflag,8)
3797 C ===============================================================
3798  ELSE IF (mstack(1,klk).EQ.18) THEN
3799 C PRINT *,'18 REFERENCE SCALE',KLK
3800 C
3801 C REFERENCE SIGN - 1 BYTE
3802 C 0 = POS, 1 = NEG
3803 C
3804  klk = i + iextra
3805  ihold = kdata(iz,klk)
3806  IF (index(ascchr,'-').EQ.0) THEN
3807  irfsgn(iz) = 1
3808  ELSE
3809  irfsgn(iz) = -1
3810  END IF
3811 C ===============================================================
3812  ELSE IF (mstack(1,klk).EQ.19) THEN
3813 C PRINT *,'19 REFERENCE VALUE',KLK
3814 C
3815 C REFERENCE VALUE - 10 BYTES/ 3 WDS
3816 C
3817  jj = iextra
3818  kqk = i + jj
3819  km = 0
3820  DO 26 ll = 1, 12, iptr(45)
3821  kqk = i + jj
3822  km = km + 1
3823  jhold(km) = kdata(iz,kqk)
3824  jj = jj + 1
3825  26 CONTINUE
3826  CALL fi8814(aaaa,10,irfvl1(ixb+iz),ierr,iptr)
3827  IF (ierr.NE.0) THEN
3828  print *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
3829  iptr(1) = 888
3830  GO TO 9000
3831  END IF
3832  irfvl1(ixb+iz) = irfvl1(ixb+iz) * irfsgn(iz)
3833  iextra = iextra + 10 / iptr(45)
3834 C DO 261 IZ = 1, JK
3835 C PRINT *,'RFVAL',IXB+IZ,JK,IRFVL1(IXB+IZ)
3836 C 261 CONTINUE
3837  ibflag = ior(ibflag,4)
3838 C ===============================================================
3839  ELSE
3840 C PRINT *,'20 WIDTH',KLK
3841 C
3842 C ELEMENT DATA WIDTH - 3 BYTES
3843 C
3844 C DO 27 LL = 1, 24, IPTR(45)
3845  klk = i + iextra
3846 C DO 270 IZ = 1, JK
3847  CALL fi8814(kdata(iz,klk),3,iwide1(ixb+iz),ierr,iptr)
3848  IF (ierr.NE.0) THEN
3849  print *,'NON-NUMERIC CHAR - CANNOT CONVERT'
3850  iptr(1) = 888
3851  GO TO 9000
3852  END IF
3853  IF (iwide1(ixb+iz).LT.1) THEN
3854  iptr(1) = 890
3855 C PRINT *,'CLASS 0 DESCRIPTOR, WIDTH=0',KFXY1(IXB+IZ)
3856  GO TO 9000
3857  END IF
3858 C 270 CONTINUE
3859 C 27 CONTINUE
3860  ibflag = ior(ibflag,2)
3861  END IF
3862 C NO, IT ISN'T
3863 C
3864 C IF THERE ARE ENOUGH OF THE ELEMENTS
3865 C NECESSARY TO ACCEPT A TABLE B ENTRY
3866 C
3867 C PRINT *,' IBFLAG =',IBFLAG
3868  IF (ibflag.EQ.127) THEN
3869 C PRINT *,'COMPLETE TABLE B ENTRY'
3870 C HAVE A COMPLETE TABLE B ENTRY
3871  ixb = ixb + 1
3872 C PRINT *,'B',IXB,JK,KFXY1(IXB),ANAME1(IXB)
3873 C PRINT *,' ',AUNIT1(IXB),ISCAL1(IXB),
3874 C * IRFVL1(IXB),IWIDE1(IXB)
3875  iptr(21) = ixb
3876  GO TO 1000
3877  END IF
3878  i = i + 1
3879 C
3880 C CHECK NEXT DESCRIPTOR
3881 C
3882  IF (i.GT.iptr(31)) THEN
3883 C RETURN IF COMPLETED SEARCH
3884  GO TO 9000
3885  END IF
3886  GO TO 20
3887 C ==================================================================
3888  300 CONTINUE
3889  iseq = 0
3890  ijk = iptr(20) + 1
3891 C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD),' FOR',IJK
3892  30 CONTINUE
3893  klk = i + iextra
3894 C PRINT *,'HAVE A SEQUENCE DESCRIPTOR',KLK,KDATA(IZ,KLK)
3895  IF (mstack(1,klk).EQ.30) THEN
3896 C FROM TEXT FIELD (6 BYTES/2 WDS)
3897 C STRIP OUT NEXT DESCRIPTOR IN SEQUENCE
3898 C
3899 C F - EXTRACT AND CONVERT TO DECIMAL
3900  jj = iextra
3901  kk = 0
3902  DO 351 ll = 1, 6, iptr(45)
3903  kqk = i + jj
3904  kk = kk + 1
3905  jhold(kk) = kdata(1,kqk)
3906  jj = jj + 1
3907  IF (ll.GT.1) iextra = iextra + 1
3908  351 CONTINUE
3909 C PRINT 349,KDATA(1,KQK)
3910  349 FORMAT (6x,z24)
3911 C CONVERT TO INTEGER
3912  CALL fi8814(aaaa,6,ihold,ierr,iptr)
3913 C PRINT *,' ',IHOLD
3914  IF (ierr.NE.0) THEN
3915  print *,'NON NUMERIC CHARACTER FOUND IN F X Y'
3916  iptr(1) = 888
3917  GO TO 9000
3918  END IF
3919 C CONSTRUCT SEQUENCE DESCRIPTOR
3920  iff = ihold / 100000
3921  ixx = mod((ihold/1300),100)
3922  iyy = mod(ihold,1300)
3923 C INSERT IN PROPER SEQUENCE
3924  itbld(iseq+2,ijk) = 16384 * iff + 256 * ixx + iyy
3925 C PRINT *,' SEQUENCE',IZ,AAAA,IHOLD,ITBLD(ISEQ+2,IJK),
3926 C * IFF,IXX,IYY
3927  iseq = iseq + 1
3928  IF (iseq.GT.18) THEN
3929  iptr(1) = 30
3930  RETURN
3931  END IF
3932 C SET TO LOOK AT NEXT DESCRIPTOR
3933  i = i + 1
3934 C IF (IPTR(45).LT.6) THEN
3935 C IEXTRA = IEXTRA + 1
3936 C END IF
3937  GO TO 30
3938  ELSE
3939 C NEXT DESCRIPTOR IS NOT A SEQUENCE DESCRIPTOR
3940  IF (iseq.GE.1) THEN
3941 C HAVE COMPLETE TABLE D ENTRY
3942  iptr(20) = iptr(20) + 1
3943 C PRINT *,' INTO LOCATION ',IPTR(20)
3944  lz = itbld(1,ijk)
3945  mz = mod(lz,16384)
3946  kptrd(mz) = ijk
3947  i = i - 1
3948  END IF
3949  END IF
3950 C GO TEST NEXT DESCRIPTOR
3951  GO TO 1000
3952 C ==================================================================
3953  9000 CONTINUE
3954 C PRINT *,IPTR(21),' ENTRIES IN ANCILLARY TABLE B'
3955 C PRINT *,IPTR(20),' ENTRIES IN ANCILLARY TABLE D'
3956 C DO 9050 L = 1, 16384
3957 C IF (KPTRD(L).GT.0) PRINT *,' D',L+32768, KPTRD(L)
3958 C9050 CONTINUE
3959 C IF (I.GE.IPTR(31)) THEN
3960 C
3961 C FILE FOR MODIFIED TABLE B OUTPUT
3962  numnut = iunitb + 1
3963  rewind numnut
3964 C
3965 C PRINT *,' HERE IS THE NEW TABLE B',IPTR(21)
3966  DO 2000 kb = 1, iptr(21)
3967  jf = kfxy1(kb) / 16384
3968  jx = mod((kfxy1(kb) / 256),64)
3969  jy = mod(kfxy1(kb),256)
3970 C WRITE (6,2001)JF,JX,JY,ANAME1(KB),
3971 C * AUNIT1(KB),ISCAL1(KB),IRFVL1(KB),IWIDE1(KB)
3972  WRITE (numnut,5000)jf,jx,jy,aname1(kb)(1:40),
3973  * aunit1(kb)(1:24),iscal1(kb),irfvl1(kb),iwide1(kb)
3974  5000 FORMAT(i1,i2,i3,a40,a24,i5,i15,i5)
3975  2000 CONTINUE
3976  2001 FORMAT (1x,i1,1x,i2,1x,i3,2x,a40,3x,a24,2x,i5,2x,i12,
3977  * 2x,i4)
3978 C
3979  endfile numnut
3980 C
3981  IF (iptr(20).NE.0) THEN
3982 C PRINT OUT TABLE
3983 C PRINT *,' HERE IS THE UPGRADED TABLE D'
3984 C DO 3000 KB = 1, IPTR(20)
3985 C PRINT 3001,KB,(ITBLD(K,KB),K=1,15)
3986 C3000 CONTINUE
3987 C3001 FORMAT (16(1X,I5))
3988  END IF
3989 C EXIT ROUTINE, ALL DONE WITH PASS
3990 C END IF
3991  RETURN
3992  END
3993  SUBROUTINE fi8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR)
3994 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
3995 C . . . .
3996 C SUBPROGRAM: FI8814 CONVERT TEXT TO INTEGER
3997 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
3998 C
3999 C ABSTRACT: CONVERT TEXT CHARACTERS TO INTEGER VALUE
4000 C
4001 C PROGRAM HISTORY LOG:
4002 C 94-03-04 CAVANAUGH
4003 C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
4004 C
4005 C USAGE: CALL FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR)
4006 C INPUT ARGUMENT LIST:
4007 C ASCCHR -
4008 C NPOS -
4009 C NEWVAL -
4010 C IERR -
4011 C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
4012 C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
4013 C
4014 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
4015 C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
4016 C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
4017 C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
4018 C
4019 C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
4020 C DDNAME1 - GENERIC NAME & CONTENT
4021 C
4022 C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
4023 C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
4024 C FT06F001 - INCLUDE IF ANY PRINTOUT
4025 C
4026 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
4027 C
4028 C ATTRIBUTES:
4029 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
4030 C MACHINE: NAS, CYBER, WHATEVER
4031 C
4032 C$$$
4033  INTEGER IERR, IHOLD, IPTR(*)
4034  CHARACTER*8 AHOLD
4035  CHARACTER*64 ASCCHR
4036  EQUIVALENCE (IHOLD,AHOLD)
4037 
4038  SAVE
4039 C ----------------------------------------------------------
4040  IERR = 0
4041  newval = 0
4042  iflag = 0
4043 C
4044  DO 1000 i = 1, npos
4045  ihold = 0
4046  ahold(iptr(45):iptr(45)) = ascchr(i:i)
4047  IF (iptr(37).EQ.1) THEN
4048  IF (ihold.EQ.32) THEN
4049  IF (iflag.EQ.0) GO TO 1000
4050  GO TO 2000
4051  ELSE IF (ihold.LT.48.OR.ihold.GT.57) THEN
4052 C PRINT*,' ASCII IHOLD =',IHOLD
4053  ierr = 1
4054  RETURN
4055  ELSE
4056  iflag = 1
4057  newval = newval * 10 + ihold - 48
4058  END IF
4059  ELSE
4060  IF (ihold.EQ.64) THEN
4061  IF (iflag.EQ.0) GO TO 1000
4062  GO TO 2000
4063  ELSE IF (ihold.LT.240.OR.ihold.GT.249) THEN
4064 C PRINT*,' EBCIDIC IHOLD =',IHOLD
4065  ierr = 1
4066  RETURN
4067  ELSE
4068  iflag = 1
4069  newval = newval * 10 + ihold - 240
4070  END IF
4071  END IF
4072  1000 CONTINUE
4073  2000 CONTINUE
4074  RETURN
4075  END
4076  SUBROUTINE fi8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD,
4077  * ANAME3,AUNIT3,
4078  * ISCAL3,IRFVL3,IWIDE3,
4079  * KEYSET,IBFLAG,IERR)
4080 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
4081 C . . . .
4082 C SUBPROGRAM: FI8815 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES
4083 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
4084 C
4085 C ABSTRACT: EXTRACT TABLE A, TABLE B, ENTRIES FROM ACTIVE BUFR MESSAGE
4086 C TO BE RETAINED FOR USE DURING THE DECODING OF ACTIVE BUFR MESSAGE.
4087 C THESE WILL BE DISCARDED WHEN DECODING OF CURRENT MESSAGE IS COMPLETE
4088 C
4089 C PROGRAM HISTORY LOG:
4090 C 94-03-04 CAVANAUGH
4091 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
4092 C
4093 C USAGE: CALL FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD,
4094 C * ANAME3,AUNIT3,
4095 C * ISCAL3,IRFVL3,IWIDE3,
4096 C * KEYSET,IBFLAG,IERR)
4097 C INPUT ARGUMENT LIST:
4098 C IPTR -
4099 C MAXR -
4100 C MAXD -
4101 C MSTACK -
4102 C KDATA -
4103 C IDENT -
4104 C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
4105 C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
4106 C
4107 C OUTPUT ARGUMENT LIST:
4108 C ANAME3 -
4109 C AUNIT3 -
4110 C KFXY3 -
4111 C ISCAL3 -
4112 C IRFVL3 -
4113 C IWIDE3 -
4114 C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
4115 C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
4116 C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
4117 C
4118 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
4119 C
4120 C ATTRIBUTES:
4121 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
4122 C MACHINE: NAS, CYBER
4123 C
4124 C$$$
4125  CHARACTER*64 ANAME3(*),SPACES
4126  CHARACTER*24 AUNIT3(*)
4127 C
4128  INTEGER IPTR(*),MAXR,MAXD,JDESC
4129  INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD)
4130  INTEGER IEXTRA
4131  INTEGER KEYSET
4132  INTEGER KFXY3(*),IDENT(*)
4133  INTEGER ISCAL3(*),ISCSGN(150)
4134  INTEGER IRFVL3(*),IRFSGN(150)
4135  INTEGER IWIDE3(*)
4136 
4137  SAVE
4138 C ==============================================================
4139 C PRINT *,'FI8815'
4140  IEXTRA = 0
4141 C BUILD SPACE CONSTANT
4142  do 1 i = 1, 64
4143  spaces(i:i) = ' '
4144  1 CONTINUE
4145 C INITIALIZE ENTRY COUNTS
4146  ixa = 0
4147  ixb = 0
4148  ixd = 0
4149 C
4150 C SET FOR COMPRESSED OR NON COMPRESSED
4151 C PROCESSING
4152 C
4153  IF (ident(16).EQ.0) THEN
4154  jk = 1
4155  ELSE
4156  jk = ident(14)
4157  END IF
4158 C
4159 C CLEAR NECESSARY ENTRIES
4160 C
4161  DO 2 iy = 1, jk
4162 C
4163 C CLEAR NEXT TABLE B ENTRY
4164 C
4165  kfxy3(ixb+iy) = 0
4166  aname3(ixb+iy)(1:64) = spaces(1:64)
4167  aunit3(ixb+iy)(1:24) = spaces(1:24)
4168  iscal3(ixb+iy) = 0
4169  irfvl3(ixb+iy) = 0
4170  iwide3(ixb+iy) = 0
4171  iscsgn(iy) = 1
4172  irfsgn(iy) = 1
4173  2 CONTINUE
4174 C
4175 C START PROCESSING ENTRIES
4176 C
4177  i = 0
4178  1000 CONTINUE
4179 C
4180 C SET POINTER TO CORRECT DATA POSITION
4181 C
4182  k = i + iextra
4183 C
4184 C MUST FIND F X Y KEY FOR TABLE B
4185 C OR TABLE D ENTRY
4186 C
4187  IF (jdesc.GE.10.AND.jdesc.LE.12) THEN
4188  10 CONTINUE
4189 C
4190 C BUILD DESCRIPTOR SEGMENT
4191 C
4192  DO 20 ly = 1,jk
4193  IF (jdesc.EQ.10) THEN
4194  kfxy3(ixb+ly) = kdata(k,1) * 16384 + kfxy3(ixb+ly)
4195  keyset = ior(keyset,4)
4196  i = i + 1
4197  GO TO 10
4198  ELSE IF (jdesc.EQ.11) THEN
4199  kfxy3(ixb+ly) = kdata(k,1) * 256 + kfxy3(ixb+ly)
4200  keyset = ior(keyset,2)
4201  i = i + 1
4202  GO TO 10
4203  ELSE IF (jdesc.EQ.12) THEN
4204  kfxy3(ixb+ly) = kdata(k,1) + kfxy3(ixb+ly)
4205  keyset = ior(keyset,1)
4206  END IF
4207  20 CONTINUE
4208 C ==================================================================
4209  ELSE IF (jdesc.GE.13.AND.jdesc.LE.20) THEN
4210  DO 250 iz = 1, jk
4211  IF (jdesc.EQ.13) THEN
4212 C
4213 C ELEMENT NAME PART 1 - 32 BYTES/8 WDS
4214 C
4215  CALL gbytes (aname3(ixb+iz),kdata(k,iz),0,32,0,8)
4216  ibflag = ior(ibflag,16)
4217  ELSE IF (jdesc.EQ.14) THEN
4218 C
4219 C ELEMENT NAME PART 2 - 32 BYTES/8 WDS
4220 C
4221  CALL gbytes(aname3(ixb+iz)(33:33),kdata(k,iz),0,32,0,8)
4222  ELSE IF (jdesc.EQ.15) THEN
4223 C
4224 C UNITS NAME - 24 BYTES/6 WDS
4225 C
4226  CALL gbytes (aunit3(ixb+iz)(1:1),kdata(k,iz),0,32,0,6)
4227  ibflag = ior(ibflag,8)
4228  ELSE IF (jdesc.EQ.16) THEN
4229 C
4230 C UNITS SCALE SIGN - 1 BYTE/ 1 WD
4231 C 0 = POS, 1 = NEG
4232  IF (kdata(k,1).NE.48) THEN
4233  iscsgn(iz) = -1
4234  ELSE
4235  iscsgn(iz) = 1
4236  END IF
4237  ELSE IF (jdesc.EQ.17) THEN
4238 C
4239 C UNITS SCALE - 3 BYTES/ 1 WD
4240 C
4241  CALL fi8814(kdata(k,iz),3,iscal3(ixb+iz),ierr,iptr)
4242  IF (ierr.NE.0) THEN
4243  print *,'NON-NUMERIC CHARACTER - CANNOT CONVERT'
4244  iptr(1) = 888
4245  RETURN
4246  END IF
4247  ibflag = ior(ibflag,4)
4248  ELSE IF (jdesc.EQ.18) THEN
4249 C
4250 C UNITS REFERENCE SIGN - 1 BYTE/ 1 WD
4251 C 0 = POS, 1 = NEG
4252 C
4253  IF (kdata(k,1).EQ.48) THEN
4254  irfsgn(iz) = 1
4255  ELSE
4256  irfsgn(iz) = -1
4257  END IF
4258  ELSE IF (jdesc.EQ.19) THEN
4259 C
4260 C UNITS REFERENCE VALUE - 10 BYTES/ 3 WDS
4261 C
4262  CALL fi8814(kdata(k,iz),10,irfvl3(ixb+iz),ierr,iptr)
4263  IF (ierr.NE.0) THEN
4264  print *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
4265  iptr(1) = 888
4266  RETURN
4267  END IF
4268  ibflag = ior(ibflag,2)
4269  ELSE
4270 C
4271 C ELEMENT DATA WIDTH - 3 BYTES/ 1 WD
4272 C
4273  CALL fi8814(kdata(k,1),3,iwide3(ixb+1),ierr,iptr)
4274  IF (ierr.NE.0) THEN
4275  print *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
4276  iptr(1) = 888
4277  RETURN
4278  END IF
4279  ibflag = ior(ibflag,1)
4280  END IF
4281  250 CONTINUE
4282  END IF
4283 C ==================================================================
4284  9000 RETURN
4285  END
4286  SUBROUTINE fi8818(IPTR,
4287  * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
4288  * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
4289  * KPTRB)
4290 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
4291 C . . . .
4292 C SUBPROGRAM: FI8818 MERGE ANCILLARY & STANDARD B ENTRIES
4293 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD
4294 C
4295 C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE
4296 C FOLLOWING LINES. SEE NMC HANDBOOK SECTION 3.1.1. FOR DETAILS
4297 C
4298 C PROGRAM HISTORY LOG:
4299 C YY-MM-DD CAVANAUGH
4300 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
4301 C
4302 C USAGE: CALL FI8818(IPTR,
4303 C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
4304 C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB)
4305 C INPUT ARGUMENT LIST:
4306 C IPTR -
4307 C KFXY1 -
4308 C ANAME1 -
4309 C AUNIT1 -
4310 C ISCAL1 -
4311 C IRFVL1 -
4312 C IWIDE1 -
4313 C KFXY2 -
4314 C ANAME2 -
4315 C AUNIT2 -
4316 C ISCAL2 -
4317 C IRFVL2 -
4318 C IWIDE2 -
4319 C
4320 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
4321 C IPTR -
4322 C KFXY1 -
4323 C ANAME1 -
4324 C AUNIT1 -
4325 C ISCAL1 -
4326 C IRFVL1 -
4327 C IWIDE1 -
4328 C
4329 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
4330 C
4331 C ATTRIBUTES:
4332 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
4333 C MACHINE: NAS, CYBER, WHATEVER
4334 C
4335 C$$$
4336 C ..................................................
4337 C
4338 C NEW BASE TABLE B
4339 C MAY BE A COMBINATION OF MASTER TABLE B
4340 C AND ANCILLARY TABLE B
4341 C
4342  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
4343  CHARACTER*40 ANAME1(*)
4344  CHARACTER*24 AUNIT1(*)
4345 C ..................................................
4346 C
4347 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
4348 C
4349  INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
4350  CHARACTER*64 ANAME2(*)
4351  CHARACTER*24 AUNIT2(*)
4352 C ..................................................
4353  INTEGER IPTR(*),KPTRB(*)
4354 
4355  SAVE
4356 C
4357 C SET UP POINTERS
4358 C PRINT *,'FI8818-A',IPTR(21),IPTR(41)
4359  KAB = 1
4360  kb = 1
4361  1000 CONTINUE
4362 C PRINT *,KB,KAB,KFXY1(KB),KFXY2(KAB),IPTR(21)
4363  IF (kb.GT.iptr(21)) THEN
4364 C NO MORE MASTER ENTRIES
4365 C PRINT *,'NO MORE MASTER ENTRIES'
4366  IF (kab.GT.iptr(41)) THEN
4367  GO TO 5000
4368  END IF
4369 C APPEND ANCILLARY ENTRY
4370  GO TO 2000
4371  ELSE IF (kb.LE.iptr(21)) THEN
4372 C HAVE MORE MASTER ENTRIES
4373  IF (kab.GT.iptr(41)) THEN
4374 C NO MORE ANCILLARY ENTRIES
4375  GO TO 5000
4376  END IF
4377  IF (kfxy2(kab).EQ.kfxy1(kb)) THEN
4378 C REPLACE MASTER ENTRY
4379  GO TO 3000
4380  ELSE IF (kfxy2(kab).LT.kfxy1(kb)) THEN
4381 C INSERT ANCILLARY ENTRY
4382  GO TO 2000
4383  ELSE IF (kfxy2(kab).GT.kfxy1(kb)) THEN
4384 C SKIP MASTER ENTRY
4385  kb = kb + 1
4386  END IF
4387  END IF
4388  GO TO 1000
4389  2000 CONTINUE
4390  iptr(21) = iptr(21) + 1
4391  kptrb(kfxy2(kab)) = iptr(21)
4392 C APPEND ANCILLARY ENTRY
4393  kfxy1(iptr(21)) = kfxy2(kab)
4394  aname1(iptr(21))(1:40) = aname2(kab)(1:40)
4395  aunit1(iptr(21)) = aunit2(kab)
4396  iscal1(iptr(21)) = iscal2(kab)
4397  irfvl1(1,iptr(21)) = irfvl2(kab)
4398  iwide1(iptr(21)) = iwide2(kab)
4399 C PRINT *,IPTR(21),KFXY1(IPTR(21)),' APPENDED'
4400  kab = kab + 1
4401  GO TO 1000
4402  3000 CONTINUE
4403 C REPLACE MASTER ENTRY
4404  kfxy1(kb) = kfxy2(kab)
4405  aname1(kb) = aname2(kab)(1:40)
4406  aunit1(kb) = aunit2(kab)
4407  iscal1(kb) = iscal2(kab)
4408  irfvl1(1,kb) = irfvl2(kab)
4409  iwide1(kb) = iwide2(kab)
4410 C PRINT *,KB,KFXY1(KB),'REPLACED',IWIDE1(KB)
4411  kab = kab + 1
4412  kb = kb + 1
4413  GO TO 1000
4414  5000 CONTINUE
4415  iptr(41) = 0
4416 C PROCESSING COMPLETE
4417 C PRINT *,'FI8818-B',IPTR(21),IPTR(41)
4418 C DO 6000 I = 1, IPTR(21)
4419 C PRINT *,'FI8818-C',I,KFXY1(I),IWIDE1(I)
4420 C6000 CONTINUE
4421  RETURN
4422  END
4423  SUBROUTINE fi8819(IPTR,ITBLD,ITBLD2,KPTRD)
4424 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
4425 C . . . .
4426 C SUBPROGRAM: FI8819 MERGE ANCILLARY & MASTER TABLE D
4427 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD
4428 C
4429 C ABSTRACT: MERGE TABLE D ENTRIES WITH THE ENTRIES FROM THE STANDARD
4430 C TABLE D. ASSURE THAT ENTRIES ARE SEQUENTIAL.
4431 C
4432 C PROGRAM HISTORY LOG:
4433 C YY-MM-DD CAVANAUGH
4434 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
4435 C
4436 C USAGE: CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
4437 C INPUT ARGUMENT LIST:
4438 C IPTR -
4439 C ITBLD -
4440 C ITBLD2 -
4441 C
4442 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
4443 C IPTR -
4444 C ITBLD -
4445 C
4446 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
4447 C
4448 C ATTRIBUTES:
4449 C LANGUAGE: FORTRAN 77
4450 C MACHINE: NAS, CYBER
4451 C
4452 C$$$
4453 C ..................................................
4454 C
4455 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
4456 C
4457  INTEGER ITBLD2(20,*)
4458 C ..................................................
4459 C
4460 C NEW BASE TABLE D
4461 C
4462  INTEGER ITBLD(20,*)
4463 C ..................................................
4464  INTEGER IPTR(*),KPTRD(*)
4465 
4466  SAVE
4467 C PRINT *,'FI8819-A',IPTR(20),IPTR(42)
4468 C SET UP POINTERS
4469  DO 1000 I = 1, iptr(42)
4470  iptr(20) = iptr(20) + 1
4471  DO 500 j = 1, 20
4472  itbld(j,iptr(20)) = itbld2(j,i)
4473  mptrd = mod(itbld(j,iptr(20)),16384)
4474  kptrd(mptrd) = iptr(20)
4475  500 CONTINUE
4476  1000 CONTINUE
4477 C =======================================================
4478  iptr(42) = 0
4479 C PRINT *,'MERGED TABLE D -- FI8819-B',IPTR(20),IPTR(42)
4480 C DO 6000 I = 1, IPTR(20)
4481 C WRITE (6,6001)I,(ITBLD(J,I),J=1,20)
4482 C6001 FORMAT(15(1X,I5))
4483 C6000 CONTINUE
4484  RETURN
4485  END
4486  SUBROUTINE fi8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
4487 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
4488 C . . . .
4489 C SUBPROGRAM: FI8820 READ IN BUFR TABLE D
4490 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-06
4491 C
4492 C ABSTRACT: READ IN BUFR TABLE D
4493 C
4494 C PROGRAM HISTORY LOG:
4495 C 93-05-06 CAVANAUGH
4496 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
4497 C
4498 C USAGE: CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
4499 C INPUT ARGUMENT LIST:
4500 C IUNITD - UNIT NUMBER FOR TABLE D INPUT
4501 C IPTR - ARRAY OF WORKING VALUES
4502 C
4503 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
4504 C ITBLD - ARRAY TO CONTAIN TABLE D
4505 C
4506 C REMARKS:
4507 C
4508 C ATTRIBUTES:
4509 C LANGUAGE: FORTRAN 77
4510 C MACHINE: NAS
4511 C
4512 C$$$
4513 C ..................................................
4514 C
4515 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
4516 C
4517  INTEGER ITBLD2(20,*)
4518 C ..................................................
4519 C
4520 C NEW BASE TABLE D
4521 C
4522  INTEGER ITBLD(20,*)
4523 C ..................................................
4524 C
4525  INTEGER IHOLD(33),IPTR(*),KPTRD(*)
4526  LOGICAL MORE
4527 
4528  SAVE
4529 C
4530  MORE = .true.
4531  i = 0
4532 C
4533 C READ IN TABLE D, BUT JUST ONCE
4534 C PRINT *,'TABLE D SWITCH=',IPTR(20),' ANCILLARY D SW=',IPTR(42)
4535  IF (iptr(20).EQ.0) THEN
4536  DO 1000 mm = 1, 16384
4537  kptrd(mm) = -1
4538  1000 CONTINUE
4539  ierr = 0
4540  print *,'FI8820 - READING TABLE D'
4541  key = 0
4542  100 CONTINUE
4543 C READ NEXT TABLE D ENTRY
4544  READ(iunitd,15,err=9998,END=9000)(IHOLD(M),M=1,33)
4545  15 FORMAT(11(i1,i2,i3,1x),3x)
4546 C BUILD KEY FROM MASTER D ENTRY
4547 C INSERT NEW MASTER INTO TABLE B
4548  i = i + 1
4549  iptr(20) = iptr(20) + 1
4550  DO 25 jj = 1, 41, 3
4551  kk = (jj/3) + 1
4552  IF (jj.LE.31) THEN
4553  itbld(kk,i) = ihold(jj)*16384 +
4554  * ihold(jj+1)*256 + ihold(jj+2)
4555  IF (itbld(kk,i).LT.1.OR.itbld(kk,i).GT.65535) THEN
4556  itbld(kk,i) = 0
4557  GO TO 25
4558  END IF
4559  ELSE
4560  itbld(kk,i) = 0
4561  END IF
4562  25 CONTINUE
4563  mptrd = mod(itbld(1,i),16384)
4564  kptrd(mptrd) = i
4565  50 CONTINUE
4566 C WRITE (6,51)I,(ITBLD(L,I),L=1,15)
4567  51 FORMAT (7h tabled,16(1x,i5))
4568  GO TO 100
4569  ELSE
4570 C PRINT *,'TABLE D IS IN PLACE'
4571  END IF
4572  GO TO 9999
4573  9000 CONTINUE
4574  CLOSE(unit=iunitd,status='KEEP')
4575  GO TO 9999
4576  9998 CONTINUE
4577  iptr(1) = 8
4578 C
4579  9999 CONTINUE
4580 C PRINT *,'THERE ARE',IPTR(20),' ENTRIES IN TABLE D'
4581  RETURN
4582  END
gbyte
subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
This is the fortran version of gbyte.
Definition: gbyte.f:27
gbytes
subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
Program history log:
Definition: gbytes.f:26
mova2i
integer function mova2i(a)
This Function copies a bit string from a Character*1 variable to an integer variable.
Definition: mova2i.f:25
w3ai39
subroutine w3ai39(NFLD, N)
translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
Definition: w3ai39.f:26
w3fc05
subroutine w3fc05(U, V, DIR, SPD)
Given the true (Earth oriented) wind components compute the wind direction and speed.
Definition: w3fc05.f:29
w3fi01
subroutine w3fi01(LW)
Determines the number of bytes in a full word for the particular machine (IBM or cray).
Definition: w3fi01.f:19
fi8806
subroutine fi8806(IPTR, LX, LY, IDENT, MSGA, KDATA, IVALS, MSTACK, IWIDE1, IRFVL1, ISCAL1, J, LL, KFXY1, IWORK, JDESC, MAXR, MAXD, KPTRB)
Process operator descriptors.
Definition: w3fi88.f:2149
fi8811
subroutine fi8811(IPTR, IDENT, MSTACK, KDATA, KNR, LDATA, LSTACK, MAXD, MAXR)
Expand data/descriptor replication.
Definition: w3fi88.f:3249
fi8803
subroutine fi8803(IPTR, IDENT, MSGA, KDATA, IVALS, MSTACK, IWIDE1, IRFVL1, ISCAL1, J, JDESC, MAXR, MAXD)
Process compressed data.
Definition: w3fi88.f:1414
fi8808
subroutine fi8808(IPTR, IWORK, LF, LX, LY, JDESC)
Program history log:
Definition: w3fi88.f:2459
fi8809
subroutine fi8809(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
Reformat profiler w hgt increments.
Definition: w3fi88.f:2517
fi8805
subroutine fi8805(IPTR, IDENT, MSGA, IWORK, LX, LY, KDATA, LL, KNR, MSTACK, MAXR, MAXD)
Process a replication descriptor.
Definition: w3fi88.f:1941
fi8802
subroutine fi8802(IPTR, IDENT, MSGA, KDATA, KFXY1, LL, MSTACK, AUNIT1, IWIDE1, IRFVL1, ISCAL1, JDESC, IVALS, J, MAXR, MAXD, KPTRB)
Process element descriptor.
Definition: w3fi88.f:1309
fi8804
subroutine fi8804(IPTR, MSGA, KDATA, IVALS, MSTACK, IWIDE1, IRFVL1, ISCAL1, J, LL, JDESC, MAXR, MAXD)
Process serial data.
Definition: w3fi88.f:1733
fi8807
subroutine fi8807(IPTR, IWORK, ITBLD, ITBLD2, JDESC, KPTRD)
Process queue descriptor.
Definition: w3fi88.f:2372
w3fi88
subroutine w3fi88(IPTR, IDENT, MSGA, ISTACK, MSTACK, KDATA, KNR, INDEX, LDATA, LSTACK, MAXR, MAXD, IUNITB, IUNITD)
This set of routines will decode a bufr message and place information extracted from the bufr message...
Definition: w3fi88.f:439
fi8810
subroutine fi8810(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
Reformat profiler edition 2 data.
Definition: w3fi88.f:2911
fi8801
subroutine fi8801(IPTR, IDENT, MSGA, ISTACK, IWORK, KDATA, IVALS, MSTACK, KNR, INDEX, MAXR, MAXD, KFXY1, ANAME1, AUNIT1, ISCAL1, IRFVL1, IWIDE1, IRF1SW, INEWVL, KFXY2, ANAME2, AUNIT2, ISCAL2, IRFVL2, IWIDE2, KFXY3, ANAME3, AUNIT3, ISCAL3, IRFVL3, IWIDE3, IUNITB, IUNITD, ITBLD, ITBLD2, KPTRB, KPTRD)
Data extraction.
Definition: w3fi88.f:973