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