NCEPLIBS-w3emc  2.11.0
w3fi78.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 substes 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 88-08-31
17 C> - Bill Cavanaugh 90-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 91-01-18 Program/routines modified to properly handle
25 C> serial profiler data.
26 C> - Bill Cavanaugh 91-04-04 Modified to handle text supplied thru
27 C> descriptor 2 05 yyy.
28 C> - Bill Cavanaugh 91-04-17 Errors in extracting and scaling data
29 C> corrected. Improved handling of nested queue descriptors is added.
30 C> - Bill Cavanaugh 91-05-10 Array 'data' has been enlarged to real*8
31 C> to better contain very large numbers more accurately. the preious size
32 C> real*4 could not contain sufficient significant digits. Coding has been
33 C> introduced to process new table c descriptor 2 06 yyy which permits in
34 C> line processing of a local descriptor even if the descriptor is not
35 C> contained in the users table b. A second routine to process ifod messages
36 C> (ifod0) has been removed in favor of the improved processing of the one
37 C> remaining (ifod1). New coding has been introduced to permit processing of
38 C> BUFR messages based on BUFR edition up to and including edition 2. Please
39 C> note increased size requirements for arrays ident(20) and iptr(40).
40 C> - Bill Cavanaugh 91-07-26 Add array mtime to calling sequence to
41 C> permit inclusion of receipt/transfer times to ifod messages.
42 C> - Bill Cavanaugh 91-09-25 All processing of decoded BUFR data into
43 C> ifod (a local use reformat of BUFR data) has been isolated from this set
44 C> of routines. For those interested in the ifod form, see w3fl05() in the
45 C> w3lib routines.
46 C> Processing of BUFR messages containing delayed replication has been altered
47 C> so that single subsets (reports) and and a matching descriptor list for
48 C> that particular subset will be passed to the user will be passed to the
49 C> user one at a time to assure that each subset can be fully defined with a
50 C> minimum of reprocessing.
51 C> Processing of associated fields has been tested with messages containing
52 C> non-compressed data.
53 C> In order to facilitate user processing a matching list of scale factors are
54 C> included with the expanded descriptor list (mstack).
55 C> - Bill Cavanaugh 91-11-21 Processing of descriptor 2 03 yyy
56 C> has corrected to agree with fm94 standards.
57 C> - Bill Cavanaugh 91-12-19 Calls to fi7803() and fi7804() have been
58 C> corrected to agree called program argument list. Some additional entries
59 C> have been included for communicating with data access routines. Additional
60 C> error exit provided for the case where table b is damaged.
61 C> - Bill Cavanaugh 92-01-24 Routines fi7801(), fi7803() and fi7804()
62 C> have been modified to handle associated fields all descriptors are set to
63 C> echo to mstack(1,n)
64 C> - Bill Cavanaugh 92-05-21 Further expansion of information collected
65 C> from within upper air soundings has produced the necessity to expand some
66 C> of the processing and output arrays. (see remarks below)
67 C> - Bill Cavanaugh 92-06-29 Corrected descriptor denoting height of
68 C> each wind level for profiler conversions.
69 C> - Bill Cavanaugh 92-07-23 Expansion of table b requires adjustment
70 C> of arrays to contain table b values needed to assist in the decoding
71 C> process.
72 C> ARRAYS CONTAINING DATA FROM TABLE B
73 C> - KDESC Descriptor
74 C> - ANAME Descriptor name
75 C> - AUNITS Units for descriptor
76 C> - MSCALE Scale for value of descriptor
77 C> - MREF Reference value for descriptor
78 C> - MWIDTH Bit width for value of descriptor
79 C> - Bill Cavanaugh 92-09-09 First encounter with operator descriptor
80 C> 2 05 yyy showed error in decoding. That error is corrected with this
81 C> implementation. Further testing of upper air data has encountered
82 C> the condition of large (many level) soundings arrays in the decoder have
83 C> been expanded (again) to allow for this condition.
84 C> - Bill Cavanaugh 92-10-02 Modified routine to reformat profiler data
85 C> (fi7809) to show descriptors, scale value and data in proper order.
86 C> Corrected an error that prevented user from assigning the second dimension
87 C> of kdata(500,*).
88 C> - Bill Cavanaugh 92-10-20 Removed error that prevented full implementation
89 C> of previous corrections and made corrections to table b to bring it up to
90 C> date. changes include proper reformat of profiler data and user capability
91 C> for assigning second dimension of kdata array.
92 C> - Bill Cavanaugh 92-12-09 Thanks to dennis keyser for the suggestions and
93 C> coding, this implementation will allow the inclusion of unit numbers for
94 C> tables b & d, and in addition allows for realistic sizing of kdata and
95 C> mstack arrays by the user. As of this implementation, the upper size limit
96 C> for a BUFR message allows for a message size greater than 10000 bytes.
97 C> - Bill Cavanaugh 93-01-26 Subroutine fi7810() has been added to permit
98 C> reformatting of profiler data in edition 2.
99 C>
100 C> @param[in] MSGA Array containing supposed BUFR message size is determined
101 C> by user, can be greater than 10000 bytes.
102 C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
103 C> a BUFR message.
104 C> @param[in] MAXD Maximum number of descriptor combinations that may be
105 C> processed; Upper air data and some satellite data require a value for maxd
106 C> of 1600, but for most other data a value for maxd of 500 will suffice.
107 C> @param[in] IUNITB Unit number of data set holding table b
108 C> @param[in] IUNITD Unit number of data set holding table d
109 C> @param KNR
110 C> @param[out] ISTACK Original array of descriptors extracted from source
111 C> BUFR message.
112 C> @param[out] MSTACK (A,B)
113 C> - Level b - descriptor number (limited to value of
114 C> input argument maxd)
115 C> - level a = 1 descriptor = 2 10**N Scaling to return to original value
116 C> @param[out] IPTR Utility array
117 C> - IPTR( 1)- Error return.
118 C> - IPTR( 2)- Byte count section 1.
119 C> - IPTR( 3)- Pointer to start of section 1.
120 C> - IPTR( 4)- Byte count section 2.
121 C> - IPTR( 5)- Pointer to start of section 2.
122 C> - IPTR( 6)- Byte count section 3.
123 C> - IPTR( 7)- Pointer to start of section 3.
124 C> - IPTR( 8)- Byte count section 4.
125 C> - IPTR( 9)- Pointer to start of section 4.
126 C> - IPTR(10)- Start of requested subset, reserved for dar.
127 C> - IPTR(11)- Current descriptor ptr in iwork.
128 C> - IPTR(12)- Last descriptor pos in iwork.
129 C> - IPTR(13)- Last descriptor pos in istack.
130 C> - IPTR(14)- Number of table b entries.
131 C> - IPTR(15)- Requested subset pointer, reserved for dar.
132 C> - IPTR(16)- Indicator for existance of section 2.
133 C> - IPTR(17)- Number of reports processed.
134 C> - IPTR(18)- Ascii/text event.
135 C> - IPTR(19)- Pointer to start of BUFR message.
136 C> - IPTR(20)- Number of lines from table d.
137 C> - IPTR(21)- Table b switch.
138 C> - IPTR(22)- Table d switch.
139 C> - IPTR(23)- Code/flag table switch.
140 C> - IPTR(24)- Aditional words added by text info.
141 C> - IPTR(25)- Current bit number.
142 C> - IPTR(26)- Data width change.
143 C> - IPTR(27)- Data scale change.
144 C> - IPTR(28)- Data reference value change.
145 C> - IPTR(29)- Add data associated field.
146 C> - IPTR(30)- Signify characters.
147 C> - IPTR(31)- Number of expanded descriptors in mstack.
148 C> - IPTR(32)- Current descriptor segment f.
149 C> - IPTR(33)- Current descriptor segment x.
150 C> - IPTR(34)- Current descriptor segment y.
151 C> - IPTR(35)- Unused.
152 C> - IPTR(36)- Next descriptor may be undecipherable.
153 C> - IPTR(37)- Unused.
154 C> - IPTR(38)- Unused.
155 C> - IPTR(39)- Delayed replication flag.
156 C> - 0 No delayed replication.
157 C> - 1 Message contains delayed replication.
158 C> - IPTR(40)- Number of characters in text for curr descriptor.
159 C> @param[out] IDENT Array contains message information extracted from BUFR
160 C> Message.
161 C> - IDENT(1) Edition number (byte 4, section 1)
162 C> - IDENT(2) Originating center (bytes 5-6, section 1)
163 C> - IDENT(3) Update sequence (byte 7, section 1)
164 C> - IDENT(4) Optional section (byte 8, section 1)
165 C> - IDENT(5) BUFR message type (byte 9, section 1)
166 C> - 0 = Surface (land).
167 C> - 1 = Surface (ship).
168 C> - 2 = Vertical soundings other than satellite.
169 C> - 3 = Vertical soundings (satellite).
170 C> - 4 = Sngl lvl upper-air other than satellite.
171 C> - 5 = Sngl lvl upper-air (satellite).
172 C> - 6 = Radar.
173 C> - IDENT(6) BUFR msg sub-type (byte 10, section 1).
174 C> | TYPE | SBTYP |
175 C> | :--- | :---- |
176 C> | 2 | 7 = PROFILER |
177 C> - IDENT(7) (bytes 11-12, section 1).
178 C> - IDENT(8) Year of century (byte 13, section 1).
179 C> - IDENT(9) Month of year (byte 14, section 1).
180 C> - IDENT(10) Day of month (byte 15, section 1).
181 C> - IDENT(11) Hour of day (byte 16, section 1).
182 C> - IDENT(12) Minute of hour (byte 17, section 1).
183 C> - IDENT(13) Rsvd by adp centers (byte 18, section 1).
184 C> - IDENT(14) Nr of data subsets (byte 5-6, section 3).
185 C> - IDENT(15) Observed flag (byte 7, bit 1, section 3).
186 C> - IDENT(16) Compression flag (byte 7, bit 2, section 3).
187 C> - IDENT(17) Master table number(byte 4, section 1, ed 2 or gtr).
188 C> @param[out] KDATA Array containing decoded reports from BUFR message.
189 C> KDATA(report number,parameter number)
190 C> (Report number limited to value of input argument maxr and parameter number
191 C> limited to value of input argument maxd)
192 C> Arrays containing data from table b:
193 C> - ANAME Descriptor name
194 C> - AUNITS Units for descriptor
195 C> - MSCALE Scale for value of descriptor
196 C> - MREF Reference value for descriptor
197 C> - MWIDTH Bit width for value of descriptor
198 C> @param[out] INDEX Pointer to available subset
199 C>
200 C> Error returns:
201 C> IPTR(1):
202 C> - 1 'BUFR' Not found in first 125 characters
203 C> - 2 '7777' Not found in location determined by
204 C> by using counts found in each section. one or
205 C> more sections have an erroneous byte count or
206 C> characters '7777' are not in test message.
207 C> - 3 Message contains a descriptor with f=0 that does
208 C> not exist in table b.
209 C> - 4 Message contains a descriptor with f=3 that does
210 C> not exist in table d.
211 C> - 5 Message contains a descriptor with f=2 with the
212 C> value of x outside the range 1-5.
213 C> - 6 Descriptor element indicated to have a flag value
214 C> does not have an entry in the flag table.
215 C> (to be activated)
216 C> - 7 Descriptor indicated to have a code value does
217 C> not have an entry in the code table.
218 C> (to be activated)
219 C> - 8 Error reading table d
220 C> - 9 Error reading table b
221 C> - 10 Error reading code/flag table
222 C> - 11 Descriptor 2 04 004 not followed by 0 31 021
223 C> - 12 Data descriptor operator qualifier does not follow
224 C> delayed replication descriptor.
225 C> - 13 Bit width on ascii characters not a multiple of 8
226 C> - 14 Subsets = 0, no content bulletin
227 C> - 20 Exceeded count for delayed replication pass
228 C> - 21 Exceeded count for non-delayed replication pass
229 C> - 27 Non zero lowest on text data
230 C> - 28 Nbinc not nr of characters
231 C> - 29 Table b appears to be damaged
232 C> - 99 No more subsets (reports) available in current
233 C> BUFR mesage
234 C> - 400 Number of subsets exceeds the value of input
235 C> argument maxr; must increase maxr to value of
236 C> ident(14) in calling program
237 C> - 401 Number of parameters (and associated fields)
238 C> exceeds limits of this program.
239 C> - 500 Value for nbinc has been found that exceeds
240 C> standard width plus any bit width change.
241 C> check all bit widths up to point of error.
242 C> - 501 Corrected width for descriptor is 0 or less
243 C>
244 C> On the initial call to w3fi78() with a BUFR message the argument
245 C> index must be set to zero (index = 0). On the return from w3fi78()
246 C> 'index' will be set to the next available subset/report. When
247 C> there are no more subsets available a 99 err return will occur.
248 C>
249 C> If the original BUFR message does not contain delayed replication
250 C> the BUFR message will be completely decoded and 'index' will point
251 C> to the first decoded subset. The users will then have the option
252 C> of indexing through the subsets on their own or by recalling this
253 C> routine (without resetting 'index') to have the routine do the
254 C> indexing.
255 C>
256 C> If the original BUFR message does contain delayed replication
257 C> one subset/report will be decoded at a time and passed back to
258 C> the user. This is not an option.
259 C>
260 C> =============================================
261 C> TO USE THIS ROUTINE
262 C> --------------------------------
263 C> - 1. Read in BUFR message
264 C> - 2. Set index = 0
265 C> - 3. CALL W3FI78()
266 C> - 4.
267 C> @code
268 C> IF (IPTR(1).EQ.99) THEN
269 C> NO MORE SUBSETS
270 C> EITHER GO TO 1
271 C> OR TERMINATE IN NO MORE BUFR MESSAGES
272 C> END IF
273 C> @endcode
274 C> - 5.
275 C> @code
276 C> IF (IPTR(1).NE.0) THEN
277 C> ERROR CONDITION
278 C> EITHER GO TO 1
279 C> OR TERMINATE IN NO MORE BUFR MESSAGES
280 C> END IF
281 C> @endcode
282 C> - 6. The value of index indicates the active subset so
283 C> @code
284 C> IF INTERESTED IN GENERATING AN IFOD MESSAGE
285 C> W3FL05 ( )
286 C> ELSE
287 C> PROCESS DECODED INFORMATION AS REQUIRED
288 C> END IF
289 C> @endcode
290 C> - 7. GO TO 3
291 C>
292 C> The arrays to contain the output information are defined as follows:
293 C> - KDATA(A,B) Is the a data entry (integer value) where a is the maximum
294 C> number of reports/subsets that may be contained in the bufr message (this
295 C> is now set to "maxr" which is passed as an input argument to w3fi78()), and
296 C> where b is the maximum number of descriptor combinations that may be
297 C> processed (this is now set to "maxd" which is also passed as an input
298 C> argument to w3fi78(); Upper air data and some satellite data require a
299 C> value for maxd of 1600, but for most other data a value for maxd of 500
300 C> will suffice).
301 C> - MSTACK(1,B) Contains the descriptor that matches the data entry (max.
302 C> value for b is now "maxd" which is passed as an input argument to w3fi78())
303 C> - MSTACK(2,B) Is the scale (power of 10) to be applied to the data (max.
304 C> value for b is now "maxd" which is passed as an input argument to w3fi78())
305 C>
306 C> @author Bill Cavanaugh @date 1988-08-31
307  SUBROUTINE w3fi78(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
308  * MAXR,MAXD,IUNITB,IUNITD)
309 C
310  CHARACTER*40 ANAME(700)
311  CHARACTER*24 AUNITS(700)
312 C
313 C
314 C
315  INTEGER MSGA(*)
316  INTEGER IPTR(*)
317  INTEGER KDATA(MAXR,MAXD)
318  INTEGER MSTACK(2,MAXD)
319 C
320  INTEGER IVALS(1000)
321  INTEGER KNR(MAXR)
322  INTEGER IDENT(*)
323  INTEGER KDESC(2000)
324  INTEGER ISTACK(*)
325  INTEGER IWORK(2000)
326  INTEGER MSCALE(700)
327  INTEGER MREF(700,3)
328  INTEGER MWIDTH(700)
329  INTEGER INDEX
330 C
331  CHARACTER*4 DIRID(2)
332 C
333  LOGICAL SEC2
334 C
335  SAVE
336 C
337 C PRINT *,' W3FI78 DECODER'
338 C INITIALIZE ERROR RETURN
339  iptr(1) = 0
340  IF (index.GT.0) THEN
341 C HAVE RE-ENTRY
342  index = index + 1
343 C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
344  IF (index.GT.ident(14)) THEN
345 C ALL SUBSETS PROCESSED
346  iptr(1) = 99
347  iptr(39) = 0
348  ELSE IF (index.LE.ident(14)) THEN
349  IF (iptr(39).NE.0) THEN
350  CALL fi7801(iptr,ident,msga,istack,iwork,aname,kdata,
351 C
352  * ivals,mstack,
353  * aunits,kdesc,mwidth,mref,mscale,knr,index,maxr,maxd,
354  * iunitb,iunitd)
355 C
356  END IF
357  END IF
358  RETURN
359  ELSE
360  index = 1
361 C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
362  END IF
363  iptr(39) = 0
364 C FIND 'BUFR' IN FIRST 125 CHARACTERS
365  DO 1000 knofst = 0, 999, 8
366  inofst = knofst
367  CALL gbyte (msga,ivals,inofst,8)
368  IF (ivals(1).EQ.66) THEN
369  iptr(19) = inofst
370  inofst = inofst + 8
371  CALL gbyte (msga,ivals,inofst,24)
372  IF (ivals(1).EQ.5588562) THEN
373 C PRINT *,'FOUND BUFR AT',IPTR(19)
374  inofst = inofst + 24
375  GO TO 1500
376  END IF
377  END IF
378  1000 CONTINUE
379  print *,'BUFR - START OF BUFR MESSAGE NOT FOUND'
380  iptr(1) = 1
381  RETURN
382  1500 CONTINUE
383  ident(1) = 0
384 C TEST FOR EDITION NUMBER
385 C ======================
386  CALL gbyte (msga,ident(1),inofst+24,8)
387 C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE'
388 C
389  IF (ident(1).GE.2) THEN
390 C GET TOTAL COUNT
391  CALL gbyte (msga,ivals,inofst,24)
392  itotal = ivals(1)
393  kender = itotal * 8 - 32 + iptr(19)
394  CALL gbyte (msga,ilast,kender,32)
395 C IF (ILAST.EQ.926365495) THEN
396 C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
397 C END IF
398  inofst = inofst + 32
399 C GET SECTION 1 COUNT
400  iptr(3) = inofst
401  CALL gbyte (msga,ivals,inofst,24)
402 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
403  inofst = inofst + 24
404  iptr( 2) = ivals(1)
405 C GET MASTER TABLE
406  CALL gbyte (msga,ivals,inofst,8)
407  inofst = inofst + 8
408  ident(17) = ivals(1)
409 C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
410  ELSE
411  iptr(3) = inofst
412 C GET SECTION 1 COUNT
413  CALL gbyte (msga,ivals,inofst,24)
414 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
415  inofst = inofst + 32
416  iptr( 2) = ivals(1)
417  END IF
418 C ======================
419 C ORIGINATING CENTER
420  CALL gbyte (msga,ivals,inofst,16)
421  inofst = inofst + 16
422  ident(2) = ivals(1)
423 C UPDATE SEQUENCE
424  CALL gbyte (msga,ivals,inofst,8)
425  inofst = inofst + 8
426  ident(3) = ivals(1)
427 C OPTIONAL SECTION FLAG
428  CALL gbyte (msga,ivals,inofst,1)
429  ident(4) = ivals(1)
430  IF (ident(4).GT.0) THEN
431  sec2 = .true.
432  ELSE
433 C PRINT *,' NO OPTIONAL SECTION 2'
434  sec2 = .false.
435  END IF
436  inofst = inofst + 8
437 C MESSAGE TYPE
438  CALL gbyte (msga,ivals,inofst,8)
439  ident(5) = ivals(1)
440  inofst = inofst + 8
441 C MESSAGE SUB-TYPE
442  CALL gbyte (msga,ivals,inofst,8)
443  ident(6) = ivals(1)
444  inofst = inofst + 8
445 C IF BUFR EDITION 0 OR 1 THEN
446 C NEXT 2 BYTES ARE BUFR TABLE VERSION
447 C ELSE
448 C BYTE 11 IS VER NR OF MASTER TABLE
449 C BYTE 12 IS VER NR OF LOCAL TABLE
450  IF (ident(1).LT.2) THEN
451  CALL gbyte (msga,ivals,inofst,16)
452  ident(7) = ivals(1)
453  inofst = inofst + 16
454  ELSE
455 C BYTE 11 IS VER NR OF MASTER TABLE
456  CALL gbyte (msga,ivals,inofst,8)
457  ident(18) = ivals(1)
458  inofst = inofst + 8
459 C BYTE 12 IS VER NR OF LOCAL TABLE
460  CALL gbyte (msga,ivals,inofst,8)
461  ident(19) = ivals(1)
462  inofst = inofst + 8
463 
464  END IF
465 C YEAR OF CENTURY
466  CALL gbyte (msga,ivals,inofst,8)
467  ident(8) = ivals(1)
468  inofst = inofst + 8
469 C MONTH
470  CALL gbyte (msga,ivals,inofst,8)
471  ident(9) = ivals(1)
472  inofst = inofst + 8
473 C DAY
474 C PRINT *,'DAY AT ',INOFST
475  CALL gbyte (msga,ivals,inofst,8)
476  ident(10) = ivals(1)
477  inofst = inofst + 8
478 C HOUR
479  CALL gbyte (msga,ivals,inofst,8)
480  ident(11) = ivals(1)
481  inofst = inofst + 8
482 C MINUTE
483  CALL gbyte (msga,ivals,inofst,8)
484  ident(12) = ivals(1)
485 C RESET POINTER (INOFST) TO START OF
486 C NEXT SECTION
487 C (SECTION 2 OR SECTION 3)
488  inofst = iptr(3) + iptr(2) * 8
489  iptr(4) = 0
490  iptr(5) = inofst
491  IF (sec2) THEN
492 C SECTION 2 COUNT
493  CALL gbyte (msga,iptr(4),inofst,24)
494  inofst = inofst + 32
495 C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
496  kentry = (iptr(4) - 4) / 14
497 C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS'
498  IF (ident(2).EQ.7) THEN
499  DO 2000 i = 1, kentry
500  CALL gbyte (msga,kdspl ,inofst,16)
501  inofst = inofst + 16
502  CALL gbyte (msga,lat ,inofst,16)
503  inofst = inofst + 16
504  CALL gbyte (msga,lon ,inofst,16)
505  inofst = inofst + 16
506  CALL gbyte (msga,kdahr ,inofst,16)
507  inofst = inofst + 16
508  CALL gbyte (msga,dirid(1),inofst,32)
509  inofst = inofst + 32
510  CALL gbyte (msga,dirid(2),inofst,16)
511  inofst = inofst + 16
512 C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
513  2000 CONTINUE
514  END IF
515 C RESET POINTER (INOFST) TO START OF
516 C SECTION 3
517  inofst = iptr(5) + iptr(4) * 8
518  END IF
519 C BIT OFFSET TO START OF SECTION 3
520  iptr( 7) = inofst
521 C SECTION 3 COUNT
522  CALL gbyte (msga,iptr(6),inofst,24)
523 C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6)
524  inofst = inofst + 24
525 C SKIP RESERVED BYTE
526  inofst = inofst + 8
527 C NUMBER OF DATA SUBSETS
528  CALL gbyte (msga,ident(14),inofst,16)
529 C
530  IF (ident(14).GT.maxr) THEN
531  print *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',maxr
532  print *,'PASSED INTO W3FI78; MAXR MUST BE INCREASED IN '
533  print *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF'
534  print *,ident(14),'TO BE ABLE TO PROCESS THIS DATA'
535 C
536  iptr(1) = 400
537  RETURN
538  END IF
539  inofst = inofst + 16
540 C OBSERVED DATA FLAG
541  CALL gbyte (msga,ivals,inofst,1)
542  ident(15) = ivals(1)
543  inofst = inofst + 1
544 C COMPRESSED DATA FLAG
545  CALL gbyte (msga,ivals,inofst,1)
546  ident(16) = ivals(1)
547  inofst = inofst + 7
548 C CALCULATE NUMBER OF DESCRIPTORS
549  nrdesc = (iptr( 6) - 8) / 2
550  iptr(12) = nrdesc
551  iptr(13) = nrdesc
552 C EXTRACT DESCRIPTORS
553  CALL gbytes (msga,istack,inofst,16,0,nrdesc)
554 C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
555  DO 10 l = 1, nrdesc
556  iwork(l) = istack(l)
557 C PRINT *,L,ISTACK(L)
558  10 CONTINUE
559  iptr(13) = nrdesc
560 C RESET POINTER TO START OF SECTION 4
561  inofst = iptr(7) + iptr(6) * 8
562 C BIT OFFSET TO START OF SECTION 4
563  iptr( 9) = inofst
564 C SECTION 4 COUNT
565  CALL gbyte (msga,ivals,inofst,24)
566 C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
567  iptr( 8) = ivals(1)
568  inofst = inofst + 32
569 C SET FOR STARTING BIT OF DATA
570  iptr(25) = inofst
571 C FIND OUT IF '7777' TERMINATOR IS THERE
572  inofst = iptr(9) + iptr(8) * 8
573  CALL gbyte (msga,ivals,inofst,32)
574 C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1)
575  IF (ivals(1).NE.926365495) THEN
576  print *,'BAD SECTION COUNT'
577  iptr(1) = 2
578  RETURN
579  ELSE
580  iptr(1) = 0
581  END IF
582 C
583  CALL fi7801(iptr,ident,msga,istack,iwork,aname,kdata,ivals,mstack,
584  * aunits,kdesc,mwidth,mref,mscale,knr,index,maxr,maxd,
585  * iunitb,iunitd)
586 C
587 C PRINT *,'HAVE RETURNED FROM FI7801'
588 C IF (IPTR(1).NE.0) THEN
589 C RETURN
590 C END IF
591 C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
592  IF (ident(5).EQ.2) THEN
593  IF (ident(6).EQ.7) THEN
594 C PRINT *,'BASIC PROFILER DATA'
595 C DO 153 I = 1, KNR(INDEX)
596 C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
597 C 153 CONTINUE
598 C PRINT *,'REFORMAT PROFILER DATA'
599 C
600  IF (ident(1).LT.2) THEN
601  CALL fi7809(ident,mstack,kdata,iptr,maxr,maxd)
602  ELSE
603  CALL fi7810(ident,mstack,kdata,iptr,maxr,maxd)
604  END IF
605 C DO 151 I = 1, 40
606 C IF (I.LE.20) THEN
607 C PRINT *,'IPTR(',I,')=',IPTR(I),
608 C * ' IDENT(',I,')= ',IDENT(I)
609 C ELSE
610 C PRINT *,'IPTR(',I,')=',IPTR(I)
611 C END IF
612 C 151 CONTINUE
613  IF (iptr(1).NE.0) THEN
614  RETURN
615  END IF
616 C
617 C DO 154 I = 1, IPTR(31)
618 C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
619 C 154 CONTINUE
620  END IF
621  END IF
622  RETURN
623  END
624 C
625 C> @brief Data extraction
626 C> @author Bill Cavanaugh @date 1988-09-01
627 
628 C> Control the extraction of data from section 4 based on data descriptors.
629 C>
630 C> Program history log:
631 C> - Bill Cavanaugh 1988-09-01
632 C> - Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed
633 C> data.
634 C> - Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with
635 C> delayed replication.
636 C> - Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
637 C>
638 C> @param[in] IPTR See w3fi78() routine docblock
639 C> @param[in] IDENT See w3fi78() routine docblock
640 C> @param[in] MSGA Array containing bufr message
641 C> @param[inout] ISTACK Original array of descriptors extracted from
642 C> source bufr message.
643 C> @param[in] MSTACK Working array of descriptors (expanded)and scaling
644 C> factor
645 C> @param[inout] KDESC Image of current descriptor
646 C> @param[in] INDEX
647 C> @param[in] MAXR maximum number of reports/subsets that may be
648 C> contained in a bufr message
649 C> @param[in] MAXD Maximum number of descriptor combinations that
650 C> may be processed; upper air data and some satellite data require a value
651 C> for maxd of 1600, but for most other data a value for maxd of 500 will suffice
652 C> @param[in] IUNITB Unit number of data set holding table b
653 C> @param[in] IUNITD Unit number of data set holding table d
654 C> @param[out] IWORK Working descriptor list
655 C> @param[out] KDATA Array containing decoded reports from bufr message.
656 C> KDATA(Report number,parameter number)
657 C> (report number limited to value of input argument maxr and parameter
658 C> number limited to value of input argument maxd)
659 C> arrays containing data from table b
660 C> @param[out] ANAME Descriptor name
661 C> @param[out] AUNITS Units for descriptor
662 C> @param[out] MSCALE Scale for value of descriptor
663 C> @param[out] MREF Reference value for descriptor
664 C> @param[out] MWIDTH Bit width for value of descriptor
665 C> @param IVALS
666 C> @param KNR
667 C>
668 C> Error return:
669 C> IPTR(1)
670 C> - = 8 Error reading table b
671 C> - = 9 Error reading table d
672 C> - = 11 Error opening table b
673 C>
674 C> @author Bill Cavanaugh @date 1988-09-01
675  SUBROUTINE fi7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS,
676  * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD,
677  * IUNITB,IUNITD)
678 
679  SAVE
680 C
681  CHARACTER*40 ANAME(*)
682  CHARACTER*24 AUNITS(*)
683 C
684 C
685  INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*)
686 C
687  INTEGER MSCALE(*),KNR(MAXR)
688  INTEGER LX,LY,LL,J
689  INTEGER MREF(700,3)
690  INTEGER MWIDTH(*)
691  INTEGER IHOLD(33)
692  INTEGER ITBLD(500,11)
693  INTEGER IPTR(*)
694  INTEGER IDENT(*)
695  INTEGER KDESC(*)
696  INTEGER ISTACK(*),IWORK(*)
697 C
698  INTEGER MSTACK(2,MAXD),KK
699 C
700  INTEGER JDESC
701  INTEGER INDEX
702  INTEGER ITEST(30)
703 C
704  DATA itest /1,3,7,15,31,63,127,255,
705  * 511,1023,2047,4095,8191,16383,
706  * 32767, 65535,131071,262143,524287,
707  * 1048575,2097151,4194303,8388607,
708  * 16777215,33554431,67108863,134217727,
709  * 268435455,536870911,1073741823/
710 C
711 C PRINT *,' DECOLL FI7801'
712  IF (index.GT.1) THEN
713  GO TO 1000
714  END IF
715 C --------- DECOLL ---------------
716  iptr(23) = 0
717  iptr(26) = 0
718  iptr(27) = 0
719  iptr(28) = 0
720  iptr(29) = 0
721  iptr(30) = 0
722  iptr(36) = 0
723 C INITIALIZE OUTPUT AREA
724 C SET POINTER TO BEGINNING OF DATA
725 C SET BIT
726  iptr(17) = 1
727  1000 CONTINUE
728 C IPTR(12) = IPTR(13)
729  ll = 0
730  iptr(11) = 1
731  IF (iptr(10).EQ.0) THEN
732 C RE-ENTRY POINT FOR MULTIPLE
733 C NON-COMPRESSED REPORTS
734  ELSE
735  index = iptr(15)
736  iptr(17) = index
737  iptr(25) = iptr(10)
738  iptr(10) = 0
739  iptr(15) = 0
740  END IF
741 C PRINT *,'FI7801 - RPT',IPTR(17),' STARTS AT',IPTR(25)
742  iptr(24) = 0
743  iptr(31) = 0
744 C POINTING AT NEXT AVAILABLE DESCRIPTOR
745  mm = 0
746  IF (iptr(21).EQ.0) THEN
747 C PRINT *,' READING TABLE B'
748  DO 150 i = 1, 700
749  iptr(21) = i
750 C
751  READ(unit=iunitb,fmt=20,err=9999,END=175)MF,
752  * mx,my,
753  * (aname(i)(k:k),k=1,40),
754  * (aunits(i)(k:k),k=1,24),
755  * mscale(i),mref(i,1),mwidth(i)
756  20 FORMAT(i1,i2,i3,40a1,24a1,i5,i15,1x,i4)
757  IF (mwidth(i).EQ.0) THEN
758  iptr(1) = 29
759  RETURN
760  END IF
761  mref(i,2) = 0
762  iptr(14) = i
763  kdesc(i) = mf*16384 + mx*256 + my
764 C PRINT *,I
765 C WRITE(6,21) MF,MX,MY,KDESC(I),
766 C * (ANAME(I)(K:K),K=1,40),
767 C * (AUNITS(I)(K:K),K=1,24),
768 C * MSCALE(I),MREF(I,1),MWIDTH(I)
769  21 FORMAT(1x,i1,i2,i3,1x,i6,1x,40a1,
770  * 2x,24a1,2x,i5,2x,i15,1x,i4)
771  150 CONTINUE
772  print *,'HAVE READ LIMIT OF 700 TABLE B DESCRIPTORS'
773  print *,'IF THERE ARE MORE THAT THAT, CORRECT READ LOOP'
774  175 CONTINUE
775 C
776 C CLOSE(UNIT=IUNITB,STATUS='KEEP')
777 C
778  iptr(21) = 1
779  END IF
780 C DO WHILE MM <= MAXD
781  10 CONTINUE
782 C PROCESS THRU THE FOLLOWING
783 C DEPENDING UPON THE VALUE OF 'F' (LF)
784  mm = mm + 1
785  12 CONTINUE
786  IF (mm.GT.maxd) THEN
787  GO TO 200
788  END IF
789 C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
790  IF (iptr(11).GT.iptr(12)) THEN
791 C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
792  IF (ident(16).NE.0) THEN
793 C PRINT *,' PROCESSING COMPRESSED REPORTS'
794 C REFORMAT DATA FROM DESCRIPTOR
795 C FORM TO USER FORM
796  RETURN
797  ELSE
798 C WRITE (6,1)
799 C 1 FORMAT (1H1)
800 C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25)
801  iptr(17) = iptr(17) + 1
802  IF (iptr(17).GT.ident(14)) THEN
803  iptr(17) = iptr(17) - 1
804  GO TO 200
805  END IF
806  DO 300 i = 1, iptr(13)
807  iwork(i) = istack(i)
808  300 CONTINUE
809 C RESET POINTERS
810  ll = 0
811  iptr(1) = 0
812  iptr(11) = 1
813  iptr(12) = iptr(13)
814 C IS THIS LAST REPORT ?
815 C PRINT *,'READY',IPTR(39),INDEX
816  IF (iptr(39).GT.0) THEN
817  IF (index.GT.0) THEN
818 C PRINT *,'HERE IS SUBSET NR',INDEX
819  RETURN
820  END IF
821  END IF
822  GO TO 1000
823  END IF
824  END IF
825  14 CONTINUE
826 C GET NEXT DESCRIPTOR
827  CALL fi7808 (iptr,iwork,lf,lx,ly,jdesc,maxd)
828 C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
829 C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
830 C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
831 C * ' FOR LOC',IPTR(17),IPTR(25)
832  IF (iptr(11).GT.1600) THEN
833  iptr(1) = 401
834  RETURN
835  END IF
836 C
837  kprm = iptr(31) + iptr(24)
838  IF (kprm.GT.1600) THEN
839  IF (kprm.GT.kold) THEN
840  print *,'EXCEEDED ARRAY SIZE',kprm,iptr(31),
841  * iptr(24)
842  kold = kprm
843  END IF
844  END IF
845 C REPLICATION PROCESSING
846  IF (lf.EQ.1) THEN
847 C ---------- F1 ---------
848  iptr(31) = iptr(31) + 1
849  kprm = iptr(31) + iptr(24)
850  mstack(1,kprm) = jdesc
851  mstack(2,kprm) = 0
852  kdata(iptr(17),kprm) = 0
853 C PRINT *,'FI7801-1',KPRM,MSTACK(1,KPRM),
854 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
855  CALL fi7805(iptr,ident,msga,iwork,lx,ly,
856  * kdata,ll,knr,mstack,maxr,maxd)
857  IF (iptr(1).NE.0) THEN
858  RETURN
859  ELSE
860  GO TO 12
861  END IF
862 C
863 C DATA DESCRIPTION OPERATORS
864  ELSE IF (lf.EQ.2)THEN
865  IF (lx.EQ.5) THEN
866  ELSE IF (lx.EQ.4) THEN
867  iptr(31) = iptr(31) + 1
868  kprm = iptr(31) + iptr(24)
869  mstack(1,kprm) = jdesc
870  mstack(2,kprm) = 0
871  kdata(iptr(17),kprm) = 0
872 C PRINT *,'FI7801-2',KPRM,MSTACK(1,KPRM),
873 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
874  END IF
875  CALL fi7806 (iptr,lx,ly,ident,msga,kdata,ivals,mstack,
876  * mwidth,mref,mscale,j,ll,kdesc,iwork,jdesc,maxr,maxd)
877  IF (iptr(1).NE.0) THEN
878  RETURN
879  END IF
880  GO TO 12
881 C DESCRIPTOR SEQUENCE STRINGS
882  ELSE IF (lf.EQ.3) THEN
883 C PRINT *,'F3 SEQUENCE DESCRIPTOR'
884  IF (iptr(22).EQ.0) THEN
885 C READ IN TABLE D, BUT JUST ONCE
886  ierr = 0
887 C PRINT *,' READING TABLE D'
888  DO 50 i = 1, 500
889  READ(iunitd,15,err=9998,END=75 )
890  * (ihold(j),j=1,33)
891  15 FORMAT(11(i1,i2,i3,1x),3x)
892  iptr(20) = i
893  DO 25 jj = 1, 31, 3
894  kk = (jj/3) + 1
895  itbld(i,kk) = ihold(jj)*16384 +
896  * ihold(jj+1)*256 + ihold(jj+2)
897  IF (itbld(i,kk).EQ.0) THEN
898 C PRINT 16,(ITBLD(I,L),L=1,11)
899  GO TO 50
900  END IF
901  25 CONTINUE
902 C PRINT 16,(ITBLD(I,L),L=1,11)
903  50 CONTINUE
904  16 FORMAT(1x,11(i6,1x))
905  75 CONTINUE
906  CLOSE(unit=iunitd,status='KEEP')
907  iptr(22) = 1
908  ENDIF
909  CALL fi7807(iptr,iwork,itbld,jdesc,maxd)
910  IF (iptr(1).GT.0) THEN
911  RETURN
912  END IF
913  GO TO 14
914 C
915 C STANDARD DESCRIPTOR PROCESSING
916  ELSE
917 C PRINT *,'ENTRY',IPTR(31),JDESC,' AT',IPTR(25)
918  kprm = iptr(31) + iptr(24)
919  CALL fi7802(iptr,ident,msga,kdata,kdesc,ll,mstack,
920  * aunits,mwidth,mref,mscale,jdesc,ivals,j,maxr,maxd)
921 C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR
922  iptr(36) = 0
923  IF (iptr(1).GT.0) THEN
924  RETURN
925  ELSE
926  IF (ident(16).EQ.0) THEN
927  knr(iptr(17)) = iptr(31)
928  ELSE
929  DO 310 kj = 1, maxr
930  knr(kj) = iptr(31)
931  310 CONTINUE
932  END IF
933  GO TO 10
934  END IF
935  END IF
936 C END IF
937 C END DO WHILE
938  200 CONTINUE
939  IF (ident(16).NE.0) THEN
940 C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
941  ELSE
942 C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS'
943  END IF
944  RETURN
945  9998 CONTINUE
946  print *,' ERROR READING TABLE D'
947  iptr(1) = 8
948  RETURN
949  9999 CONTINUE
950  print *,' ERROR READING TABLE B'
951  iptr(1) = 9
952  RETURN
953  END
954 C> @brief Process standard descriptor
955 C> @author Bill Cavanaugh @date 1988-09-01
956 
957 C> Process a standard descriptor (f = 0) and store data
958 C> in output array.
959 C>
960 C> Program history log:
961 C> - Bill Cavanaugh 1988-09-01
962 C> - Bill Cavanaugh 1991-04-04 Changed to pass width of text fields in bytes
963 C>
964 C> @param[in] IPTR See w3fi78 routine docblock
965 C> @param[in] IDENT See w3fi78 routine docblock
966 C> @param[in] MSGA Array containing bufr message
967 C> @param[inout] KDATA Array containing decoded reports from bufr message.
968 C> KDATA(Report number,parameter number)
969 C> (report number limited to value of input argument maxr and parameter
970 C> number limited to value of input argument maxd)
971 C> @param[inout] KDESC Image of current descriptor
972 C> @param[in] MSTACK
973 C> @param[in] MAXR maximum number of reports/subsets that may be contained in
974 C> a bufr message
975 C> @param[in] MAXD Maximum number of descriptor combinations that may be
976 C> processed; upper air data and some satellite data require a value for maxd
977 C> of 1600, but for most other data a value for maxd of 500 will suffice
978 C> Arrays containing data from table B
979 C> @param[out] AUNITS Units for descriptor
980 C> @param[out] MSCALE Scale for value of descriptor
981 C> @param[out] MREF Reference value for descriptor
982 C> @param[out] MWIDTH Bit width for value of descriptor
983 C> @param LL
984 C> @param JDESC
985 C> @param IVALS
986 C> @param J
987 C>
988 C> Error return:
989 C> IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist
990 C> in table b.
991 C>
992 C> @author Bill Cavanaugh @date 1988-09-01
993  SUBROUTINE fi7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS,
994  * MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD)
995  SAVE
996 C TABLE B ENTRY
997  CHARACTER*24 ASKEY
998  CHARACTER*24 AUNITS(*)
999 C TABLE B ENTRY
1000  INTEGER MSGA(*)
1001  INTEGER IPTR(*)
1002  INTEGER IDENT(*)
1003  INTEGER J
1004  INTEGER JDESC
1005  INTEGER KDESC(*)
1006  INTEGER MWIDTH(*),MSTACK(2,MAXD),MSCALE(*)
1007  INTEGER MREF(700,3),KDATA(MAXR,MAXD),IVALS(*)
1008 C TABLE B ENTRY
1009 C
1010  DATA askey /'CCITT IA5 '/
1011 C
1012 C PRINT *,' FI7802 - STANDARD DESCRIPTOR PROCESSOR'
1013 C GET A MATCH BETWEEN CURRENT
1014 C DESCRIPTOR (JDESC) AND
1015 C TABLE B ENTRY
1016 C IF (KDESC(356).EQ.0) THEN
1017 C PRINT *,'FI7802 - KDESC(356) WENT TO ZER0'
1018 C IPTR(1) = 600
1019 C RETURN
1020 C END IF
1021  k = 1
1022  kk = iptr(14)
1023  IF (jdesc.GT.kdesc(kk)) THEN
1024  k = kk + 1
1025  END IF
1026  10 CONTINUE
1027  IF (k.GT.kk) THEN
1028  IF (iptr(36).NE.0) THEN
1029 C HAVE SKIP FLAG
1030  IF (ident(16).NE.0) THEN
1031 C SKIP OVER COMPRESSED DATA
1032 C LOWEST
1033  iptr(25) = iptr(25) + iptr(36)
1034 C NBINC
1035  CALL gbyte (msga,ihold,iptr(25),6)
1036  iptr(25) = iptr(25) + 6
1037  iptr(31) = iptr(31) + 1
1038  kprm = iptr(31) + iptr(24)
1039  mstack(1,kprm) = jdesc
1040  mstack(2,kprm) = 0
1041  DO 50 i = 1, iptr(14)
1042  kdata(i,kprm) = 99999
1043  50 CONTINUE
1044 C PROCESS DIFFERENCES
1045  IF (ihold.NE.0) THEN
1046  ibits = ihold * ident(14)
1047  iptr(25) = iptr(25) + ibits
1048  END IF
1049  ELSE
1050  iptr(31) = iptr(31) + 1
1051  kprm = iptr(31) + iptr(24)
1052  mstack(1,kprm) = jdesc
1053  mstack(2,kprm) = 0
1054  kdata(iptr(17),kprm) = 99999
1055 C SKIP OVER NON-COMPRESSED DATA
1056 C PRINT *,'SKIP NON-COMPRESSED DATA'
1057  iptr(25) = iptr(25) + iptr(36)
1058  END IF
1059  RETURN
1060  ELSE
1061  print *,'FI7802 - ERROR = 3'
1062  print *,jdesc,k,kk,j,kdesc(j)
1063  print *,' '
1064  print *,'TABLE B'
1065 C DO 20 LL = 1, IPTR(14)
1066 C PRINT *,LL,KDESC(LL)
1067 C 20 CONTINUE
1068  iptr(1) = 3
1069  RETURN
1070  END IF
1071  ELSE
1072  j = ((kk - k) / 2) + k
1073  END IF
1074  IF (jdesc.EQ.kdesc(k)) THEN
1075  j = k
1076  GO TO 15
1077  ELSE IF (jdesc.EQ.kdesc(kk))THEN
1078  j = kk
1079  GO TO 15
1080  ELSE IF (jdesc.LT.kdesc(j)) THEN
1081  k = k + 1
1082  kk = j - 1
1083  GO TO 10
1084  ELSE IF (jdesc.GT.kdesc(j)) THEN
1085  k = j + 1
1086  kk = kk - 1
1087  GO TO 10
1088  END IF
1089  15 CONTINUE
1090 C HAVE A MATCH
1091 C SET FLAG IF TEXT EVENT
1092  IF (askey(1:9).EQ.aunits(j)(1:9)) THEN
1093  iptr(18) = 1
1094  iptr(40) = mwidth(j) / 8
1095  ELSE
1096  iptr(18) = 0
1097  END IF
1098  IF (ident(16).NE.0) THEN
1099 C COMPRESSED
1100  CALL fi7803(iptr,ident,msga,kdata,ivals,mstack,
1101  * mwidth,mref,mscale,j,jdesc,maxr,maxd)
1102  IF (iptr(1).NE.0) THEN
1103  RETURN
1104  END IF
1105  ELSE
1106 C NOT COMPRESSED
1107  CALL fi7804(iptr,msga,kdata,ivals,mstack,
1108  * mwidth,mref,mscale,j,ll,jdesc,maxr,maxd)
1109  END IF
1110  RETURN
1111  END
1112 C> @brief Process compressed data
1113 C> @author Bill Cavanaugh @date 1988-09-01
1114 
1115 C> Process compressed data and place individual elements
1116 C> into output array.
1117 C>
1118 C> PROGRAM HISTORY LOG:
1119 C> - Bill Cavanaugh 1988-09-01
1120 C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
1121 C> modified to hanle width of fields in bytes.
1122 C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
1123 C> and uncompressed form gave different results. This has been corrected.
1124 C> - Bill Cavanaugh 1991-06-21 Processing of text data has been changed to
1125 C> provide exact reproduction of all characters.
1126 C>
1127 C> @param[in] IPTR See w3fi78() routine docblock
1128 C> @param[in] IDENT See w3fi78() routine docblock
1129 C> @param[in] MSGA Array containing bufr message,mstack,
1130 C> @param[in] IVALS Array of single parameter values
1131 C> @param[inout] J
1132 C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
1133 C> a bufr message.
1134 C> @param[in] MAXD Maximum number of descriptor combinations that may be
1135 C> processed; Upper air data and some satellite data require a value for maxd
1136 C> of 1600, but for most other data a value for maxd of 500 will suffice.
1137 C> @param[out] KDATA Array containing decoded reports from bufr message.
1138 C> KDATA(Report number,parameter number)
1139 C> (report number limited to value of input argument maxr and parameter number
1140 C> limited to value of input argument maxd)
1141 C> Arrays containing data from table B.
1142 C> @param[out] MSCALE Scale for value of descriptor
1143 C> @param[out] MREF Reference value for descriptor
1144 C> @param[out] MWIDTH Bit width for value of descriptor
1145 C> @param MSTACK
1146 C> @param JDESC
1147 C>
1148 C> @author Bill Cavanaugh @date 1988-09-01
1149  SUBROUTINE fi7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
1150  * MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD)
1151 
1152  SAVE
1153 C
1154  INTEGER MSGA(*),JDESC,MSTACK(2,MAXD)
1155  INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD)
1156  INTEGER NRVALS,JWIDE,IDATA
1157  INTEGER IDENT(*)
1158  INTEGER MSCALE(*)
1159  INTEGER MREF(700,3)
1160  INTEGER J
1161  INTEGER MWIDTH(*)
1162  INTEGER KLOW(256)
1163 C
1164  LOGICAL TEXT
1165 C
1166  INTEGER MSK(28)
1167 C
1168 C
1169  DATA msk /1,3,7,15,31,63,127,
1170 C 1 2 3 4 5 6 7
1171  * 255,511,1023,2047,4095,
1172 C 8 9 10 11 12
1173  * 8191,16383,32767,65535,
1174 C 13 14 15 16
1175  * 131071,262143,524287,
1176 C 17 18 19
1177  * 1048575,2097151,4194303,
1178 C 20 21 22
1179  * 8388607,16777215,33554431,
1180 C 23 24 25
1181  * 67108863,134217727,268435455/
1182 C 26 27 28
1183 C
1184 C PRINT *,' FI7803 COMPR J=',J,' MWIDTH(J) =',MWIDTH(J),
1185 C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25)
1186  IF (iptr(18).EQ.0) THEN
1187  text = .false.
1188  ELSE
1189  text = .true.
1190  END IF
1191 C PRINT *,'DESCRIPTOR',KPRM
1192  IF (.NOT.text) THEN
1193  IF (iptr(29).GT.0) THEN
1194 C WORKING WITH ASSOCIATED FIELDS HERE
1195  iptr(31) = iptr(31) + 1
1196  kprm = iptr(31) + iptr(24)
1197 C GET LOWEST
1198  CALL gbyte (msga,lowest,iptr(25),iptr(29))
1199  iptr(25) = iptr(25) + iptr(29)
1200 C GET NBINC
1201  CALL gbyte (msga,nbinc,iptr(25),6)
1202  iptr(25) = iptr(25) + 6
1203 C EXTRACT DATA FOR ASSOCIATED FIELD
1204  IF (nbinc.GT.0) THEN
1205  CALL gbytes (msga,ivals,iptr(25),nbinc,0,iptr(14))
1206  iptr(25) = iptr(25) + nbinc * iptr(14)
1207  DO 50 i = 1, iptr(14)
1208  kdata(i,kprm) = ivals(i) + lowest
1209  IF (kdata(i,kprm).GE.msk(nbinc)) THEN
1210  kdata(i,kprm) = 999999
1211  END IF
1212  50 CONTINUE
1213  ELSE
1214  DO 51 i = 1, iptr(14)
1215  IF (lowest.GE.msk(nbinc)) THEN
1216  kdata(i,kprm) = 999999
1217  ELSE
1218  kdata(i,kprm) = lowest
1219  END IF
1220  51 CONTINUE
1221  END IF
1222  END IF
1223 C SET PARAMETER
1224 C ISOLATE STANDARD BIT WIDTH
1225  jwide = mwidth(j) + iptr(26)
1226 C SINGLE VALUE FOR LOWEST
1227  nrvals = 1
1228 C LOWEST
1229 C PRINT *,'PARAM',KPRM
1230  CALL gbyte (msga,lowest,iptr(25),jwide)
1231 C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
1232  iptr(25) = iptr(25) + jwide
1233 C ISOLATE COMPRESSED BIT WIDTH
1234  CALL gbyte (msga,nbinc,iptr(25),6)
1235 C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25)
1236  IF (iptr(32).EQ.2.AND.iptr(33).EQ.5) THEN
1237  ELSE
1238  IF (nbinc.GT.jwide) THEN
1239 C PRINT *,'FOR DESCRIPTOR',JDESC
1240 C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' MWIDTH(J)=',
1241 C * MWIDTH(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
1242 C DO 110 I = 1, KPRM
1243 C WRITE (6,111)I,(KDATA(J,I),J=1,6)
1244 C 110 CONTINUE
1245  111 FORMAT (1x,5hdata ,i3,6(2x,i10))
1246  iptr(1) = 500
1247 C RETURN
1248  print *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE',
1249  * ' B PLUS WIDTH CHANGES'
1250  END IF
1251  END IF
1252  iptr(25) = iptr(25) + 6
1253 C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
1254 C IF TEXT EVENT, PROCESS TEXT
1255 C GET COMPRESSED VALUES
1256 C PRINT *,'COMPRESSED VALUES - NONTEXT'
1257  nrvals = ident(14)
1258  iptr(31) = iptr(31) + 1
1259  kprm = iptr(31) + iptr(24)
1260  IF (nbinc.NE.0) THEN
1261  CALL gbytes (msga,ivals,iptr(25),nbinc,0,nrvals)
1262  iptr(25) = iptr(25) + nbinc * nrvals
1263 C RECALCULATE TO ORIGINAL VALUES
1264  DO 100 i = 1, nrvals
1265 C PRINT *,IVALS(I),MSK(NBINC),NBINC
1266  IF (ivals(i).GE.msk(nbinc)) THEN
1267  kdata(i,kprm) = 999999
1268  ELSE
1269  IF (mref(j,2).EQ.0) THEN
1270  kdata(i,kprm) = ivals(i) + lowest + mref(j,1)
1271  ELSE
1272  kdata(i,kprm) = ivals(i) + lowest + mref(j,3)
1273  END IF
1274  END IF
1275  100 CONTINUE
1276 C PRINT *,I,JDESC,LOWEST,MREF(J,1),MREF(J,3)
1277  ELSE
1278  IF (lowest.EQ.msk(mwidth(j))) THEN
1279  DO 105 i = 1, nrvals
1280  kdata(i,kprm) = 999999
1281  105 CONTINUE
1282  ELSE
1283  IF (mref(j,2).EQ.0) THEN
1284  icomb = lowest + mref(j,1)
1285  ELSE
1286  icomb = lowest + mref(j,3)
1287  END IF
1288  DO 106 i = 1, nrvals
1289  kdata(i,kprm) = icomb
1290  106 CONTINUE
1291  END IF
1292  END IF
1293 C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25)
1294  mstack(1,kprm) = jdesc
1295  IF (iptr(27).NE.0) THEN
1296  mstack(2,kprm) = iptr(27)
1297  ELSE
1298  mstack(2,kprm) = mscale(j)
1299  END IF
1300 C WRITE (6,80) (DATA(I,KPRM),I=1,10)
1301 C 80 FORMAT(2X,10(F10.2,1X))
1302  ELSE IF (text) THEN
1303 C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
1304 C GET LOWEST
1305 C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40))
1306  DO 1906 k = 1, iptr(40)
1307  CALL gbyte (msga,klow,iptr(25),8)
1308  iptr(25) = iptr(25) + 8
1309  IF (klow(k).NE.0) THEN
1310  iptr(1) = 27
1311  print *,'NON-ZERO LOWEST ON TEXT DATA'
1312  RETURN
1313  END IF
1314  1906 CONTINUE
1315 C GET NBINC
1316  CALL gbyte (msga,nbinc,iptr(25),6)
1317 C PRINT *,'NBINC =',NBINC
1318  iptr(25) = iptr(25) + 6
1319  IF (nbinc.NE.iptr(40)) THEN
1320  iptr(1) = 28
1321  print *,'NBINC IS NOT THE NUMBER OF CHARACTERS',nbinc
1322  RETURN
1323  END IF
1324 C FOR NUMBER OF OBSERVATIONS
1325  iptr(31) = iptr(31) + 1
1326  kprm = iptr(31) + iptr(24)
1327  istart = kprm
1328  i24 = iptr(24)
1329  DO 1900 n = 1, ident(14)
1330  kprm = istart
1331  iptr(24) = i24
1332  nbits = iptr(40) * 8
1333  1700 CONTINUE
1334 C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS
1335  IF (nbits.GT.32) THEN
1336  CALL gbyte (msga,idata,iptr(25),32)
1337  iptr(25) = iptr(25) + 32
1338  nbits = nbits - 32
1339 C CONVERTS ASCII TO EBCIDIC
1340 C COMMENT OUT IF NOT IBM370 COMPUTER
1341 C PRINT *,IDATA
1342 C CALL W3AI39 (IDATA,4)
1343  mstack(1,kprm) = jdesc
1344  mstack(2,kprm) = 0
1345  kdata(n,kprm) = idata
1346 C SET FOR NEXT PART
1347  kprm = kprm + 1
1348  iptr(24) = iptr(24) + 1
1349 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
1350  1701 FORMAT (1x,i1,1x,6hkdata=,a4,2x,i5,2x,i5,2x,i5,2x,i12)
1351  GO TO 1700
1352  ELSE IF (nbits.GT.0) THEN
1353  CALL gbyte (msga,idata,iptr(25),nbits)
1354  iptr(25) = iptr(25) + nbits
1355  ibuf = (32 - nbits) / 8
1356  IF (ibuf.GT.0) THEN
1357  DO 1750 mp = 1, ibuf
1358  idata = idata * 256 + 32
1359  1750 CONTINUE
1360  END IF
1361 C CONVERTS ASCII TO EBCIDIC
1362 C COMMENT OUT IF NOT IBM370 COMPUTER
1363 C CALL W3AI39 (IDATA,4)
1364  mstack(1,kprm) = jdesc
1365  mstack(2,kprm) = 0
1366  kdata(n,kprm) = idata
1367 C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
1368  nbits = 0
1369  END IF
1370 C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
1371 C1800 FORMAT (2X,I4,2X,3A4)
1372  1900 CONTINUE
1373  END IF
1374  RETURN
1375  END
1376 
1377 C> @brief Process serial data.
1378 C> @author Bill Cavanaugh @date 1988-09-01
1379 
1380 C> Process data that is not compressed.
1381 C>
1382 C> Program history log:
1383 C> - Bill Cavanaugh 1988-09-01
1384 C> - Bill Cavanaugh 1991-01-18 Modified to properly handle non-compressed
1385 C> data.
1386 C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
1387 C> modified to handle field width in bytes.
1388 C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
1389 C> and uncompressed form gave different results.
1390 C> this has been corrected.
1391 C>
1392 C> @param[in] IPTR See w3fi78 routine docblock
1393 C> @param[in] MSGA Array containing bufr message
1394 C> @param[inout] IVALS Array of single parameter values
1395 C> @param[inout] J
1396 C> @param[in] MAXR Maximum number of reports/subsets that may be
1397 C> contained in a bufr message
1398 C> @param[in] MAXD Maximum number of descriptor combinations that
1399 C> may be processed; upper air data and some satellite
1400 C> data require a value for maxd of 1600, but for most
1401 C> other data a value for maxd of 500 will suffice
1402 C> @param[out] KDATA Array containing decoded reports from bufr message.
1403 C> KDATA(report number,parameter number)
1404 C> (report number limited to value of input argument maxr and parameter number
1405 C> limited to value of input argument maxd)
1406 C> arrays containing data from table B
1407 C> @param[out] MSCALE Scale for value of descriptor
1408 C> @param[out] MREF Reference value for descriptor
1409 C> @param[out] MWIDTH Bit width for value of descriptor
1410 C> @param MSTACK
1411 C> @param LL
1412 C> @param JDESC
1413 C>
1414 C> Error return:
1415 C> IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
1416 C>
1417 C> @author Bill Cavanaugh @date 1988-09-01
1418  SUBROUTINE fi7804(IPTR,MSGA,KDATA,IVALS,MSTACK,
1419  * MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD)
1420  SAVE
1421 C
1422  INTEGER MSGA(*)
1423  INTEGER IPTR(*),MREF(700,3),MSCALE(*)
1424  INTEGER MWIDTH(*),JDESC
1425  INTEGER IVALS(*)
1426  INTEGER LSTBLK(3)
1427  INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD)
1428  INTEGER J,LL
1429  LOGICAL LKEY
1430 C
1431 C
1432  INTEGER ITEST(30)
1433  DATA itest /1,3,7,15,31,63,127,255,
1434  * 511,1023,2047,4095,8191,16383,
1435  * 32767, 65535,131071,262143,524287,
1436  * 1048575,2097151,4194303,8388607,
1437  * 16777215,33554431,67108863,134217727,
1438  * 268435455,536870911,1073741823/
1439 C
1440 C PRINT *,' FI7804 NOCMP',J,JDESC,MWIDTH(J),IPTR(26),IPTR(25)
1441  IF ((iptr(26)+mwidth(j)).LT.1) THEN
1442  iptr(1) = 501
1443  RETURN
1444  END IF
1445 C -------- NOCMP --------
1446 C ISOLATE BIT WIDTH
1447  jwide = mwidth(j) + iptr(26)
1448 C IF NOT TEXT EVENT, PROCESS
1449  IF (iptr(18).NE.1) THEN
1450 C IF ASSOCIATED FIELD SW ON
1451  IF (iptr(29).GT.0) THEN
1452  IF (jdesc.NE.7957.AND.jdesc.NE.7937) THEN
1453  iptr(31) = iptr(31) + 1
1454  kprm = iptr(31) + iptr(24)
1455  mstack(1,kprm) = 33792 + iptr(29)
1456  mstack(2,kprm) = 0
1457  CALL gbyte (msga,ivals,iptr(25),iptr(29))
1458  iptr(25) = iptr(25) + iptr(29)
1459  kdata(iptr(17),kprm) = ivals(1)
1460 C PRINT *,'FI7804-A',KPRM,MSTACK(1,KPRM),
1461 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
1462  END IF
1463  END IF
1464  iptr(31) = iptr(31) + 1
1465  kprm = iptr(31) + iptr(24)
1466  mstack(1,kprm) = jdesc
1467  IF (iptr(27).NE.0) THEN
1468  mstack(2,kprm) = iptr(27)
1469  ELSE
1470  mstack(2,kprm) = mscale(j)
1471  END IF
1472 C GET VALUES
1473 C CALL TO GET DATA OF GIVEN BIT WIDTH
1474  CALL gbyte (msga,ivals,iptr(25),jwide)
1475 C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
1476  iptr(25) = iptr(25) + jwide
1477 C RETURN WITH SINGLE VALUE
1478  IF (ivals(1).EQ.itest(jwide)) THEN
1479  kdata(iptr(17),kprm) = 999999
1480  ELSE
1481  IF (mref(j,2).EQ.0) THEN
1482  kdata(iptr(17),kprm) = ivals(1) + mref(j,1)
1483  ELSE
1484  kdata(iptr(17),kprm) = ivals(1) + mref(j,3)
1485  END IF
1486  END IF
1487 C PRINT *,'FI7804-B',KPRM,MSTACK(1,KPRM),
1488 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
1489 C IF(JDESC.EQ.2049) THEN
1490 C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
1491 C END IF
1492 C PRINT *,'FI7804 ',KPRM,MSTACK(1,KPRM),
1493 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1494  ELSE
1495 C IF TEXT EVENT, PROCESS TEXT
1496 C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
1497  nrchrs = iptr(40)
1498  nrbits = nrchrs * 8
1499 C PRINT *,'CHARS =',NRCHRS,' BITS =',NRBITS
1500  iptr(31) = iptr(31) + 1
1501  kany = 0
1502  1800 CONTINUE
1503  kany = kany + 1
1504  IF (nrbits.GT.32) THEN
1505  CALL gbyte (msga,idata,iptr(25),32)
1506 C PRINT 1801,KANY,IDATA,IPTR(17),KPRM
1507 C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4))
1508 C CONVERTS ASCII TO EBCIDIC
1509 C COMMENT OUT IF NOT IBM370 COMPUTER
1510 C CALL W3AI39 (IDATA,4)
1511  kprm = iptr(31) + iptr(24)
1512  kdata(iptr(17),kprm) = idata
1513  mstack(1,kprm) = jdesc
1514  mstack(2,kprm) = 0
1515 C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
1516 C * KDATA(IPTR(17),KPRM)
1517  iptr(25) = iptr(25) + 32
1518  nrbits = nrbits - 32
1519  iptr(24) = iptr(24) + 1
1520  GO TO 1800
1521  ELSE IF (nrbits.GT.0) THEN
1522 C PRINT *,'LAST TEXT WORD'
1523  CALL gbyte (msga,idata,iptr(25),nrbits)
1524  iptr(25) = iptr(25) + nrbits
1525 C CONVERTS ASCII TO EBCIDIC
1526 C COMMENT OUT IF NOT IBM370 COMPUTER
1527 C CALL W3AI39 (IDATA,4)
1528  kprm = iptr(31) + iptr(24)
1529  kshft = 32 - nrbits
1530  IF (kshft.GT.0) THEN
1531  ktry = kshft / 8
1532  DO 1722 lak = 1, ktry
1533  idata = idata * 256 + 64
1534 C PRINT 1723,IDATA
1535  1723 FORMAT (12x,z8)
1536  1722 CONTINUE
1537  END IF
1538  kdata(iptr(17),kprm) = idata
1539 C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
1540  mstack(1,kprm) = jdesc
1541  mstack(2,kprm) = 0
1542 C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
1543 C * KDATA(IPTR(17),KPRM)
1544  END IF
1545 C TURN OFF TEXT
1546  iptr(18) = 0
1547  END IF
1548  RETURN
1549  END
1550 C> @brief Process a replication descriptor.
1551 C> @author Bill Cavanaugh @date 1988-09-01
1552 
1553 C> Process a replication descriptor, must extract number
1554 C> of replications of n descriptors from the data stream.
1555 C>
1556 C> Program history log:
1557 C> - Bill Cavanaugh 1988-09-01
1558 C>
1559 C> @param[in] IWORK Working descriptor list
1560 C> @param[in] IPTR See w3fi78 routine docblock
1561 C> @param[in] IDENT See w3fi78 routine docblock
1562 C> @param[inout] LX X portion of current descriptor
1563 C> @param[inout] LY Y portion of current descriptor
1564 C> @param[in] MAXR Maximum number of reports/subsets that may be
1565 C> contained in a bufr message.
1566 C> @param[in] MAXD Maximum number of descriptor combinations that
1567 C> may be processed; upper air data and some satellite
1568 C> data require a value for maxd of 1600, but for most
1569 C> other data a value for maxd of 500 will suffice
1570 C> @param[out] KDATA Array containing decoded reports from bufr message.
1571 C> KDATA(report number,parameter number)
1572 C> (report number limited to value of input argument
1573 C> maxr and parameter number limited to value of input
1574 C> argument maxd)
1575 C> @param MSGA
1576 C> @param LL
1577 C> @param KNR
1578 C> @param MSTACK
1579 C>
1580 C> Error return:
1581 C> IPTR(1):
1582 C> - = 12 Data descriptor qualifier does not follow delayed replication
1583 C> descriptor
1584 C> - = 20 Exceeded count for delayed replication pass
1585 C>
1586 C> @author Bill Cavanaugh @date 1988-09-01
1587  SUBROUTINE fi7805(IPTR,IDENT,MSGA,IWORK,LX,LY,
1588  * KDATA,LL,KNR,MSTACK,MAXR,MAXD)
1589 
1590  SAVE
1591 C
1592  INTEGER IPTR(*)
1593  INTEGER KNR(MAXR)
1594  INTEGER ITEMP(2000)
1595  INTEGER LL
1596  INTEGER KTEMP(2000)
1597  INTEGER KDATA(MAXR,MAXD)
1598  INTEGER LX,MSTACK(2,MAXD)
1599  INTEGER LY
1600  INTEGER MSGA(*)
1601  INTEGER KVALS(1000)
1602  INTEGER IWORK(MAXD)
1603  INTEGER IDENT(*)
1604 C
1605 C PRINT *,' REPLICATION FI7805'
1606 C DO 100 I = 1, IPTR(13)
1607 C PRINT *,I,IWORK(I)
1608 C 100 CONTINUE
1609 C NUMBER OF DESCRIPTORS
1610  nrset = lx
1611 C NUMBER OF REPLICATIONS
1612  nrreps = ly
1613  icurr = iptr(11) - 1
1614  ipick = iptr(11) - 1
1615 C
1616  IF (nrreps.EQ.0) THEN
1617  iptr(39) = 1
1618 C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
1619 C IPTR(31) = IPTR(31) + 1
1620 C KPRM = IPTR(31) + IPTR(24)
1621 C MSTACK(1,KPRM) = JDESC
1622 C MSTACK(2,KPRM) = 0
1623 C KDATA(IPTR(17),KPRM) = 0
1624 C PRINT *,'FI7805-1',KPRM,MSTACK(1,KPRM),
1625 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1626 C DELAYED REPLICATION - MUST GET NUMBER OF
1627 C REPLICATIONS FROM DATA.
1628 C GET NEXT DESCRIPTOR
1629  CALL fi7808(iptr,iwork,lf,lx,ly,jdesc,maxd)
1630 C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
1631 C MUST BE DATA DESCRIPTION
1632 C OPERATION QUALIFIER
1633  IF (jdesc.EQ.7937.OR.jdesc.EQ.7947) THEN
1634  jwide = 8
1635  ELSE IF (jdesc.EQ.7938.OR.jdesc.EQ.7948) THEN
1636  jwide = 16
1637  ELSE
1638  iptr(1) = 12
1639  RETURN
1640  END IF
1641 
1642 C SET SINGLE VALUE FOR SEQUENTIAL,
1643 C MULTIPLE VALUES FOR COMPRESSED
1644  IF (ident(16).EQ.0) THEN
1645 C NON COMPRESSED
1646  CALL gbyte (msga,kvals,iptr(25),jwide)
1647 C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1)
1648  iptr(25) = iptr(25) + jwide
1649  iptr(31) = iptr(31) + 1
1650  kprm = iptr(31) + iptr(24)
1651  mstack(1,kprm) = jdesc
1652  mstack(2,kprm) = 0
1653  kdata(iptr(17),kprm) = kvals(1)
1654  nrreps = kvals(1)
1655 C PRINT *,'FI7805-2',KPRM,MSTACK(1,KPRM),
1656 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1657  ELSE
1658  nrvals = ident(14)
1659  CALL gbytes (msga,kvals,iptr(25),jwide,0,nrvals)
1660  iptr(25) = iptr(25) + jwide * nrvals
1661  iptr(31) = iptr(31) + 1
1662  kprm = iptr(31) + iptr(24)
1663  mstack(1,kprm) = jdesc
1664  mstack(2,kprm) = 0
1665  kdata(iptr(17),kprm) = kvals(1)
1666  DO 100 i = 1, nrvals
1667  kdata(i,kprm) = kvals(i)
1668  100 CONTINUE
1669  nrreps = kvals(1)
1670  END IF
1671  ELSE
1672 C PRINT *,'NOT DELAYED REPLICATION'
1673  END IF
1674 C RESTRUCTURE WORKING STACK W/REPLICATIONS
1675 C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
1676 C PICK UP DESCRIPTORS TO BE REPLICATED
1677  DO 1000 i = 1, nrset
1678  CALL fi7808(iptr,iwork,lf,lx,ly,jdesc,maxd)
1679  itemp(i) = jdesc
1680 C PRINT *,'REPLICATION ',I,ITEMP(I)
1681  1000 CONTINUE
1682 C MOVE TRAILING DESCRIPTORS TO HOLD AREA
1683  lax = iptr(12) - iptr(11) + 1
1684 C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12)
1685  DO 2000 i = 1, lax
1686  CALL fi7808(iptr,iwork,lf,lx,ly,jdesc,maxd)
1687  ktemp(i) = jdesc
1688 C PRINT *,' ',I,KTEMP(I)
1689  2000 CONTINUE
1690 C REPLICATIONS INTO ISTACK
1691 C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
1692 C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
1693  DO 4000 i = 1, nrreps
1694  DO 3000 j = 1, nrset
1695  iwork(icurr) = itemp(j)
1696 C PRINT *,'FI7805 A',ICURR,IWORK(ICURR)
1697  icurr = icurr + 1
1698  3000 CONTINUE
1699  4000 CONTINUE
1700 C PRINT *,' TO LOC',ICURR-1
1701 C RESTORE TRAILING DESCRIPTORS
1702 C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
1703  DO 5000 i = 1, lax
1704  iwork(icurr) = ktemp(i)
1705 C PRINT *,'FI7805 B',ICURR,IWORK(ICURR)
1706  icurr = icurr + 1
1707  5000 CONTINUE
1708  iptr(12) = icurr - 1
1709  iptr(11) = ipick
1710  RETURN
1711  END
1712 C> @brief Process operator descriptors
1713 C> @author Bill Cavanaugh @date 1988-09-01
1714 
1715 C> Extract and save indicated change values for use
1716 C> until changes are rescinded, or extract text strings indicated
1717 C> through 2 05 yyy.
1718 C>
1719 C> Program history log:
1720 C> - Bill Cavanaugh 1988-09-01
1721 C> - Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
1722 C> - Bill Cavanaugh 1991-05-10 Coding has been added to process proposed
1723 C> table c descriptor 2 06 yyy.
1724 C> - Bill Cavanaugh 1991-11-21 Coding has been added to properly process
1725 C> table c descriptor 2 03 yyy, the change
1726 C> to new reference value for selected
1727 C> descriptors.
1728 C>
1729 C> @param[in] IPTR See w3fi78 routine docblock
1730 C> @param[in] LX X portion of current descriptor
1731 C> @param[in] LY Y portion of current descriptor
1732 C> @param[in] MAXR Maximum number of reports/subsets that may be
1733 C> contained in a bufr message
1734 C> @param[in] MAXD Maximum number of descriptor combinations that
1735 C> may be processed; upper air data and some satellite
1736 C> data require a value for maxd of 1600, but for most
1737 C> other data a value for maxd of 500 will suffice
1738 C> @param[out] KDATA Array containing decoded reports from bufr message.
1739 C> KDATA(Report number,parameter number)
1740 C> (report number limited to value of input argument maxr and parameter number
1741 C> limited to value of input argument maxd)
1742 C> Arrays containing data from table b
1743 C> @param[out] MSCALE Scale for value of descriptor
1744 C> @param[out] MREF Reference value for descriptor
1745 C> @param[out] MWIDTH Bit width for value of descriptor
1746 C> @param IDENT
1747 C> @param MSGA
1748 C> @param IVALS
1749 C> @param MSTACK
1750 C> @param J
1751 C> @param LL
1752 C> @param KDESC
1753 C> @param JDESC
1754 C> @param IWORK
1755 C>
1756 C> Error return:
1757 C> IPTR(1) = 5 - Erroneous X value in data descriptor operator
1758 C>
1759 C> @author Bill Cavanaugh @date 1988-09-01
1760  SUBROUTINE fi7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
1761  * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD)
1762 
1763  SAVE
1764  INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*)
1765  INTEGER IDENT(*),IWORK(*)
1766  INTEGER MSGA(*),MSTACK(2,MAXD)
1767  INTEGER MREF(700,3),KDESC(*)
1768  INTEGER MSCALE(*),MWIDTH(*)
1769  INTEGER J,JDESC
1770  INTEGER LL
1771  INTEGER LX
1772  INTEGER LY
1773 C
1774 C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
1775  IF (lx.EQ.1) THEN
1776 C CHANGE BIT WIDTH
1777  IF (ly.EQ.0) THEN
1778 C PRINT *,' RETURN TO NORMAL WIDTH'
1779  iptr(26) = 0
1780  ELSE
1781 C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
1782  iptr(26) = ly - 128
1783  END IF
1784  ELSE IF (lx.EQ.2) THEN
1785 C CHANGE SCALE
1786  IF (ly.EQ.0) THEN
1787 C RESET TO STANDARD SCALE
1788  iptr(27) = 0
1789  ELSE
1790 C SET NEW SCALE
1791  iptr(27) = ly - 128
1792  END IF
1793  ELSE IF (lx.EQ.3) THEN
1794 C CHANGE REFERENCE VALUE
1795 C FOR EACH OF THOSE DESCRIPTORS BETWEEN
1796 C 2 03 YYY WHERE Y LT 255 AND
1797 C 2 03 255, EXTRACT THE NEW REFERENCE
1798 C VALUE (BIT WIDTH YYY) AND PLACE
1799 C IN TERTIARY TABLE B REF VAL POSITION,
1800 C SET FLAG IN SECONDARY REFVAL POSITION
1801 C THOSE DESCRIPTORS DO NOT HAVE DATA
1802 C ASSOCIATED WITH THEM, BUT ONLY
1803 C IDENTIFY THE TABLE B ENTRIES THAT
1804 C ARE GETTING NEW REFERENCE VALUES.
1805  kyyy = ly
1806  IF (kyyy.GT.0.AND.kyyy.LT.255) THEN
1807 C START CYCLING THRU DESCRIPTORS UNTIL
1808 C TERMINATE NEW REF VALS IS FOUND
1809  300 CONTINUE
1810  CALL fi7808 (iptr,iwork,lf,lx,ly,jdesc,maxd)
1811  IF (jdesc.EQ.33791) THEN
1812 C IF 2 03 255 THEN RETURN
1813  RETURN
1814  ELSE
1815 C FIND MATCHING TABLE B ENTRY
1816  DO 500 lj = 1, iptr(14)
1817  IF (jdesc.EQ.kdesc(lj)) THEN
1818 C TURN ON NEW REF VAL FLAG
1819  mref(lj,2) = 1
1820 C INSERT NEW REF VAL
1821  CALL gbyte (msga,mref(lj,3),iptr(25),kyyy)
1822 C GO GET NEXT DESCRIPTOR
1823  GO TO 300
1824  END IF
1825  500 CONTINUE
1826 C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR
1827  print *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND'
1828  stop 203
1829  END IF
1830  ELSE IF (kyyy.EQ.0) THEN
1831 C MUST TURN OFF ALL NEW
1832 C REFERENCE VALUES
1833  DO 400 i = 1, iptr(14)
1834  mref(i,2) = 0
1835  400 CONTINUE
1836  END IF
1837 C LX = 3
1838 C MUST BE CONCLUDED WITH Y=255
1839  ELSE IF (lx.EQ.4) THEN
1840 C ASSOCIATED VALUES
1841  IF (ly.EQ.0) THEN
1842  iptr(29) = 0
1843 C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29)
1844  ELSE
1845  iptr(29) = ly
1846  IF (iwork(iptr(11)).NE.7957) THEN
1847  print *,'2 04 YYY NOT FOLLOWED BY 0 31 021'
1848  iptr(1) = 11
1849  END IF
1850 C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
1851  END IF
1852  ELSE IF (lx.EQ.5) THEN
1853 C PROCESS TEXT DATA
1854  iptr(40) = ly
1855  iptr(18) = 1
1856  IF (ident(16).EQ.0) THEN
1857 C PRINT *,'2 05 YYY - TEXT - NONCOMPRESSED MODE'
1858  CALL fi7804(iptr,msga,kdata,ivals,mstack,
1859  * mwidth,mref,mscale,j,ll,jdesc,maxr,maxd)
1860  ELSE
1861 C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE'
1862  CALL fi7803(iptr,ident,msga,kdata,ivals,mstack,
1863  * mwidth,mref,mscale,j,jdesc,maxr,maxd)
1864  IF (iptr(1).NE.0) THEN
1865  RETURN
1866  END IF
1867  ENDIF
1868  iptr(18) = 0
1869  ELSE IF (lx.EQ.6) THEN
1870 C SKIP NEXT DESCRIPTOR
1871 C SET TO PASS OVER DESCRIPTOR AND DATA
1872 C IF DESCRIPTOR NOT IN TABLE B
1873  iptr(36) = ly
1874 C PRINT *,'SET TO SKIP',LY,' BIT FIELD'
1875  iptr(31) = iptr(31) + 1
1876  kprm = iptr(31) + iptr(24)
1877  mstack(1,kprm) = 34304 + ly
1878  mstack(2,kprm) = 0
1879  ELSE
1880  iptr(1) = 5
1881  ENDIF
1882  RETURN
1883  END
1884 C> @brief Process queue descriptor.
1885 C> @author Bill Cavanaugh @date 1988-09-01
1886 
1887 C> Substitute descriptor queue for queue descriptor.
1888 C>
1889 C> Program history log:
1890 C> - Bill Cavanaugh 1988-09-01
1891 C> - Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors.
1892 C> - Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors.
1893 C> based on tests with live data.
1894 C>
1895 C> @param[in] IWORK Working descriptor list
1896 C> @param[in] IPTR See w3fi78 routine docblock
1897 C> @param MAXD
1898 C> @param[in] ITBLD Array containing descriptor queues
1899 C> @param[in] JDESC Queue descriptor to be expanded
1900 C>
1901 C$$$
1902  SUBROUTINE fi7807(IPTR,IWORK,ITBLD,JDESC,MAXD)
1903 
1904  SAVE
1905 C
1906  INTEGER IPTR(*),JDESC
1907  INTEGER IWORK(*),IHOLD(2000)
1908  INTEGER ITBLD(500,11)
1909 C
1910 C PRINT *,' FI7807 F3 ENTRY',IPTR(11),IPTR(12)
1911 C SET FOR BINARY SEARCH IN TABLE D
1912 C DO 2020 I = 1, IPTR(12)
1913 C PRINT *,'ENTRY IWORK',I,IWORK(I)
1914 C2020 CONTINUE
1915  jlo = 1
1916  jhi = iptr(20)
1917 C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC
1918  10 CONTINUE
1919  jmid = (jlo + jhi) / 2
1920 C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1)
1921 C
1922  IF (jdesc.LT.itbld(jmid,1)) THEN
1923  IF (jdesc.EQ.itbld(jlo,1)) THEN
1924  jmid = jlo
1925  GO TO 100
1926  ELSE
1927  jlo = jlo + 1
1928  jhi = jmid - 1
1929  IF (jlo.GT.jmid) THEN
1930  iptr(1) = 4
1931  RETURN
1932  END IF
1933  GO TO 10
1934  END IF
1935  ELSE IF (jdesc.GT.itbld(jmid,1)) THEN
1936  IF (jdesc.EQ.itbld(jhi,1)) THEN
1937  jmid = jhi
1938  GO TO 100
1939  ELSE
1940  jlo = jmid + 1
1941  jhi = jhi - 1
1942  IF (jlo.GT.jhi) THEN
1943  iptr(1) = 4
1944  RETURN
1945  END IF
1946  GO TO 10
1947  END IF
1948  END IF
1949  100 CONTINUE
1950 C HAVE TABLE D MATCH
1951 C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11)
1952 C PRINT *,'TABLE D TO IHOLD'
1953  ik = 0
1954  jk = 0
1955  DO 200 ki = 2, 11
1956  IF (itbld(jmid,ki).NE.0) THEN
1957  ik = ik + 1
1958  ihold(ik) = itbld(jmid,ki)
1959 C PRINT *,IK,IHOLD(IK)
1960  ELSE
1961  GO TO 300
1962  END IF
1963  200 CONTINUE
1964  300 CONTINUE
1965  kk = iptr(11)
1966  IF (kk.GT.iptr(12)) THEN
1967 C NOTHING MORE TO APPEND
1968 C PRINT *,'NOTHING MORE TO APPEND'
1969  ELSE
1970 C APPEND TRAILING IWORK TO IHOLD
1971 C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12)
1972  DO 500 i = kk, iptr(12)
1973  ik = ik + 1
1974  ihold(ik) = iwork(i)
1975  500 CONTINUE
1976  END IF
1977 C RESET IHOLD TO IWORK
1978 C PRINT *,' RESET IWORK STACK'
1979  kk = iptr(11) - 2
1980  DO 1000 i = 1, ik
1981  kk = kk + 1
1982  iwork(kk) = ihold(i)
1983  1000 CONTINUE
1984  iptr(12) = kk
1985 C PRINT *,' FI7807 F3 EXIT ',IPTR(11),IPTR(12)
1986 C DO 2000 I = 1, IPTR(12)
1987 C PRINT *,'EXIT IWORK',I,IWORK(I)
1988 C2000 CONTINUE
1989 C RESET POINTERS
1990  iptr(11) = iptr(11) - 1
1991  RETURN
1992  END
1993 C> @brief
1994 C> @author Bill Cavanaugh @date 1988-09-01
1995 
1996 C> Program history log:
1997 C> - Bill Cavanaugh 1988-09-01
1998 C>
1999 C> @param[inout] IPTR See w3fi78() routine docblock
2000 C> @param[in] IWORK Working descriptor list
2001 C> @param LF
2002 C> @param LX
2003 C> @param LY
2004 C> @param JDESC
2005 C> @param MAXD
2006 C>
2007 C> @author Bill Cavanaugh @date 1988-09-01
2008  SUBROUTINE fi7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD)
2009 
2010  SAVE
2011  INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC
2012 C
2013 C PRINT *,' FI7808 NEW DESCRIPTOR PICKUP'
2014  JDESC = iwork(iptr(11))
2015  ly = mod(jdesc,256)
2016  iptr(34) = ly
2017  lx = mod((jdesc/256),64)
2018  iptr(33) = lx
2019  lf = jdesc / 16384
2020  iptr(32) = lf
2021 C PRINT *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY
2022  iptr(11) = iptr(11) + 1
2023  RETURN
2024  END
2025 C> @brief Reformat profiler w hgt increments.
2026 C> @author Bill Cavanaugh @date 1990-02-14
2027 
2028 C> Reformat decoded profiler data to show heights instead of
2029 C> height increments.
2030 C>
2031 C> Program history log:
2032 C> - Bill Cavanaugh 1990-02-14
2033 C>
2034 C> @param[in] IDENT Array contains message information extracted from BUFR
2035 C> message:
2036 C> - IDENT(1)- Edition number (byte 4, section 1)
2037 C> - IDENT(2)- Originating center (bytes 5-6, section 1)
2038 C> - IDENT(3)- Update sequence (byte 7, section 1)
2039 C> - IDENT(4)- (byte 8, section 1)
2040 C> - IDENT(5)- Bufr message type (byte 9, section 1)
2041 C> - IDENT(6)- Bufr msg sub-type (byte 10, section 1)
2042 C> - IDENT(7)- (bytes 11-12, section 1)
2043 C> - IDENT(8)- Year of century (byte 13, section 1)
2044 C> - IDENT(9)- Month of year (byte 14, section 1)
2045 C> - IDENT(10)- Day of month (byte 15, section 1)
2046 C> - IDENT(11)- Hour of day (byte 16, section 1)
2047 C> - IDENT(12)- Minute of hour (byte 17, section 1)
2048 C> - IDENT(13)- Rsvd by adp centers(byte 18, section 1)
2049 C> - IDENT(14)- Nr of data subsets (byte 5-6, section 3)
2050 C> - IDENT(15)- Observed flag (byte 7, bit 1, section 3)
2051 C> - IDENT(16)- Compression flag (byte 7, bit 2, section 3)
2052 C> @param[in] MSTACK Working descriptor list and scaling factor
2053 C> @param[in] KDATA Array containing decoded reports from bufr message.
2054 C> KDATA(Report number,parameter number)
2055 C> (report number limited to value of input argument maxr and parameter number
2056 C> limited to value of input argument maxd)
2057 C> @param[in] IPTR See w3fi78
2058 C> @param[in] MAXR Maximum number of reports/subsets that may be
2059 C> contained in a bufr message
2060 C> @param[in] MAXD Maximum number of descriptor combinations that
2061 C> may be processed; upper air data and some satellite
2062 C> data require a value for maxd of 1600, but for most
2063 C> other data a value for maxd of 500 will suffice.
2064 C>
2065 C> @author Bill Cavanaugh @date 1990-02-14
2066  SUBROUTINE fi7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
2067 
2068  SAVE
2069 C ----------------------------------------------------------------
2070 C
2071  INTEGER ISW
2072  INTEGER IDENT(*),KDATA(MAXR,MAXD)
2073  INTEGER MSTACK(2,MAXD),IPTR(*)
2074  INTEGER KPROFL(1600)
2075  INTEGER KPROF2(1600)
2076  INTEGER KSET2(1600)
2077 C
2078 C ----------------------------------------------------------
2079 C PRINT *,'FI7809'
2080 C LOOP FOR NUMBER OF SUBSETS/REPORTS
2081  DO 3000 i = 1, ident(14)
2082 C INIT FOR DATA INPUT ARRAY
2083  mk = 1
2084 C INIT FOR DESC OUTPUT ARRAY
2085  jk = 0
2086 C LOCATION
2087  isw = 0
2088  DO 200 j = 1, 3
2089 C LATITUDE
2090  IF (mstack(1,mk).EQ.1282) THEN
2091  isw = isw + 1
2092  GO TO 100
2093 C LONGITUDE
2094  ELSE IF (mstack(1,mk).EQ.1538) THEN
2095  isw = isw + 2
2096  GO TO 100
2097 C HEIGHT ABOVE SEA LEVEL
2098  ELSE IF (mstack(1,mk).EQ.1793) THEN
2099  ihgt = kdata(i,mk)
2100  isw = isw + 4
2101  GO TO 100
2102  END IF
2103  GO TO 200
2104  100 CONTINUE
2105  jk = jk + 1
2106 C SAVE DESCRIPTOR
2107  kprofl(jk) = mstack(1,mk)
2108 C SAVE SCALE
2109  kprof2(jk) = mstack(2,mk)
2110 C SAVE DATA
2111  kset2(jk) = kdata(i,mk)
2112  mk = mk + 1
2113  200 CONTINUE
2114  IF (isw.NE.7) THEN
2115  print *,'LOCATION ERROR PROCESSING PROFILER'
2116  iptr(1) = 200
2117  RETURN
2118  END IF
2119 C TIME
2120  isw = 0
2121  DO 400 j = 1, 7
2122 C YEAR
2123  IF (mstack(1,mk).EQ.1025) THEN
2124  isw = isw + 1
2125  GO TO 300
2126 C MONTH
2127  ELSE IF (mstack(1,mk).EQ.1026) THEN
2128  isw = isw + 2
2129  GO TO 300
2130 C DAY
2131  ELSE IF (mstack(1,mk).EQ.1027) THEN
2132  isw = isw + 4
2133  GO TO 300
2134 C HOUR
2135  ELSE IF (mstack(1,mk).EQ.1028) THEN
2136  isw = isw + 8
2137  GO TO 300
2138 C MINUTE
2139  ELSE IF (mstack(1,mk).EQ.1029) THEN
2140  isw = isw + 16
2141  GO TO 300
2142 C TIME SIGNIFICANCE
2143  ELSE IF (mstack(1,mk).EQ.2069) THEN
2144  isw = isw + 32
2145  GO TO 300
2146  ELSE IF (mstack(1,mk).EQ.1049) THEN
2147  isw = isw + 64
2148  GO TO 300
2149  END IF
2150  GO TO 400
2151  300 CONTINUE
2152  jk = jk + 1
2153 C SAVE DESCRIPTOR
2154  kprofl(jk) = mstack(1,mk)
2155 C SAVE SCALE
2156  kprof2(jk) = mstack(2,mk)
2157 C SAVE DATA
2158  kset2(jk) = kdata(i,mk)
2159  mk = mk + 1
2160  400 CONTINUE
2161  IF (isw.NE.127) THEN
2162  print *,'TIME ERROR PROCESSING PROFILER',isw
2163  iptr(1) = 201
2164  RETURN
2165  END IF
2166 C SURFACE DATA
2167  krg = 0
2168  isw = 0
2169  DO 600 j = 1, 10
2170 C WIND SPEED
2171  IF (mstack(1,mk).EQ.2818) THEN
2172  isw = isw + 1
2173  GO TO 500
2174 C WIND DIRECTION
2175  ELSE IF (mstack(1,mk).EQ.2817) THEN
2176  isw = isw + 2
2177  GO TO 500
2178 C PRESS REDUCED TO MSL
2179  ELSE IF (mstack(1,mk).EQ.2611) THEN
2180  isw = isw + 4
2181  GO TO 500
2182 C TEMPERATURE
2183  ELSE IF (mstack(1,mk).EQ.3073) THEN
2184  isw = isw + 8
2185  GO TO 500
2186 C RAINFALL RATE
2187  ELSE IF (mstack(1,mk).EQ.3342) THEN
2188  isw = isw + 16
2189  GO TO 500
2190 C RELATIVE HUMIDITY
2191  ELSE IF (mstack(1,mk).EQ.3331) THEN
2192  isw = isw + 32
2193  GO TO 500
2194 C 1ST RANGE GATE OFFSET
2195  ELSE IF (mstack(1,mk).EQ.1982.OR.
2196  * mstack(1,mk).EQ.1983) THEN
2197 C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
2198 C VALUE FOR LATER USE
2199  IF (mstack(1,mk).EQ.1983) THEN
2200  ihgt = kdata(i,mk)
2201  mk = mk + 1
2202  krg = 1
2203  ELSE
2204  IF (krg.EQ.0) THEN
2205  incrht = kdata(i,mk)
2206  mk = mk + 1
2207  krg = 1
2208 C PRINT *,'INITIAL INCR =',INCRHT
2209  ELSE
2210  lhgt = 500 + ihgt - kdata(i,mk)
2211  isw = isw + 64
2212 C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
2213  END IF
2214  END IF
2215 C MODE #1
2216  ELSE IF (mstack(1,mk).EQ.8128) THEN
2217  isw = isw + 128
2218  GO TO 500
2219 C MODE #2
2220  ELSE IF (mstack(1,mk).EQ.8129) THEN
2221  isw = isw + 256
2222  GO TO 500
2223  END IF
2224  GO TO 600
2225  500 CONTINUE
2226 C SAVE DESCRIPTOR
2227  jk = jk + 1
2228  kprofl(jk) = mstack(1,mk)
2229 C SAVE SCALE
2230  kprof2(jk) = mstack(2,mk)
2231 C SAVE DATA
2232  kset2(jk) = kdata(i,mk)
2233 C IF (I.EQ.1) THEN
2234 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
2235 C END IF
2236  mk = mk + 1
2237  600 CONTINUE
2238  650 CONTINUE
2239  IF (isw.NE.511) THEN
2240  print *,'SURFACE ERROR PROCESSING PROFILER',isw
2241  iptr(1) = 202
2242  RETURN
2243  END IF
2244 C 43 LEVELS
2245  DO 2000 l = 1, 43
2246  2020 CONTINUE
2247  isw = 0
2248 C HEIGHT INCREMENT
2249  IF (mstack(1,mk).EQ.1982) THEN
2250 C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK)
2251  incrht = kdata(i,mk)
2252  mk = mk + 1
2253  IF (lhgt.LT.(9250+ihgt)) THEN
2254  lhgt = ihgt + 500 - incrht
2255  ELSE
2256  lhgt = ihgt + 9250 - incrht
2257  END IF
2258  END IF
2259 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
2260 C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
2261  lhgt = lhgt + incrht
2262 C PRINT *,'LEVEL ',L,LHGT
2263  IF (l.EQ.37) THEN
2264  lhgt = lhgt + incrht
2265  END IF
2266  jk = jk + 1
2267 C SAVE DESCRIPTOR
2268  kprofl(jk) = 1798
2269 C SAVE SCALE
2270  kprof2(jk) = 0
2271 C SAVE DATA
2272  kset2(jk) = lhgt
2273 C IF (I.EQ.10) THEN
2274 C PRINT *,' '
2275 C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
2276 C END IF
2277  isw = 0
2278  DO 800 j = 1, 9
2279  750 CONTINUE
2280  IF (mstack(1,mk).EQ.1982) THEN
2281  GO TO 2020
2282 C U VECTOR VALUE
2283  ELSE IF (mstack(1,mk).EQ.3008) THEN
2284  isw = isw + 1
2285  IF (kdata(i,mk).GE.2047) THEN
2286  vectu = 32767
2287  ELSE
2288  vectu = kdata(i,mk)
2289  END IF
2290  mk = mk + 1
2291  GO TO 800
2292 C V VECTOR VALUE
2293  ELSE IF (mstack(1,mk).EQ.3009) THEN
2294  isw = isw + 2
2295  IF (kdata(i,mk).GE.2047) THEN
2296  vectv = 32767
2297  ELSE
2298  vectv = kdata(i,mk)
2299  END IF
2300  mk = mk + 1
2301 C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
2302 C DESCRIPTORS AND DATA
2303  IF (iand(isw,1).NE.0) THEN
2304  IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
2305 C SAVE DD DESCRIPTOR
2306  jk = jk + 1
2307  kprofl(jk) = 2817
2308 C SAVE SCALE
2309  kprof2(jk) = 0
2310 C SAVE DD DATA
2311  kset2(jk) = 32767
2312 C SAVE FFF DESCRIPTOR
2313  jk = jk + 1
2314  kprofl(jk) = 2818
2315 C SAVE SCALE
2316  kprof2(jk) = 1
2317 C SAVE FFF DATA
2318  kset2(jk) = 32767
2319  ELSE
2320 C GENERATE DDFFF
2321  CALL w3fc05 (vectu,vectv,dir,spd)
2322  ndir = dir
2323  spd = spd
2324  nspd = spd
2325 C PRINT *,' ',NDIR,NSPD
2326 C SAVE DD DESCRIPTOR
2327  jk = jk + 1
2328  kprofl(jk) = 2817
2329 C SAVE SCALE
2330  kprof2(jk) = 0
2331 C SAVE DD DATA
2332  kset2(jk) = dir
2333 C IF (I.EQ.1) THEN
2334 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
2335 C END IF
2336 C SAVE FFF DESCRIPTOR
2337  jk = jk + 1
2338  kprofl(jk) = 2818
2339 C SAVE SCALE
2340  kprof2(jk) = 1
2341 C SAVE FFF DATA
2342  kset2(jk) = spd
2343 C IF (I.EQ.1) THEN
2344 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
2345 C END IF
2346  END IF
2347  END IF
2348  GO TO 800
2349 C W VECTOR VALUE
2350  ELSE IF (mstack(1,mk).EQ.3010) THEN
2351  isw = isw + 4
2352  GO TO 700
2353 C Q/C TEST RESULTS
2354  ELSE IF (mstack(1,mk).EQ.8130) THEN
2355  isw = isw + 8
2356  GO TO 700
2357 C U,V QUALITY IND
2358  ELSE IF(iand(isw,16).EQ.0.AND.mstack(1,mk).EQ.2070) THEN
2359  isw = isw + 16
2360  GO TO 700
2361 C W QUALITY IND
2362  ELSE IF(iand(isw,32).EQ.0.AND.mstack(1,mk).EQ.2070) THEN
2363  isw = isw + 32
2364  GO TO 700
2365 C SPECTRAL PEAK POWER
2366  ELSE IF (mstack(1,mk).EQ.5568) THEN
2367  isw = isw + 64
2368  GO TO 700
2369 C U,V VARIABILITY
2370  ELSE IF (mstack(1,mk).EQ.3011) THEN
2371  isw = isw + 128
2372  GO TO 700
2373 C W VARIABILITY
2374  ELSE IF (mstack(1,mk).EQ.3013) THEN
2375  isw = isw + 256
2376  GO TO 700
2377  ELSE IF ((mstack(1,mk)/16384).NE.0) THEN
2378  mk = mk + 1
2379  GO TO 750
2380  END IF
2381  GO TO 800
2382  700 CONTINUE
2383  jk = jk + 1
2384 C SAVE DESCRIPTOR
2385  kprofl(jk) = mstack(1,mk)
2386 C SAVE SCALE
2387  kprof2(jk) = mstack(2,mk)
2388 C SAVE DATA
2389  kset2(jk) = kdata(i,mk)
2390  mk = mk + 1
2391 C IF (I.EQ.1) THEN
2392 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
2393 C END IF
2394  800 CONTINUE
2395  850 CONTINUE
2396  IF (isw.NE.511) THEN
2397  print *,'LEVEL ERROR PROCESSING PROFILER',isw
2398  iptr(1) = 203
2399  RETURN
2400  END IF
2401  2000 CONTINUE
2402 C MOVE DATA BACK INTO KDATA ARRAY
2403  DO 4000 ll = 1, jk
2404  kdata(i,ll) = kset2(ll)
2405  4000 CONTINUE
2406  3000 CONTINUE
2407 C PRINT *,'REBUILT ARRAY'
2408  DO 5000 ll = 1, jk
2409 C DESCRIPTOR
2410  mstack(1,ll) = kprofl(ll)
2411 C SCALE
2412  mstack(2,ll) = kprof2(ll)
2413 C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
2414  5000 CONTINUE
2415 C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
2416  iptr(31) = jk
2417  RETURN
2418  END
2419 C> @brief Reformat profiler edition 2 data.
2420 C> @author Bill Cavanaugh @date 1993-01-21
2421 
2422 C> Reformat profiler data in edition 2.
2423 C>
2424 C> Program history log:
2425 C> - Bill Cavanaugh 1993-01-27
2426 C>
2427 C> @param[in] IDENT Array contains message information extracted from
2428 C> bufr message:
2429 C> - IDENT(1) - Edition number (byte 4, section 1)
2430 C> - IDENT(2) - Originating center (bytes 5-6, section 1)
2431 C> - IDENT(3) - Update sequence (byte 7, section 1)
2432 C> - IDENT(4) - (byte 8, section 1)
2433 C> - IDENT(5) - Bufr message type (byte 9, section 1)
2434 C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
2435 C> - IDENT(7) - (bytes 11-12, section 1)
2436 C> - IDENT(8) - Year of century (byte 13, section 1)
2437 C> - IDENT(9) - Month of year (byte 14, section 1)
2438 C> - IDENT(10) - Day of month (byte 15, section 1)
2439 C> - IDENT(11) - Hour of day (byte 16, section 1)
2440 C> - IDENT(12) - Minute of hour (byte 17, section 1)
2441 C> - IDENT(13) - Rsvd by adp centers (byte 18, section 1)
2442 C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
2443 C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
2444 C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
2445 C> @param[in] MSTACK Working descriptor list and scaling factor
2446 C> @param[in] KDATA Array containing decoded reports from bufr message.
2447 c> kdata(report number,parameter number)
2448 c> (report number limited to value of input argument maxr and parameter number
2449 C> limited to value of input argument maxd)
2450 C> @param[in] IPTR See w3fi78
2451 C> @param[in] MAXR Maximum number of reports/subsets that may be
2452 C> contained in a bufr message
2453 C> @param[in] MAXD Maximum number of descriptor combinations that
2454 C> may be processed; upper air data and some satellite
2455 C> data require a value for maxd of 1600, but for most
2456 C> other data a value for maxd of 500 will suffice
2457 C>
2458 C> @author Bill Cavanaugh @date 1993-01-21
2459  SUBROUTINE fi7810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
2460 
2461  INTEGER ISW
2462  INTEGER IDENT(*),KDATA(MAXR,MAXD)
2463  INTEGER MSTACK(2,MAXD),IPTR(*)
2464  INTEGER KPROFL(1600)
2465  INTEGER KPROF2(1600)
2466  INTEGER KSET2(1600)
2467 C LOOP FOR NUMBER OF SUBSETS
2468  DO 3000 i = 1, ident(14)
2469  mk = 1
2470  jk = 0
2471  isw = 0
2472 C PRINT *,'IDENTIFICATION'
2473  DO 200 j = 1, 5
2474  IF (mstack(1,mk).EQ.257) THEN
2475 C BLOCK NUMBER
2476  isw = isw + 1
2477  ELSE IF (mstack(1,mk).EQ.258) THEN
2478 C STATION NUMBER
2479  isw = isw + 2
2480  ELSE IF (mstack(1,mk).EQ.1282) THEN
2481 C LATITUDE
2482  isw = isw + 4
2483  ELSE IF (mstack(1,mk).EQ.1538) THEN
2484 C LONGITUDE
2485  isw = isw + 8
2486  ELSE IF (mstack(1,mk).EQ.1793) THEN
2487 C HEIGHT OF STATION
2488  isw = isw + 16
2489  ihgt = kdata(i,mk)
2490  ELSE
2491  mk = mk + 1
2492  GO TO 200
2493  END IF
2494  jk = jk + 1
2495  kprofl(jk) = mstack(1,mk)
2496  kprof2(jk) = mstack(2,mk)
2497  kset2(jk) = kdata(i,mk)
2498 C PRINT *,JK,KPROFL(JK),KSET2(JK)
2499  mk = mk + 1
2500  200 CONTINUE
2501 C PRINT *,'LOCATION ',ISW
2502  IF (isw.NE.31) THEN
2503  print *,'LOCATION ERROR PROCESSING PROFILER'
2504  iptr(10) = 200
2505  RETURN
2506  END IF
2507 C PROCESS TIME ELEMENTS
2508  isw = 0
2509  DO 400 j = 1, 7
2510  IF (mstack(1,mk).EQ.1025) THEN
2511 C YEAR
2512  isw = isw + 1
2513  ELSE IF (mstack(1,mk).EQ.1026) THEN
2514 C MONTH
2515  isw = isw + 2
2516  ELSE IF (mstack(1,mk).EQ.1027) THEN
2517 C DAY
2518  isw = isw + 4
2519  ELSE IF (mstack(1,mk).EQ.1028) THEN
2520 C HOUR
2521  isw = isw + 8
2522  ELSE IF (mstack(1,mk).EQ.1029) THEN
2523 C MINUTE
2524  isw = isw + 16
2525  ELSE IF (mstack(1,mk).EQ.2069) THEN
2526 C TIME SIGNIFICANCE
2527  isw = isw + 32
2528  ELSE IF (mstack(1,mk).EQ.1049) THEN
2529 C TIME DISPLACEMENT
2530  isw = isw + 64
2531  ELSE
2532  mk = mk + 1
2533  GO TO 400
2534  END IF
2535  jk = jk + 1
2536  kprofl(jk) = mstack(1,mk)
2537  kprof2(jk) = mstack(2,mk)
2538  kset2(jk) = kdata(i,mk)
2539 C PRINT *,JK,KPROFL(JK),KSET2(JK)
2540  mk = mk + 1
2541  400 CONTINUE
2542 C PRINT *,'TIME ',ISW
2543  IF (isw.NE.127) THEN
2544  print *,'TIME ERROR PROCESSING PROFILER'
2545  iptr(1) = 201
2546  RETURN
2547  END IF
2548 C SURFACE DATA
2549  isw = 0
2550 C PRINT *,'SURFACE'
2551  DO 600 k = 1, 8
2552 C PRINT *,MK,MSTACK(1,MK),JK,ISW
2553  IF (mstack(1,mk).EQ.2817) THEN
2554  isw = isw + 1
2555  ELSE IF (mstack(1,mk).EQ.2818) THEN
2556  isw = isw + 2
2557  ELSE IF (mstack(1,mk).EQ.2611) THEN
2558  isw = isw + 4
2559  ELSE IF (mstack(1,mk).EQ.3073) THEN
2560  isw = isw + 8
2561  ELSE IF (mstack(1,mk).EQ.3342) THEN
2562  isw = isw + 16
2563  ELSE IF (mstack(1,mk).EQ.3331) THEN
2564  isw = isw + 32
2565  ELSE IF (mstack(1,mk).EQ.1797) THEN
2566  incrht = kdata(i,mk)
2567  isw = isw + 64
2568 C PRINT *,'INITIAL INCREMENT = ',INCRHT
2569  mk = mk + 1
2570 C PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW
2571  GO TO 600
2572  ELSE IF (mstack(1,mk).EQ.6433) THEN
2573  isw = isw + 128
2574  END IF
2575  jk = jk + 1
2576  kprofl(jk) = mstack(1,mk)
2577  kprof2(jk) = mstack(2,mk)
2578  kset2(jk) = kdata(i,mk)
2579 C PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW
2580  mk = mk + 1
2581  600 CONTINUE
2582  IF (isw.NE.255) THEN
2583  print *,'ERROR PROCESSING PROFILER',isw
2584  iptr(1) = 204
2585  RETURN
2586  END IF
2587  IF (mstack(1,mk).NE.1797) THEN
2588  print *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER'
2589  iptr(1) = 205
2590  RETURN
2591  END IF
2592 C MUST SAVE THIS HEIGHT VALUE
2593  lhgt = 500 + ihgt - kdata(i,mk)
2594 C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT
2595  mk = mk + 1
2596  IF (mstack(1,mk).GE.16384) THEN
2597  mk = mk + 1
2598  END IF
2599 C PROCESS LEVEL DATA
2600 C PRINT *,'LEVEL DATA'
2601  DO 2000 l = 1, 43
2602  2020 CONTINUE
2603 C PRINT *,'DESC',MK,MSTACK(1,MK),JK
2604  isw = 0
2605 C HEIGHT INCREMENT
2606  IF (mstack(1,mk).EQ.1797) THEN
2607  incrht = kdata(i,mk)
2608 C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT
2609  mk = mk + 1
2610  IF (lhgt.LT.(9250+ihgt)) THEN
2611  lhgt = ihgt + 500 - incrht
2612  ELSE
2613  lhgt = ihgt + 9250 -incrht
2614  END IF
2615  END IF
2616 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
2617 C AT THIS POINT
2618  lhgt = lhgt + incrht
2619 C PRINT *,'LEVEL ',L,LHGT
2620  IF (l.EQ.37) THEN
2621  lhgt = lhgt + incrht
2622  END IF
2623  jk = jk + 1
2624 C SAVE DESCRIPTOR
2625  kprofl(jk) = 1798
2626 C SAVE SCALE
2627  kprof2(jk) = 0
2628 C SAVE DATA
2629  kset2(jk) = lhgt
2630 C PRINT *,KPROFL(JK),KSET2(JK),JK
2631  isw = 0
2632  icon = 1
2633  DO 800 j = 1, 10
2634 750 CONTINUE
2635  IF (mstack(1,mk).EQ.1797) THEN
2636  GO TO 2020
2637  ELSE IF (mstack(1,mk).EQ.6432) THEN
2638 C HI/LO MODE
2639  isw = isw + 1
2640  ELSE IF (mstack(1,mk).EQ.6434) THEN
2641 C Q/C TEST
2642  isw = isw + 2
2643  ELSE IF (mstack(1,mk).EQ.2070) THEN
2644  IF (icon.EQ.1) THEN
2645 C FIRST PASS - U,V CONSENSUS
2646  isw = isw + 4
2647  icon = icon + 1
2648  ELSE
2649 C SECOND PASS - W CONSENSUS
2650  isw = isw + 64
2651  END IF
2652  ELSE IF (mstack(1,mk).EQ.2819) THEN
2653 C U VECTOR VALUE
2654  isw = isw + 8
2655  IF (kdata(i,mk).GE.2047) THEN
2656  vectu = 32767
2657  ELSE
2658  vectu = kdata(i,mk)
2659  END IF
2660  mk = mk + 1
2661  GO TO 800
2662  ELSE IF (mstack(1,mk).EQ.2820) THEN
2663 C V VECTOR VALUE
2664  isw = isw + 16
2665  IF (kdata(i,mk).GE.2047) THEN
2666  vectv = 32767
2667  ELSE
2668  vectv = kdata(i,mk)
2669  END IF
2670  IF (iand(isw,1).NE.0) THEN
2671  IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
2672 C SAVE DD DESCRIPTOR
2673  jk = jk + 1
2674  kprofl(jk) = 2817
2675  kprof2(jk) = 0
2676  kset2(jk) = 32767
2677 C SAVE FFF DESCRIPTOR
2678  jk = jk + 1
2679  kprofl(jk) = 2818
2680  kprof2(jk) = 1
2681  kset2(jk) = 32767
2682  ELSE
2683  CALL w3fc05 (vectu,vectv,dir,spd)
2684  ndir = dir
2685  spd = spd
2686  nspd = spd
2687 C PRINT *,' ',NDIR,NSPD
2688 C SAVE DD DESCRIPTOR
2689  jk = jk + 1
2690  kprofl(jk) = 2817
2691  kprof2(jk) = 0
2692  kset2(jk) = ndir
2693 C IF (I.EQ.1) THEN
2694 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
2695 C ENDIF
2696 C SAVE FFF DESCRIPTOR
2697  jk = jk + 1
2698  kprofl(jk) = 2818
2699  kprof2(jk) = 1
2700  kset2(jk) = nspd
2701 C IF (I.EQ.1) THEN
2702 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
2703 C ENDIF
2704  END IF
2705  mk = mk + 1
2706  GO TO 800
2707  END IF
2708  ELSE IF (mstack(1,mk).EQ.2866) THEN
2709 C SPEED STD DEVIATION
2710  isw = isw + 32
2711 C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568
2712  ELSE IF (mstack(1,mk).EQ.5568) THEN
2713 C SIGNAL POWER
2714  isw = isw + 128
2715  ELSE IF (mstack(1,mk).EQ.2822) THEN
2716 C W COMPONENT
2717  isw = isw + 256
2718  ELSE IF (mstack(1,mk).EQ.2867) THEN
2719 C VERT STD DEVIATION
2720  isw = isw + 512
2721  ELSE
2722  mk = mk + 1
2723  GO TO 750
2724  END IF
2725  jk = jk + 1
2726 C SAVE DESCRIPTOR
2727  kprofl(jk) = mstack(1,mk)
2728 C SAVE SCALE
2729  kprof2(jk) = mstack(2,mk)
2730 C SAVE DATA
2731  kset2(jk) = kdata(i,mk)
2732  mk = mk + 1
2733 C PRINT *,L,'TEST ',JK,KPROFL(JK),KSET2(JK)
2734  800 CONTINUE
2735  850 CONTINUE
2736  IF (isw.NE.1023) THEN
2737  print *,'LEVEL ERROR PROCESSING PROFILER',isw
2738  iptr(1) = 202
2739  RETURN
2740  END IF
2741  2000 CONTINUE
2742 C MOVE DATA BACK INTO KDATA ARRAY
2743  DO 5000 ll = 1, jk
2744 C DATA
2745  kdata(i,ll) = kset2(ll)
2746  5000 CONTINUE
2747  3000 CONTINUE
2748  DO 5005 ll = 1, jk
2749 C DESCRIPTOR
2750  mstack(1,ll) = kprofl(ll)
2751 C SCALE
2752  mstack(2,ll) = kprof2(ll)
2753 C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP
2754 C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4)
2755  5005 CONTINUE
2756  iptr(31) = jk
2757  RETURN
2758  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
w3fc05
subroutine w3fc05(U, V, DIR, SPD)
Given the true (Earth oriented) wind components compute the wind direction and speed.
Definition: w3fc05.f:29
fi7810
subroutine fi7810(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
Reformat profiler edition 2 data.
Definition: w3fi78.f:2460
fi7806
subroutine fi7806(IPTR, LX, LY, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, KDESC, IWORK, JDESC, MAXR, MAXD)
Process operator descriptors.
Definition: w3fi78.f:1762
fi7801
subroutine fi7801(IPTR, IDENT, MSGA, ISTACK, IWORK, ANAME, KDATA, IVALS, MSTACK, AUNITS, KDESC, MWIDTH, MREF, MSCALE, KNR, INDEX, MAXR, MAXD, IUNITB, IUNITD)
Data extraction.
Definition: w3fi78.f:678
w3fi78
subroutine w3fi78(IPTR, IDENT, MSGA, ISTACK, MSTACK, KDATA, KNR, INDEX, MAXR, MAXD, IUNITB, IUNITD)
This set of routines will decode a BUFR message and place information extracted from the BUFR message...
Definition: w3fi78.f:309
fi7809
subroutine fi7809(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
Reformat profiler w hgt increments.
Definition: w3fi78.f:2067
fi7808
subroutine fi7808(IPTR, IWORK, LF, LX, LY, JDESC, MAXD)
Program history log:
Definition: w3fi78.f:2009
fi7803
subroutine fi7803(IPTR, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, JDESC, MAXR, MAXD)
Process compressed data.
Definition: w3fi78.f:1151
fi7807
subroutine fi7807(IPTR, IWORK, ITBLD, JDESC, MAXD)
Process queue descriptor.
Definition: w3fi78.f:1903
fi7804
subroutine fi7804(IPTR, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, JDESC, MAXR, MAXD)
Process serial data.
Definition: w3fi78.f:1420
fi7805
subroutine fi7805(IPTR, IDENT, MSGA, IWORK, LX, LY, KDATA, LL, KNR, MSTACK, MAXR, MAXD)
Process a replication descriptor.
Definition: w3fi78.f:1589
fi7802
subroutine fi7802(IPTR, IDENT, MSGA, KDATA, KDESC, LL, MSTACK, AUNITS, MWIDTH, MREF, MSCALE, JDESC, IVALS, J, MAXR, MAXD)
Process standard descriptor.
Definition: w3fi78.f:995