NCEPLIBS-w3emc 2.12.0
Loading...
Searching...
No Matches
w3fi78.f
Go to the documentation of this file.
1C> @file
2C> @brief BUFR Message decoder.
3C> @author Bill Cavanaugh @date 1988-08-31
4
5C> This set of routines will decode a BUFR message and
6C> place information extracted from the BUFR message into selected
7C> arrays for the user.The array kdata can now be sized by the user
8C> by indicating the maximum number of substes and the maximum
9C> number of descriptors that are expected in the course of decoding
10C> selected input data. This allows for realistic sizing of kdata
11C> and the mstack arrays. This version also allows for the inclusion
12C> of the unit numbers for tables b and d into the
13C> argument list. This routine does not include ifod processing.
14C>
15C> Program history log:
16C> - Bill Cavanaugh 88-08-31
17C> - Bill Cavanaugh 90-12-07 Now utilizing gbyte routines to gather
18C> and separate bit fields. This should improve
19C> (decrease) the time it takes to decode any
20C> BUFR message. Have entered coding that will
21C> permit processing BUFR editions 1 and 2.
22C> improved and corrected the conversion into
23C> ifod format of decoded BUFR messages.
24C> - Bill Cavanaugh 91-01-18 Program/routines modified to properly handle
25C> serial profiler data.
26C> - Bill Cavanaugh 91-04-04 Modified to handle text supplied thru
27C> descriptor 2 05 yyy.
28C> - Bill Cavanaugh 91-04-17 Errors in extracting and scaling data
29C> corrected. Improved handling of nested queue descriptors is added.
30C> - Bill Cavanaugh 91-05-10 Array 'data' has been enlarged to real*8
31C> to better contain very large numbers more accurately. the preious size
32C> real*4 could not contain sufficient significant digits. Coding has been
33C> introduced to process new table c descriptor 2 06 yyy which permits in
34C> line processing of a local descriptor even if the descriptor is not
35C> contained in the users table b. A second routine to process ifod messages
36C> (ifod0) has been removed in favor of the improved processing of the one
37C> remaining (ifod1). New coding has been introduced to permit processing of
38C> BUFR messages based on BUFR edition up to and including edition 2. Please
39C> note increased size requirements for arrays ident(20) and iptr(40).
40C> - Bill Cavanaugh 91-07-26 Add array mtime to calling sequence to
41C> permit inclusion of receipt/transfer times to ifod messages.
42C> - Bill Cavanaugh 91-09-25 All processing of decoded BUFR data into
43C> ifod (a local use reformat of BUFR data) has been isolated from this set
44C> of routines. For those interested in the ifod form, see w3fl05() in the
45C> w3lib routines.
46C> Processing of BUFR messages containing delayed replication has been altered
47C> so that single subsets (reports) and and a matching descriptor list for
48C> that particular subset will be passed to the user will be passed to the
49C> user one at a time to assure that each subset can be fully defined with a
50C> minimum of reprocessing.
51C> Processing of associated fields has been tested with messages containing
52C> non-compressed data.
53C> In order to facilitate user processing a matching list of scale factors are
54C> included with the expanded descriptor list (mstack).
55C> - Bill Cavanaugh 91-11-21 Processing of descriptor 2 03 yyy
56C> has corrected to agree with fm94 standards.
57C> - Bill Cavanaugh 91-12-19 Calls to fi7803() and fi7804() have been
58C> corrected to agree called program argument list. Some additional entries
59C> have been included for communicating with data access routines. Additional
60C> error exit provided for the case where table b is damaged.
61C> - Bill Cavanaugh 92-01-24 Routines fi7801(), fi7803() and fi7804()
62C> have been modified to handle associated fields all descriptors are set to
63C> echo to mstack(1,n)
64C> - Bill Cavanaugh 92-05-21 Further expansion of information collected
65C> from within upper air soundings has produced the necessity to expand some
66C> of the processing and output arrays. (see remarks below)
67C> - Bill Cavanaugh 92-06-29 Corrected descriptor denoting height of
68C> each wind level for profiler conversions.
69C> - Bill Cavanaugh 92-07-23 Expansion of table b requires adjustment
70C> of arrays to contain table b values needed to assist in the decoding
71C> process.
72C> ARRAYS CONTAINING DATA FROM TABLE B
73C> - KDESC Descriptor
74C> - ANAME Descriptor name
75C> - AUNITS Units for descriptor
76C> - MSCALE Scale for value of descriptor
77C> - MREF Reference value for descriptor
78C> - MWIDTH Bit width for value of descriptor
79C> - Bill Cavanaugh 92-09-09 First encounter with operator descriptor
80C> 2 05 yyy showed error in decoding. That error is corrected with this
81C> implementation. Further testing of upper air data has encountered
82C> the condition of large (many level) soundings arrays in the decoder have
83C> been expanded (again) to allow for this condition.
84C> - Bill Cavanaugh 92-10-02 Modified routine to reformat profiler data
85C> (fi7809) to show descriptors, scale value and data in proper order.
86C> Corrected an error that prevented user from assigning the second dimension
87C> of kdata(500,*).
88C> - Bill Cavanaugh 92-10-20 Removed error that prevented full implementation
89C> of previous corrections and made corrections to table b to bring it up to
90C> date. changes include proper reformat of profiler data and user capability
91C> for assigning second dimension of kdata array.
92C> - Bill Cavanaugh 92-12-09 Thanks to dennis keyser for the suggestions and
93C> coding, this implementation will allow the inclusion of unit numbers for
94C> tables b & d, and in addition allows for realistic sizing of kdata and
95C> mstack arrays by the user. As of this implementation, the upper size limit
96C> for a BUFR message allows for a message size greater than 10000 bytes.
97C> - Bill Cavanaugh 93-01-26 Subroutine fi7810() has been added to permit
98C> reformatting of profiler data in edition 2.
99C>
100C> @param[in] MSGA Array containing supposed BUFR message size is determined
101C> by user, can be greater than 10000 bytes.
102C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
103C> a BUFR message.
104C> @param[in] MAXD Maximum number of descriptor combinations that may be
105C> processed; Upper air data and some satellite data require a value for maxd
106C> of 1600, but for most other data a value for maxd of 500 will suffice.
107C> @param[in] IUNITB Unit number of data set holding table b
108C> @param[in] IUNITD Unit number of data set holding table d
109C> @param KNR
110C> @param[out] ISTACK Original array of descriptors extracted from source
111C> BUFR message.
112C> @param[out] MSTACK (A,B)
113C> - Level b - descriptor number (limited to value of
114C> input argument maxd)
115C> - level a = 1 descriptor = 2 10**N Scaling to return to original value
116C> @param[out] IPTR Utility array
117C> - IPTR( 1)- Error return.
118C> - IPTR( 2)- Byte count section 1.
119C> - IPTR( 3)- Pointer to start of section 1.
120C> - IPTR( 4)- Byte count section 2.
121C> - IPTR( 5)- Pointer to start of section 2.
122C> - IPTR( 6)- Byte count section 3.
123C> - IPTR( 7)- Pointer to start of section 3.
124C> - IPTR( 8)- Byte count section 4.
125C> - IPTR( 9)- Pointer to start of section 4.
126C> - IPTR(10)- Start of requested subset, reserved for dar.
127C> - IPTR(11)- Current descriptor ptr in iwork.
128C> - IPTR(12)- Last descriptor pos in iwork.
129C> - IPTR(13)- Last descriptor pos in istack.
130C> - IPTR(14)- Number of table b entries.
131C> - IPTR(15)- Requested subset pointer, reserved for dar.
132C> - IPTR(16)- Indicator for existance of section 2.
133C> - IPTR(17)- Number of reports processed.
134C> - IPTR(18)- Ascii/text event.
135C> - IPTR(19)- Pointer to start of BUFR message.
136C> - IPTR(20)- Number of lines from table d.
137C> - IPTR(21)- Table b switch.
138C> - IPTR(22)- Table d switch.
139C> - IPTR(23)- Code/flag table switch.
140C> - IPTR(24)- Aditional words added by text info.
141C> - IPTR(25)- Current bit number.
142C> - IPTR(26)- Data width change.
143C> - IPTR(27)- Data scale change.
144C> - IPTR(28)- Data reference value change.
145C> - IPTR(29)- Add data associated field.
146C> - IPTR(30)- Signify characters.
147C> - IPTR(31)- Number of expanded descriptors in mstack.
148C> - IPTR(32)- Current descriptor segment f.
149C> - IPTR(33)- Current descriptor segment x.
150C> - IPTR(34)- Current descriptor segment y.
151C> - IPTR(35)- Unused.
152C> - IPTR(36)- Next descriptor may be undecipherable.
153C> - IPTR(37)- Unused.
154C> - IPTR(38)- Unused.
155C> - IPTR(39)- Delayed replication flag.
156C> - 0 No delayed replication.
157C> - 1 Message contains delayed replication.
158C> - IPTR(40)- Number of characters in text for curr descriptor.
159C> @param[out] IDENT Array contains message information extracted from BUFR
160C> Message.
161C> - IDENT(1) Edition number (byte 4, section 1)
162C> - IDENT(2) Originating center (bytes 5-6, section 1)
163C> - IDENT(3) Update sequence (byte 7, section 1)
164C> - IDENT(4) Optional section (byte 8, section 1)
165C> - IDENT(5) BUFR message type (byte 9, section 1)
166C> - 0 = Surface (land).
167C> - 1 = Surface (ship).
168C> - 2 = Vertical soundings other than satellite.
169C> - 3 = Vertical soundings (satellite).
170C> - 4 = Sngl lvl upper-air other than satellite.
171C> - 5 = Sngl lvl upper-air (satellite).
172C> - 6 = Radar.
173C> - IDENT(6) BUFR msg sub-type (byte 10, section 1).
174C> | TYPE | SBTYP |
175C> | :--- | :---- |
176C> | 2 | 7 = PROFILER |
177C> - IDENT(7) (bytes 11-12, section 1).
178C> - IDENT(8) Year of century (byte 13, section 1).
179C> - IDENT(9) Month of year (byte 14, section 1).
180C> - IDENT(10) Day of month (byte 15, section 1).
181C> - IDENT(11) Hour of day (byte 16, section 1).
182C> - IDENT(12) Minute of hour (byte 17, section 1).
183C> - IDENT(13) Rsvd by adp centers (byte 18, section 1).
184C> - IDENT(14) Nr of data subsets (byte 5-6, section 3).
185C> - IDENT(15) Observed flag (byte 7, bit 1, section 3).
186C> - IDENT(16) Compression flag (byte 7, bit 2, section 3).
187C> - IDENT(17) Master table number(byte 4, section 1, ed 2 or gtr).
188C> @param[out] KDATA Array containing decoded reports from BUFR message.
189C> KDATA(report number,parameter number)
190C> (Report number limited to value of input argument maxr and parameter number
191C> limited to value of input argument maxd)
192C> Arrays containing data from table b:
193C> - ANAME Descriptor name
194C> - AUNITS Units for descriptor
195C> - MSCALE Scale for value of descriptor
196C> - MREF Reference value for descriptor
197C> - MWIDTH Bit width for value of descriptor
198C> @param[out] INDEX Pointer to available subset
199C>
200C> Error returns:
201C> IPTR(1):
202C> - 1 'BUFR' Not found in first 125 characters
203C> - 2 '7777' Not found in location determined by
204C> by using counts found in each section. one or
205C> more sections have an erroneous byte count or
206C> characters '7777' are not in test message.
207C> - 3 Message contains a descriptor with f=0 that does
208C> not exist in table b.
209C> - 4 Message contains a descriptor with f=3 that does
210C> not exist in table d.
211C> - 5 Message contains a descriptor with f=2 with the
212C> value of x outside the range 1-5.
213C> - 6 Descriptor element indicated to have a flag value
214C> does not have an entry in the flag table.
215C> (to be activated)
216C> - 7 Descriptor indicated to have a code value does
217C> not have an entry in the code table.
218C> (to be activated)
219C> - 8 Error reading table d
220C> - 9 Error reading table b
221C> - 10 Error reading code/flag table
222C> - 11 Descriptor 2 04 004 not followed by 0 31 021
223C> - 12 Data descriptor operator qualifier does not follow
224C> delayed replication descriptor.
225C> - 13 Bit width on ascii characters not a multiple of 8
226C> - 14 Subsets = 0, no content bulletin
227C> - 20 Exceeded count for delayed replication pass
228C> - 21 Exceeded count for non-delayed replication pass
229C> - 27 Non zero lowest on text data
230C> - 28 Nbinc not nr of characters
231C> - 29 Table b appears to be damaged
232C> - 99 No more subsets (reports) available in current
233C> BUFR mesage
234C> - 400 Number of subsets exceeds the value of input
235C> argument maxr; must increase maxr to value of
236C> ident(14) in calling program
237C> - 401 Number of parameters (and associated fields)
238C> exceeds limits of this program.
239C> - 500 Value for nbinc has been found that exceeds
240C> standard width plus any bit width change.
241C> check all bit widths up to point of error.
242C> - 501 Corrected width for descriptor is 0 or less
243C>
244C> On the initial call to w3fi78() with a BUFR message the argument
245C> index must be set to zero (index = 0). On the return from w3fi78()
246C> 'index' will be set to the next available subset/report. When
247C> there are no more subsets available a 99 err return will occur.
248C>
249C> If the original BUFR message does not contain delayed replication
250C> the BUFR message will be completely decoded and 'index' will point
251C> to the first decoded subset. The users will then have the option
252C> of indexing through the subsets on their own or by recalling this
253C> routine (without resetting 'index') to have the routine do the
254C> indexing.
255C>
256C> If the original BUFR message does contain delayed replication
257C> one subset/report will be decoded at a time and passed back to
258C> the user. This is not an option.
259C>
260C> =============================================
261C> TO USE THIS ROUTINE
262C> --------------------------------
263C> - 1. Read in BUFR message
264C> - 2. Set index = 0
265C> - 3. CALL W3FI78()
266C> - 4.
267C> @code
268C> IF (IPTR(1).EQ.99) THEN
269C> NO MORE SUBSETS
270C> EITHER GO TO 1
271C> OR TERMINATE IN NO MORE BUFR MESSAGES
272C> END IF
273C> @endcode
274C> - 5.
275C> @code
276C> IF (IPTR(1).NE.0) THEN
277C> ERROR CONDITION
278C> EITHER GO TO 1
279C> OR TERMINATE IN NO MORE BUFR MESSAGES
280C> END IF
281C> @endcode
282C> - 6. The value of index indicates the active subset so
283C> @code
284C> IF INTERESTED IN GENERATING AN IFOD MESSAGE
285C> W3FL05 ( )
286C> ELSE
287C> PROCESS DECODED INFORMATION AS REQUIRED
288C> END IF
289C> @endcode
290C> - 7. GO TO 3
291C>
292C> The arrays to contain the output information are defined as follows:
293C> - KDATA(A,B) Is the a data entry (integer value) where a is the maximum
294C> number of reports/subsets that may be contained in the bufr message (this
295C> is now set to "maxr" which is passed as an input argument to w3fi78()), and
296C> where b is the maximum number of descriptor combinations that may be
297C> processed (this is now set to "maxd" which is also passed as an input
298C> argument to w3fi78(); Upper air data and some satellite data require a
299C> value for maxd of 1600, but for most other data a value for maxd of 500
300C> will suffice).
301C> - MSTACK(1,B) Contains the descriptor that matches the data entry (max.
302C> value for b is now "maxd" which is passed as an input argument to w3fi78())
303C> - MSTACK(2,B) Is the scale (power of 10) to be applied to the data (max.
304C> value for b is now "maxd" which is passed as an input argument to w3fi78())
305C>
306C> @author Bill Cavanaugh @date 1988-08-31
307 SUBROUTINE w3fi78(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
308 * MAXR,MAXD,IUNITB,IUNITD)
309C
310 CHARACTER*40 ANAME(700)
311 CHARACTER*24 AUNITS(700)
312C
313C
314C
315 INTEGER MSGA(*)
316 INTEGER IPTR(*)
317 INTEGER KDATA(MAXR,MAXD)
318 INTEGER MSTACK(2,MAXD)
319C
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
330C
331 CHARACTER*4 DIRID(2)
332C
333 LOGICAL SEC2
334C
335 SAVE
336C
337C PRINT *,' W3FI78 DECODER'
338C INITIALIZE ERROR RETURN
339 iptr(1) = 0
340 IF (index.GT.0) THEN
341C HAVE RE-ENTRY
342 index = index + 1
343C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
344 IF (index.GT.ident(14)) THEN
345C 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,
351C
352 * ivals,mstack,
353 * aunits,kdesc,mwidth,mref,mscale,knr,index,maxr,maxd,
354 * iunitb,iunitd)
355C
356 END IF
357 END IF
358 RETURN
359 ELSE
360 index = 1
361C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
362 END IF
363 iptr(39) = 0
364C 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
373C 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
384C TEST FOR EDITION NUMBER
385C ======================
386 CALL gbyte (msga,ident(1),inofst+24,8)
387C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE'
388C
389 IF (ident(1).GE.2) THEN
390C 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)
395C IF (ILAST.EQ.926365495) THEN
396C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
397C END IF
398 inofst = inofst + 32
399C GET SECTION 1 COUNT
400 iptr(3) = inofst
401 CALL gbyte (msga,ivals,inofst,24)
402C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
403 inofst = inofst + 24
404 iptr( 2) = ivals(1)
405C GET MASTER TABLE
406 CALL gbyte (msga,ivals,inofst,8)
407 inofst = inofst + 8
408 ident(17) = ivals(1)
409C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
410 ELSE
411 iptr(3) = inofst
412C GET SECTION 1 COUNT
413 CALL gbyte (msga,ivals,inofst,24)
414C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
415 inofst = inofst + 32
416 iptr( 2) = ivals(1)
417 END IF
418C ======================
419C ORIGINATING CENTER
420 CALL gbyte (msga,ivals,inofst,16)
421 inofst = inofst + 16
422 ident(2) = ivals(1)
423C UPDATE SEQUENCE
424 CALL gbyte (msga,ivals,inofst,8)
425 inofst = inofst + 8
426 ident(3) = ivals(1)
427C 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
433C PRINT *,' NO OPTIONAL SECTION 2'
434 sec2 = .false.
435 END IF
436 inofst = inofst + 8
437C MESSAGE TYPE
438 CALL gbyte (msga,ivals,inofst,8)
439 ident(5) = ivals(1)
440 inofst = inofst + 8
441C MESSAGE SUB-TYPE
442 CALL gbyte (msga,ivals,inofst,8)
443 ident(6) = ivals(1)
444 inofst = inofst + 8
445C IF BUFR EDITION 0 OR 1 THEN
446C NEXT 2 BYTES ARE BUFR TABLE VERSION
447C ELSE
448C BYTE 11 IS VER NR OF MASTER TABLE
449C 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
455C BYTE 11 IS VER NR OF MASTER TABLE
456 CALL gbyte (msga,ivals,inofst,8)
457 ident(18) = ivals(1)
458 inofst = inofst + 8
459C 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
465C YEAR OF CENTURY
466 CALL gbyte (msga,ivals,inofst,8)
467 ident(8) = ivals(1)
468 inofst = inofst + 8
469C MONTH
470 CALL gbyte (msga,ivals,inofst,8)
471 ident(9) = ivals(1)
472 inofst = inofst + 8
473C DAY
474C PRINT *,'DAY AT ',INOFST
475 CALL gbyte (msga,ivals,inofst,8)
476 ident(10) = ivals(1)
477 inofst = inofst + 8
478C HOUR
479 CALL gbyte (msga,ivals,inofst,8)
480 ident(11) = ivals(1)
481 inofst = inofst + 8
482C MINUTE
483 CALL gbyte (msga,ivals,inofst,8)
484 ident(12) = ivals(1)
485C RESET POINTER (INOFST) TO START OF
486C NEXT SECTION
487C (SECTION 2 OR SECTION 3)
488 inofst = iptr(3) + iptr(2) * 8
489 iptr(4) = 0
490 iptr(5) = inofst
491 IF (sec2) THEN
492C SECTION 2 COUNT
493 CALL gbyte (msga,iptr(4),inofst,24)
494 inofst = inofst + 32
495C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
496 kentry = (iptr(4) - 4) / 14
497C 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
512C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
513 2000 CONTINUE
514 END IF
515C RESET POINTER (INOFST) TO START OF
516C SECTION 3
517 inofst = iptr(5) + iptr(4) * 8
518 END IF
519C BIT OFFSET TO START OF SECTION 3
520 iptr( 7) = inofst
521C SECTION 3 COUNT
522 CALL gbyte (msga,iptr(6),inofst,24)
523C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6)
524 inofst = inofst + 24
525C SKIP RESERVED BYTE
526 inofst = inofst + 8
527C NUMBER OF DATA SUBSETS
528 CALL gbyte (msga,ident(14),inofst,16)
529C
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'
535C
536 iptr(1) = 400
537 RETURN
538 END IF
539 inofst = inofst + 16
540C OBSERVED DATA FLAG
541 CALL gbyte (msga,ivals,inofst,1)
542 ident(15) = ivals(1)
543 inofst = inofst + 1
544C COMPRESSED DATA FLAG
545 CALL gbyte (msga,ivals,inofst,1)
546 ident(16) = ivals(1)
547 inofst = inofst + 7
548C CALCULATE NUMBER OF DESCRIPTORS
549 nrdesc = (iptr( 6) - 8) / 2
550 iptr(12) = nrdesc
551 iptr(13) = nrdesc
552C EXTRACT DESCRIPTORS
553 CALL gbytes (msga,istack,inofst,16,0,nrdesc)
554C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
555 DO 10 l = 1, nrdesc
556 iwork(l) = istack(l)
557C PRINT *,L,ISTACK(L)
558 10 CONTINUE
559 iptr(13) = nrdesc
560C RESET POINTER TO START OF SECTION 4
561 inofst = iptr(7) + iptr(6) * 8
562C BIT OFFSET TO START OF SECTION 4
563 iptr( 9) = inofst
564C SECTION 4 COUNT
565 CALL gbyte (msga,ivals,inofst,24)
566C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
567 iptr( 8) = ivals(1)
568 inofst = inofst + 32
569C SET FOR STARTING BIT OF DATA
570 iptr(25) = inofst
571C FIND OUT IF '7777' TERMINATOR IS THERE
572 inofst = iptr(9) + iptr(8) * 8
573 CALL gbyte (msga,ivals,inofst,32)
574C 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
582C
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)
586C
587C PRINT *,'HAVE RETURNED FROM FI7801'
588C IF (IPTR(1).NE.0) THEN
589C RETURN
590C END IF
591C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
592 IF (ident(5).EQ.2) THEN
593 IF (ident(6).EQ.7) THEN
594C PRINT *,'BASIC PROFILER DATA'
595C DO 153 I = 1, KNR(INDEX)
596C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
597C 153 CONTINUE
598C PRINT *,'REFORMAT PROFILER DATA'
599C
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
605C DO 151 I = 1, 40
606C IF (I.LE.20) THEN
607C PRINT *,'IPTR(',I,')=',IPTR(I),
608C * ' IDENT(',I,')= ',IDENT(I)
609C ELSE
610C PRINT *,'IPTR(',I,')=',IPTR(I)
611C END IF
612C 151 CONTINUE
613 IF (iptr(1).NE.0) THEN
614 RETURN
615 END IF
616C
617C DO 154 I = 1, IPTR(31)
618C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
619C 154 CONTINUE
620 END IF
621 END IF
622 RETURN
623 END
624C
625C> @brief Data extraction
626C> @author Bill Cavanaugh @date 1988-09-01
627
628C> Control the extraction of data from section 4 based on data descriptors.
629C>
630C> Program history log:
631C> - Bill Cavanaugh 1988-09-01
632C> - Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed
633C> data.
634C> - Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with
635C> delayed replication.
636C> - Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
637C>
638C> @param[in] IPTR See w3fi78() routine docblock
639C> @param[in] IDENT See w3fi78() routine docblock
640C> @param[in] MSGA Array containing bufr message
641C> @param[inout] ISTACK Original array of descriptors extracted from
642C> source bufr message.
643C> @param[in] MSTACK Working array of descriptors (expanded)and scaling
644C> factor
645C> @param[inout] KDESC Image of current descriptor
646C> @param[in] INDEX
647C> @param[in] MAXR maximum number of reports/subsets that may be
648C> contained in a bufr message
649C> @param[in] MAXD Maximum number of descriptor combinations that
650C> may be processed; upper air data and some satellite data require a value
651C> for maxd of 1600, but for most other data a value for maxd of 500 will suffice
652C> @param[in] IUNITB Unit number of data set holding table b
653C> @param[in] IUNITD Unit number of data set holding table d
654C> @param[out] IWORK Working descriptor list
655C> @param[out] KDATA Array containing decoded reports from bufr message.
656C> KDATA(Report number,parameter number)
657C> (report number limited to value of input argument maxr and parameter
658C> number limited to value of input argument maxd)
659C> arrays containing data from table b
660C> @param[out] ANAME Descriptor name
661C> @param[out] AUNITS Units for descriptor
662C> @param[out] MSCALE Scale for value of descriptor
663C> @param[out] MREF Reference value for descriptor
664C> @param[out] MWIDTH Bit width for value of descriptor
665C> @param IVALS
666C> @param KNR
667C>
668C> Error return:
669C> IPTR(1)
670C> - = 8 Error reading table b
671C> - = 9 Error reading table d
672C> - = 11 Error opening table b
673C>
674C> @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
680C
681 CHARACTER*40 ANAME(*)
682 CHARACTER*24 AUNITS(*)
683C
684C
685 INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*)
686C
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(*)
697C
698 INTEGER MSTACK(2,MAXD),KK
699C
700 INTEGER JDESC
701 INTEGER INDEX
702 INTEGER ITEST(30)
703C
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/
710C
711C PRINT *,' DECOLL FI7801'
712 IF (index.GT.1) THEN
713 GO TO 1000
714 END IF
715C --------- 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
723C INITIALIZE OUTPUT AREA
724C SET POINTER TO BEGINNING OF DATA
725C SET BIT
726 iptr(17) = 1
727 1000 CONTINUE
728C IPTR(12) = IPTR(13)
729 ll = 0
730 iptr(11) = 1
731 IF (iptr(10).EQ.0) THEN
732C RE-ENTRY POINT FOR MULTIPLE
733C 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
741C PRINT *,'FI7801 - RPT',IPTR(17),' STARTS AT',IPTR(25)
742 iptr(24) = 0
743 iptr(31) = 0
744C POINTING AT NEXT AVAILABLE DESCRIPTOR
745 mm = 0
746 IF (iptr(21).EQ.0) THEN
747C PRINT *,' READING TABLE B'
748 DO 150 i = 1, 700
749 iptr(21) = i
750C
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
764C PRINT *,I
765C WRITE(6,21) MF,MX,MY,KDESC(I),
766C * (ANAME(I)(K:K),K=1,40),
767C * (AUNITS(I)(K:K),K=1,24),
768C * 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
775C
776C CLOSE(UNIT=IUNITB,STATUS='KEEP')
777C
778 iptr(21) = 1
779 END IF
780C DO WHILE MM <= MAXD
781 10 CONTINUE
782C PROCESS THRU THE FOLLOWING
783C 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
789C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
790 IF (iptr(11).GT.iptr(12)) THEN
791C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
792 IF (ident(16).NE.0) THEN
793C PRINT *,' PROCESSING COMPRESSED REPORTS'
794C REFORMAT DATA FROM DESCRIPTOR
795C FORM TO USER FORM
796 RETURN
797 ELSE
798C WRITE (6,1)
799C 1 FORMAT (1H1)
800C 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
809C RESET POINTERS
810 ll = 0
811 iptr(1) = 0
812 iptr(11) = 1
813 iptr(12) = iptr(13)
814C IS THIS LAST REPORT ?
815C PRINT *,'READY',IPTR(39),INDEX
816 IF (iptr(39).GT.0) THEN
817 IF (index.GT.0) THEN
818C 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
826C GET NEXT DESCRIPTOR
827 CALL fi7808 (iptr,iwork,lf,lx,ly,jdesc,maxd)
828C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
829C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
830C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
831C * ' FOR LOC',IPTR(17),IPTR(25)
832 IF (iptr(11).GT.1600) THEN
833 iptr(1) = 401
834 RETURN
835 END IF
836C
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
845C REPLICATION PROCESSING
846 IF (lf.EQ.1) THEN
847C ---------- 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
853C PRINT *,'FI7801-1',KPRM,MSTACK(1,KPRM),
854C * 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
862C
863C 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
872C PRINT *,'FI7801-2',KPRM,MSTACK(1,KPRM),
873C * 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
881C DESCRIPTOR SEQUENCE STRINGS
882 ELSE IF (lf.EQ.3) THEN
883C PRINT *,'F3 SEQUENCE DESCRIPTOR'
884 IF (iptr(22).EQ.0) THEN
885C READ IN TABLE D, BUT JUST ONCE
886 ierr = 0
887C 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
898C PRINT 16,(ITBLD(I,L),L=1,11)
899 GO TO 50
900 END IF
901 25 CONTINUE
902C 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
914C
915C STANDARD DESCRIPTOR PROCESSING
916 ELSE
917C 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)
921C 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
936C END IF
937C END DO WHILE
938 200 CONTINUE
939 IF (ident(16).NE.0) THEN
940C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
941 ELSE
942C 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
954C> @brief Process standard descriptor
955C> @author Bill Cavanaugh @date 1988-09-01
956
957C> Process a standard descriptor (f = 0) and store data
958C> in output array.
959C>
960C> Program history log:
961C> - Bill Cavanaugh 1988-09-01
962C> - Bill Cavanaugh 1991-04-04 Changed to pass width of text fields in bytes
963C>
964C> @param[in] IPTR See w3fi78 routine docblock
965C> @param[in] IDENT See w3fi78 routine docblock
966C> @param[in] MSGA Array containing bufr message
967C> @param[inout] KDATA Array containing decoded reports from bufr message.
968C> KDATA(Report number,parameter number)
969C> (report number limited to value of input argument maxr and parameter
970C> number limited to value of input argument maxd)
971C> @param[inout] KDESC Image of current descriptor
972C> @param[in] MSTACK
973C> @param[in] MAXR maximum number of reports/subsets that may be contained in
974C> a bufr message
975C> @param[in] MAXD Maximum number of descriptor combinations that may be
976C> processed; upper air data and some satellite data require a value for maxd
977C> of 1600, but for most other data a value for maxd of 500 will suffice
978C> Arrays containing data from table B
979C> @param[out] AUNITS Units for descriptor
980C> @param[out] MSCALE Scale for value of descriptor
981C> @param[out] MREF Reference value for descriptor
982C> @param[out] MWIDTH Bit width for value of descriptor
983C> @param LL
984C> @param JDESC
985C> @param IVALS
986C> @param J
987C>
988C> Error return:
989C> IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist
990C> in table b.
991C>
992C> @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
996C TABLE B ENTRY
997 CHARACTER*24 ASKEY
998 CHARACTER*24 AUNITS(*)
999C 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(*)
1008C TABLE B ENTRY
1009C
1010 DATA askey /'CCITT IA5 '/
1011C
1012C PRINT *,' FI7802 - STANDARD DESCRIPTOR PROCESSOR'
1013C GET A MATCH BETWEEN CURRENT
1014C DESCRIPTOR (JDESC) AND
1015C TABLE B ENTRY
1016C IF (KDESC(356).EQ.0) THEN
1017C PRINT *,'FI7802 - KDESC(356) WENT TO ZER0'
1018C IPTR(1) = 600
1019C RETURN
1020C 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
1029C HAVE SKIP FLAG
1030 IF (ident(16).NE.0) THEN
1031C SKIP OVER COMPRESSED DATA
1032C LOWEST
1033 iptr(25) = iptr(25) + iptr(36)
1034C 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
1044C 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
1055C SKIP OVER NON-COMPRESSED DATA
1056C 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'
1065C DO 20 LL = 1, IPTR(14)
1066C PRINT *,LL,KDESC(LL)
1067C 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
1090C HAVE A MATCH
1091C 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
1099C 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
1106C 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
1112C> @brief Process compressed data
1113C> @author Bill Cavanaugh @date 1988-09-01
1114
1115C> Process compressed data and place individual elements
1116C> into output array.
1117C>
1118C> PROGRAM HISTORY LOG:
1119C> - Bill Cavanaugh 1988-09-01
1120C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
1121C> modified to hanle width of fields in bytes.
1122C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
1123C> and uncompressed form gave different results. This has been corrected.
1124C> - Bill Cavanaugh 1991-06-21 Processing of text data has been changed to
1125C> provide exact reproduction of all characters.
1126C>
1127C> @param[in] IPTR See w3fi78() routine docblock
1128C> @param[in] IDENT See w3fi78() routine docblock
1129C> @param[in] MSGA Array containing bufr message,mstack,
1130C> @param[in] IVALS Array of single parameter values
1131C> @param[inout] J
1132C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
1133C> a bufr message.
1134C> @param[in] MAXD Maximum number of descriptor combinations that may be
1135C> processed; Upper air data and some satellite data require a value for maxd
1136C> of 1600, but for most other data a value for maxd of 500 will suffice.
1137C> @param[out] KDATA Array containing decoded reports from bufr message.
1138C> KDATA(Report number,parameter number)
1139C> (report number limited to value of input argument maxr and parameter number
1140C> limited to value of input argument maxd)
1141C> Arrays containing data from table B.
1142C> @param[out] MSCALE Scale for value of descriptor
1143C> @param[out] MREF Reference value for descriptor
1144C> @param[out] MWIDTH Bit width for value of descriptor
1145C> @param MSTACK
1146C> @param JDESC
1147C>
1148C> @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
1153C
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)
1163C
1164 LOGICAL TEXT
1165C
1166 INTEGER MSK(28)
1167C
1168C
1169 DATA msk /1,3,7,15,31,63,127,
1170C 1 2 3 4 5 6 7
1171 * 255,511,1023,2047,4095,
1172C 8 9 10 11 12
1173 * 8191,16383,32767,65535,
1174C 13 14 15 16
1175 * 131071,262143,524287,
1176C 17 18 19
1177 * 1048575,2097151,4194303,
1178C 20 21 22
1179 * 8388607,16777215,33554431,
1180C 23 24 25
1181 * 67108863,134217727,268435455/
1182C 26 27 28
1183C
1184C PRINT *,' FI7803 COMPR J=',J,' MWIDTH(J) =',MWIDTH(J),
1185C * ' 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
1191C PRINT *,'DESCRIPTOR',KPRM
1192 IF (.NOT.text) THEN
1193 IF (iptr(29).GT.0) THEN
1194C WORKING WITH ASSOCIATED FIELDS HERE
1195 iptr(31) = iptr(31) + 1
1196 kprm = iptr(31) + iptr(24)
1197C GET LOWEST
1198 CALL gbyte (msga,lowest,iptr(25),iptr(29))
1199 iptr(25) = iptr(25) + iptr(29)
1200C GET NBINC
1201 CALL gbyte (msga,nbinc,iptr(25),6)
1202 iptr(25) = iptr(25) + 6
1203C 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
1223C SET PARAMETER
1224C ISOLATE STANDARD BIT WIDTH
1225 jwide = mwidth(j) + iptr(26)
1226C SINGLE VALUE FOR LOWEST
1227 nrvals = 1
1228C LOWEST
1229C PRINT *,'PARAM',KPRM
1230 CALL gbyte (msga,lowest,iptr(25),jwide)
1231C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
1232 iptr(25) = iptr(25) + jwide
1233C ISOLATE COMPRESSED BIT WIDTH
1234 CALL gbyte (msga,nbinc,iptr(25),6)
1235C 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
1239C PRINT *,'FOR DESCRIPTOR',JDESC
1240C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' MWIDTH(J)=',
1241C * MWIDTH(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
1242C DO 110 I = 1, KPRM
1243C WRITE (6,111)I,(KDATA(J,I),J=1,6)
1244C 110 CONTINUE
1245 111 FORMAT (1x,5hdata ,i3,6(2x,i10))
1246 iptr(1) = 500
1247C 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
1253C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
1254C IF TEXT EVENT, PROCESS TEXT
1255C GET COMPRESSED VALUES
1256C 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
1263C RECALCULATE TO ORIGINAL VALUES
1264 DO 100 i = 1, nrvals
1265C 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
1276C 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
1293C 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
1300C WRITE (6,80) (DATA(I,KPRM),I=1,10)
1301C 80 FORMAT(2X,10(F10.2,1X))
1302 ELSE IF (text) THEN
1303C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
1304C GET LOWEST
1305C 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
1315C GET NBINC
1316 CALL gbyte (msga,nbinc,iptr(25),6)
1317C 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
1324C 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
1334C 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
1339C CONVERTS ASCII TO EBCIDIC
1340C COMMENT OUT IF NOT IBM370 COMPUTER
1341C PRINT *,IDATA
1342C CALL W3AI39 (IDATA,4)
1343 mstack(1,kprm) = jdesc
1344 mstack(2,kprm) = 0
1345 kdata(n,kprm) = idata
1346C SET FOR NEXT PART
1347 kprm = kprm + 1
1348 iptr(24) = iptr(24) + 1
1349C 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
1361C CONVERTS ASCII TO EBCIDIC
1362C COMMENT OUT IF NOT IBM370 COMPUTER
1363C CALL W3AI39 (IDATA,4)
1364 mstack(1,kprm) = jdesc
1365 mstack(2,kprm) = 0
1366 kdata(n,kprm) = idata
1367C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
1368 nbits = 0
1369 END IF
1370C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
1371C1800 FORMAT (2X,I4,2X,3A4)
1372 1900 CONTINUE
1373 END IF
1374 RETURN
1375 END
1376
1377C> @brief Process serial data.
1378C> @author Bill Cavanaugh @date 1988-09-01
1379
1380C> Process data that is not compressed.
1381C>
1382C> Program history log:
1383C> - Bill Cavanaugh 1988-09-01
1384C> - Bill Cavanaugh 1991-01-18 Modified to properly handle non-compressed
1385C> data.
1386C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
1387C> modified to handle field width in bytes.
1388C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
1389C> and uncompressed form gave different results.
1390C> this has been corrected.
1391C>
1392C> @param[in] IPTR See w3fi78 routine docblock
1393C> @param[in] MSGA Array containing bufr message
1394C> @param[inout] IVALS Array of single parameter values
1395C> @param[inout] J
1396C> @param[in] MAXR Maximum number of reports/subsets that may be
1397C> contained in a bufr message
1398C> @param[in] MAXD Maximum number of descriptor combinations that
1399C> may be processed; upper air data and some satellite
1400C> data require a value for maxd of 1600, but for most
1401C> other data a value for maxd of 500 will suffice
1402C> @param[out] KDATA Array containing decoded reports from bufr message.
1403C> KDATA(report number,parameter number)
1404C> (report number limited to value of input argument maxr and parameter number
1405C> limited to value of input argument maxd)
1406C> arrays containing data from table B
1407C> @param[out] MSCALE Scale for value of descriptor
1408C> @param[out] MREF Reference value for descriptor
1409C> @param[out] MWIDTH Bit width for value of descriptor
1410C> @param MSTACK
1411C> @param LL
1412C> @param JDESC
1413C>
1414C> Error return:
1415C> IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
1416C>
1417C> @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
1421C
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
1430C
1431C
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/
1439C
1440C 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
1445C -------- NOCMP --------
1446C ISOLATE BIT WIDTH
1447 jwide = mwidth(j) + iptr(26)
1448C IF NOT TEXT EVENT, PROCESS
1449 IF (iptr(18).NE.1) THEN
1450C 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)
1460C PRINT *,'FI7804-A',KPRM,MSTACK(1,KPRM),
1461C * 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
1472C GET VALUES
1473C CALL TO GET DATA OF GIVEN BIT WIDTH
1474 CALL gbyte (msga,ivals,iptr(25),jwide)
1475C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
1476 iptr(25) = iptr(25) + jwide
1477C 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
1487C PRINT *,'FI7804-B',KPRM,MSTACK(1,KPRM),
1488C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
1489C IF(JDESC.EQ.2049) THEN
1490C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
1491C END IF
1492C PRINT *,'FI7804 ',KPRM,MSTACK(1,KPRM),
1493C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1494 ELSE
1495C IF TEXT EVENT, PROCESS TEXT
1496C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
1497 nrchrs = iptr(40)
1498 nrbits = nrchrs * 8
1499C 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)
1506C PRINT 1801,KANY,IDATA,IPTR(17),KPRM
1507C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4))
1508C CONVERTS ASCII TO EBCIDIC
1509C COMMENT OUT IF NOT IBM370 COMPUTER
1510C 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
1515C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
1516C * 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
1522C PRINT *,'LAST TEXT WORD'
1523 CALL gbyte (msga,idata,iptr(25),nrbits)
1524 iptr(25) = iptr(25) + nrbits
1525C CONVERTS ASCII TO EBCIDIC
1526C COMMENT OUT IF NOT IBM370 COMPUTER
1527C 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
1534C PRINT 1723,IDATA
1535 1723 FORMAT (12x,z8)
1536 1722 CONTINUE
1537 END IF
1538 kdata(iptr(17),kprm) = idata
1539C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
1540 mstack(1,kprm) = jdesc
1541 mstack(2,kprm) = 0
1542C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
1543C * KDATA(IPTR(17),KPRM)
1544 END IF
1545C TURN OFF TEXT
1546 iptr(18) = 0
1547 END IF
1548 RETURN
1549 END
1550C> @brief Process a replication descriptor.
1551C> @author Bill Cavanaugh @date 1988-09-01
1552
1553C> Process a replication descriptor, must extract number
1554C> of replications of n descriptors from the data stream.
1555C>
1556C> Program history log:
1557C> - Bill Cavanaugh 1988-09-01
1558C>
1559C> @param[in] IWORK Working descriptor list
1560C> @param[in] IPTR See w3fi78 routine docblock
1561C> @param[in] IDENT See w3fi78 routine docblock
1562C> @param[inout] LX X portion of current descriptor
1563C> @param[inout] LY Y portion of current descriptor
1564C> @param[in] MAXR Maximum number of reports/subsets that may be
1565C> contained in a bufr message.
1566C> @param[in] MAXD Maximum number of descriptor combinations that
1567C> may be processed; upper air data and some satellite
1568C> data require a value for maxd of 1600, but for most
1569C> other data a value for maxd of 500 will suffice
1570C> @param[out] KDATA Array containing decoded reports from bufr message.
1571C> KDATA(report number,parameter number)
1572C> (report number limited to value of input argument
1573C> maxr and parameter number limited to value of input
1574C> argument maxd)
1575C> @param MSGA
1576C> @param LL
1577C> @param KNR
1578C> @param MSTACK
1579C>
1580C> Error return:
1581C> IPTR(1):
1582C> - = 12 Data descriptor qualifier does not follow delayed replication
1583C> descriptor
1584C> - = 20 Exceeded count for delayed replication pass
1585C>
1586C> @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
1591C
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(*)
1604C
1605C PRINT *,' REPLICATION FI7805'
1606C DO 100 I = 1, IPTR(13)
1607C PRINT *,I,IWORK(I)
1608C 100 CONTINUE
1609C NUMBER OF DESCRIPTORS
1610 nrset = lx
1611C NUMBER OF REPLICATIONS
1612 nrreps = ly
1613 icurr = iptr(11) - 1
1614 ipick = iptr(11) - 1
1615C
1616 IF (nrreps.EQ.0) THEN
1617 iptr(39) = 1
1618C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
1619C IPTR(31) = IPTR(31) + 1
1620C KPRM = IPTR(31) + IPTR(24)
1621C MSTACK(1,KPRM) = JDESC
1622C MSTACK(2,KPRM) = 0
1623C KDATA(IPTR(17),KPRM) = 0
1624C PRINT *,'FI7805-1',KPRM,MSTACK(1,KPRM),
1625C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1626C DELAYED REPLICATION - MUST GET NUMBER OF
1627C REPLICATIONS FROM DATA.
1628C GET NEXT DESCRIPTOR
1629 CALL fi7808(iptr,iwork,lf,lx,ly,jdesc,maxd)
1630C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
1631C MUST BE DATA DESCRIPTION
1632C 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
1642C SET SINGLE VALUE FOR SEQUENTIAL,
1643C MULTIPLE VALUES FOR COMPRESSED
1644 IF (ident(16).EQ.0) THEN
1645C NON COMPRESSED
1646 CALL gbyte (msga,kvals,iptr(25),jwide)
1647C 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)
1655C PRINT *,'FI7805-2',KPRM,MSTACK(1,KPRM),
1656C * 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
1672C PRINT *,'NOT DELAYED REPLICATION'
1673 END IF
1674C RESTRUCTURE WORKING STACK W/REPLICATIONS
1675C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
1676C 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
1680C PRINT *,'REPLICATION ',I,ITEMP(I)
1681 1000 CONTINUE
1682C MOVE TRAILING DESCRIPTORS TO HOLD AREA
1683 lax = iptr(12) - iptr(11) + 1
1684C 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
1688C PRINT *,' ',I,KTEMP(I)
1689 2000 CONTINUE
1690C REPLICATIONS INTO ISTACK
1691C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
1692C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
1693 DO 4000 i = 1, nrreps
1694 DO 3000 j = 1, nrset
1695 iwork(icurr) = itemp(j)
1696C PRINT *,'FI7805 A',ICURR,IWORK(ICURR)
1697 icurr = icurr + 1
1698 3000 CONTINUE
1699 4000 CONTINUE
1700C PRINT *,' TO LOC',ICURR-1
1701C RESTORE TRAILING DESCRIPTORS
1702C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
1703 DO 5000 i = 1, lax
1704 iwork(icurr) = ktemp(i)
1705C 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
1712C> @brief Process operator descriptors
1713C> @author Bill Cavanaugh @date 1988-09-01
1714
1715C> Extract and save indicated change values for use
1716C> until changes are rescinded, or extract text strings indicated
1717C> through 2 05 yyy.
1718C>
1719C> Program history log:
1720C> - Bill Cavanaugh 1988-09-01
1721C> - Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
1722C> - Bill Cavanaugh 1991-05-10 Coding has been added to process proposed
1723C> table c descriptor 2 06 yyy.
1724C> - Bill Cavanaugh 1991-11-21 Coding has been added to properly process
1725C> table c descriptor 2 03 yyy, the change
1726C> to new reference value for selected
1727C> descriptors.
1728C>
1729C> @param[in] IPTR See w3fi78 routine docblock
1730C> @param[in] LX X portion of current descriptor
1731C> @param[in] LY Y portion of current descriptor
1732C> @param[in] MAXR Maximum number of reports/subsets that may be
1733C> contained in a bufr message
1734C> @param[in] MAXD Maximum number of descriptor combinations that
1735C> may be processed; upper air data and some satellite
1736C> data require a value for maxd of 1600, but for most
1737C> other data a value for maxd of 500 will suffice
1738C> @param[out] KDATA Array containing decoded reports from bufr message.
1739C> KDATA(Report number,parameter number)
1740C> (report number limited to value of input argument maxr and parameter number
1741C> limited to value of input argument maxd)
1742C> Arrays containing data from table b
1743C> @param[out] MSCALE Scale for value of descriptor
1744C> @param[out] MREF Reference value for descriptor
1745C> @param[out] MWIDTH Bit width for value of descriptor
1746C> @param IDENT
1747C> @param MSGA
1748C> @param IVALS
1749C> @param MSTACK
1750C> @param J
1751C> @param LL
1752C> @param KDESC
1753C> @param JDESC
1754C> @param IWORK
1755C>
1756C> Error return:
1757C> IPTR(1) = 5 - Erroneous X value in data descriptor operator
1758C>
1759C> @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
1773C
1774C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
1775 IF (lx.EQ.1) THEN
1776C CHANGE BIT WIDTH
1777 IF (ly.EQ.0) THEN
1778C PRINT *,' RETURN TO NORMAL WIDTH'
1779 iptr(26) = 0
1780 ELSE
1781C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
1782 iptr(26) = ly - 128
1783 END IF
1784 ELSE IF (lx.EQ.2) THEN
1785C CHANGE SCALE
1786 IF (ly.EQ.0) THEN
1787C RESET TO STANDARD SCALE
1788 iptr(27) = 0
1789 ELSE
1790C SET NEW SCALE
1791 iptr(27) = ly - 128
1792 END IF
1793 ELSE IF (lx.EQ.3) THEN
1794C CHANGE REFERENCE VALUE
1795C FOR EACH OF THOSE DESCRIPTORS BETWEEN
1796C 2 03 YYY WHERE Y LT 255 AND
1797C 2 03 255, EXTRACT THE NEW REFERENCE
1798C VALUE (BIT WIDTH YYY) AND PLACE
1799C IN TERTIARY TABLE B REF VAL POSITION,
1800C SET FLAG IN SECONDARY REFVAL POSITION
1801C THOSE DESCRIPTORS DO NOT HAVE DATA
1802C ASSOCIATED WITH THEM, BUT ONLY
1803C IDENTIFY THE TABLE B ENTRIES THAT
1804C ARE GETTING NEW REFERENCE VALUES.
1805 kyyy = ly
1806 IF (kyyy.GT.0.AND.kyyy.LT.255) THEN
1807C START CYCLING THRU DESCRIPTORS UNTIL
1808C 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
1812C IF 2 03 255 THEN RETURN
1813 RETURN
1814 ELSE
1815C FIND MATCHING TABLE B ENTRY
1816 DO 500 lj = 1, iptr(14)
1817 IF (jdesc.EQ.kdesc(lj)) THEN
1818C TURN ON NEW REF VAL FLAG
1819 mref(lj,2) = 1
1820C INSERT NEW REF VAL
1821 CALL gbyte (msga,mref(lj,3),iptr(25),kyyy)
1822C GO GET NEXT DESCRIPTOR
1823 GO TO 300
1824 END IF
1825 500 CONTINUE
1826C 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
1831C MUST TURN OFF ALL NEW
1832C REFERENCE VALUES
1833 DO 400 i = 1, iptr(14)
1834 mref(i,2) = 0
1835 400 CONTINUE
1836 END IF
1837C LX = 3
1838C MUST BE CONCLUDED WITH Y=255
1839 ELSE IF (lx.EQ.4) THEN
1840C ASSOCIATED VALUES
1841 IF (ly.EQ.0) THEN
1842 iptr(29) = 0
1843C 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
1850C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
1851 END IF
1852 ELSE IF (lx.EQ.5) THEN
1853C PROCESS TEXT DATA
1854 iptr(40) = ly
1855 iptr(18) = 1
1856 IF (ident(16).EQ.0) THEN
1857C 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
1861C 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
1870C SKIP NEXT DESCRIPTOR
1871C SET TO PASS OVER DESCRIPTOR AND DATA
1872C IF DESCRIPTOR NOT IN TABLE B
1873 iptr(36) = ly
1874C 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
1884C> @brief Process queue descriptor.
1885C> @author Bill Cavanaugh @date 1988-09-01
1886
1887C> Substitute descriptor queue for queue descriptor.
1888C>
1889C> Program history log:
1890C> - Bill Cavanaugh 1988-09-01
1891C> - Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors.
1892C> - Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors.
1893C> based on tests with live data.
1894C>
1895C> @param[in] IWORK Working descriptor list
1896C> @param[in] IPTR See w3fi78 routine docblock
1897C> @param MAXD
1898C> @param[in] ITBLD Array containing descriptor queues
1899C> @param[in] JDESC Queue descriptor to be expanded
1900C>
1901C$$$
1902 SUBROUTINE fi7807(IPTR,IWORK,ITBLD,JDESC,MAXD)
1903
1904 SAVE
1905C
1906 INTEGER IPTR(*),JDESC
1907 INTEGER IWORK(*),IHOLD(2000)
1908 INTEGER ITBLD(500,11)
1909C
1910C PRINT *,' FI7807 F3 ENTRY',IPTR(11),IPTR(12)
1911C SET FOR BINARY SEARCH IN TABLE D
1912C DO 2020 I = 1, IPTR(12)
1913C PRINT *,'ENTRY IWORK',I,IWORK(I)
1914C2020 CONTINUE
1915 jlo = 1
1916 jhi = iptr(20)
1917C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC
1918 10 CONTINUE
1919 jmid = (jlo + jhi) / 2
1920C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1)
1921C
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
1950C HAVE TABLE D MATCH
1951C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11)
1952C 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)
1959C 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
1967C NOTHING MORE TO APPEND
1968C PRINT *,'NOTHING MORE TO APPEND'
1969 ELSE
1970C APPEND TRAILING IWORK TO IHOLD
1971C 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
1977C RESET IHOLD TO IWORK
1978C 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
1985C PRINT *,' FI7807 F3 EXIT ',IPTR(11),IPTR(12)
1986C DO 2000 I = 1, IPTR(12)
1987C PRINT *,'EXIT IWORK',I,IWORK(I)
1988C2000 CONTINUE
1989C RESET POINTERS
1990 iptr(11) = iptr(11) - 1
1991 RETURN
1992 END
1993C> @brief
1994C> @author Bill Cavanaugh @date 1988-09-01
1995
1996C> Program history log:
1997C> - Bill Cavanaugh 1988-09-01
1998C>
1999C> @param[inout] IPTR See w3fi78() routine docblock
2000C> @param[in] IWORK Working descriptor list
2001C> @param LF
2002C> @param LX
2003C> @param LY
2004C> @param JDESC
2005C> @param MAXD
2006C>
2007C> @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
2012C
2013C 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
2021C PRINT *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY
2022 iptr(11) = iptr(11) + 1
2023 RETURN
2024 END
2025C> @brief Reformat profiler w hgt increments.
2026C> @author Bill Cavanaugh @date 1990-02-14
2027
2028C> Reformat decoded profiler data to show heights instead of
2029C> height increments.
2030C>
2031C> Program history log:
2032C> - Bill Cavanaugh 1990-02-14
2033C>
2034C> @param[in] IDENT Array contains message information extracted from BUFR
2035C> message:
2036C> - IDENT(1)- Edition number (byte 4, section 1)
2037C> - IDENT(2)- Originating center (bytes 5-6, section 1)
2038C> - IDENT(3)- Update sequence (byte 7, section 1)
2039C> - IDENT(4)- (byte 8, section 1)
2040C> - IDENT(5)- Bufr message type (byte 9, section 1)
2041C> - IDENT(6)- Bufr msg sub-type (byte 10, section 1)
2042C> - IDENT(7)- (bytes 11-12, section 1)
2043C> - IDENT(8)- Year of century (byte 13, section 1)
2044C> - IDENT(9)- Month of year (byte 14, section 1)
2045C> - IDENT(10)- Day of month (byte 15, section 1)
2046C> - IDENT(11)- Hour of day (byte 16, section 1)
2047C> - IDENT(12)- Minute of hour (byte 17, section 1)
2048C> - IDENT(13)- Rsvd by adp centers(byte 18, section 1)
2049C> - IDENT(14)- Nr of data subsets (byte 5-6, section 3)
2050C> - IDENT(15)- Observed flag (byte 7, bit 1, section 3)
2051C> - IDENT(16)- Compression flag (byte 7, bit 2, section 3)
2052C> @param[in] MSTACK Working descriptor list and scaling factor
2053C> @param[in] KDATA Array containing decoded reports from bufr message.
2054C> KDATA(Report number,parameter number)
2055C> (report number limited to value of input argument maxr and parameter number
2056C> limited to value of input argument maxd)
2057C> @param[in] IPTR See w3fi78
2058C> @param[in] MAXR Maximum number of reports/subsets that may be
2059C> contained in a bufr message
2060C> @param[in] MAXD Maximum number of descriptor combinations that
2061C> may be processed; upper air data and some satellite
2062C> data require a value for maxd of 1600, but for most
2063C> other data a value for maxd of 500 will suffice.
2064C>
2065C> @author Bill Cavanaugh @date 1990-02-14
2066 SUBROUTINE fi7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
2067
2068 SAVE
2069C ----------------------------------------------------------------
2070C
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)
2077C
2078C ----------------------------------------------------------
2079C PRINT *,'FI7809'
2080C LOOP FOR NUMBER OF SUBSETS/REPORTS
2081 DO 3000 i = 1, ident(14)
2082C INIT FOR DATA INPUT ARRAY
2083 mk = 1
2084C INIT FOR DESC OUTPUT ARRAY
2085 jk = 0
2086C LOCATION
2087 isw = 0
2088 DO 200 j = 1, 3
2089C LATITUDE
2090 IF (mstack(1,mk).EQ.1282) THEN
2091 isw = isw + 1
2092 GO TO 100
2093C LONGITUDE
2094 ELSE IF (mstack(1,mk).EQ.1538) THEN
2095 isw = isw + 2
2096 GO TO 100
2097C 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
2106C SAVE DESCRIPTOR
2107 kprofl(jk) = mstack(1,mk)
2108C SAVE SCALE
2109 kprof2(jk) = mstack(2,mk)
2110C 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
2119C TIME
2120 isw = 0
2121 DO 400 j = 1, 7
2122C YEAR
2123 IF (mstack(1,mk).EQ.1025) THEN
2124 isw = isw + 1
2125 GO TO 300
2126C MONTH
2127 ELSE IF (mstack(1,mk).EQ.1026) THEN
2128 isw = isw + 2
2129 GO TO 300
2130C DAY
2131 ELSE IF (mstack(1,mk).EQ.1027) THEN
2132 isw = isw + 4
2133 GO TO 300
2134C HOUR
2135 ELSE IF (mstack(1,mk).EQ.1028) THEN
2136 isw = isw + 8
2137 GO TO 300
2138C MINUTE
2139 ELSE IF (mstack(1,mk).EQ.1029) THEN
2140 isw = isw + 16
2141 GO TO 300
2142C 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
2153C SAVE DESCRIPTOR
2154 kprofl(jk) = mstack(1,mk)
2155C SAVE SCALE
2156 kprof2(jk) = mstack(2,mk)
2157C 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
2166C SURFACE DATA
2167 krg = 0
2168 isw = 0
2169 DO 600 j = 1, 10
2170C WIND SPEED
2171 IF (mstack(1,mk).EQ.2818) THEN
2172 isw = isw + 1
2173 GO TO 500
2174C WIND DIRECTION
2175 ELSE IF (mstack(1,mk).EQ.2817) THEN
2176 isw = isw + 2
2177 GO TO 500
2178C PRESS REDUCED TO MSL
2179 ELSE IF (mstack(1,mk).EQ.2611) THEN
2180 isw = isw + 4
2181 GO TO 500
2182C TEMPERATURE
2183 ELSE IF (mstack(1,mk).EQ.3073) THEN
2184 isw = isw + 8
2185 GO TO 500
2186C RAINFALL RATE
2187 ELSE IF (mstack(1,mk).EQ.3342) THEN
2188 isw = isw + 16
2189 GO TO 500
2190C RELATIVE HUMIDITY
2191 ELSE IF (mstack(1,mk).EQ.3331) THEN
2192 isw = isw + 32
2193 GO TO 500
2194C 1ST RANGE GATE OFFSET
2195 ELSE IF (mstack(1,mk).EQ.1982.OR.
2196 * mstack(1,mk).EQ.1983) THEN
2197C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
2198C 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
2208C PRINT *,'INITIAL INCR =',INCRHT
2209 ELSE
2210 lhgt = 500 + ihgt - kdata(i,mk)
2211 isw = isw + 64
2212C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
2213 END IF
2214 END IF
2215C MODE #1
2216 ELSE IF (mstack(1,mk).EQ.8128) THEN
2217 isw = isw + 128
2218 GO TO 500
2219C 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
2226C SAVE DESCRIPTOR
2227 jk = jk + 1
2228 kprofl(jk) = mstack(1,mk)
2229C SAVE SCALE
2230 kprof2(jk) = mstack(2,mk)
2231C SAVE DATA
2232 kset2(jk) = kdata(i,mk)
2233C IF (I.EQ.1) THEN
2234C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
2235C 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
2244C 43 LEVELS
2245 DO 2000 l = 1, 43
2246 2020 CONTINUE
2247 isw = 0
2248C HEIGHT INCREMENT
2249 IF (mstack(1,mk).EQ.1982) THEN
2250C 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
2259C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
2260C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
2261 lhgt = lhgt + incrht
2262C PRINT *,'LEVEL ',L,LHGT
2263 IF (l.EQ.37) THEN
2264 lhgt = lhgt + incrht
2265 END IF
2266 jk = jk + 1
2267C SAVE DESCRIPTOR
2268 kprofl(jk) = 1798
2269C SAVE SCALE
2270 kprof2(jk) = 0
2271C SAVE DATA
2272 kset2(jk) = lhgt
2273C IF (I.EQ.10) THEN
2274C PRINT *,' '
2275C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
2276C 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
2282C 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
2292C 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
2301C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
2302C DESCRIPTORS AND DATA
2303 IF (iand(isw,1).NE.0) THEN
2304 IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
2305C SAVE DD DESCRIPTOR
2306 jk = jk + 1
2307 kprofl(jk) = 2817
2308C SAVE SCALE
2309 kprof2(jk) = 0
2310C SAVE DD DATA
2311 kset2(jk) = 32767
2312C SAVE FFF DESCRIPTOR
2313 jk = jk + 1
2314 kprofl(jk) = 2818
2315C SAVE SCALE
2316 kprof2(jk) = 1
2317C SAVE FFF DATA
2318 kset2(jk) = 32767
2319 ELSE
2320C GENERATE DDFFF
2321 CALL w3fc05 (vectu,vectv,dir,spd)
2322 ndir = dir
2323 spd = spd
2324 nspd = spd
2325C PRINT *,' ',NDIR,NSPD
2326C SAVE DD DESCRIPTOR
2327 jk = jk + 1
2328 kprofl(jk) = 2817
2329C SAVE SCALE
2330 kprof2(jk) = 0
2331C SAVE DD DATA
2332 kset2(jk) = dir
2333C IF (I.EQ.1) THEN
2334C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
2335C END IF
2336C SAVE FFF DESCRIPTOR
2337 jk = jk + 1
2338 kprofl(jk) = 2818
2339C SAVE SCALE
2340 kprof2(jk) = 1
2341C SAVE FFF DATA
2342 kset2(jk) = spd
2343C IF (I.EQ.1) THEN
2344C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
2345C END IF
2346 END IF
2347 END IF
2348 GO TO 800
2349C W VECTOR VALUE
2350 ELSE IF (mstack(1,mk).EQ.3010) THEN
2351 isw = isw + 4
2352 GO TO 700
2353C Q/C TEST RESULTS
2354 ELSE IF (mstack(1,mk).EQ.8130) THEN
2355 isw = isw + 8
2356 GO TO 700
2357C 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
2361C 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
2365C SPECTRAL PEAK POWER
2366 ELSE IF (mstack(1,mk).EQ.5568) THEN
2367 isw = isw + 64
2368 GO TO 700
2369C U,V VARIABILITY
2370 ELSE IF (mstack(1,mk).EQ.3011) THEN
2371 isw = isw + 128
2372 GO TO 700
2373C 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
2384C SAVE DESCRIPTOR
2385 kprofl(jk) = mstack(1,mk)
2386C SAVE SCALE
2387 kprof2(jk) = mstack(2,mk)
2388C SAVE DATA
2389 kset2(jk) = kdata(i,mk)
2390 mk = mk + 1
2391C IF (I.EQ.1) THEN
2392C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
2393C 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
2402C MOVE DATA BACK INTO KDATA ARRAY
2403 DO 4000 ll = 1, jk
2404 kdata(i,ll) = kset2(ll)
2405 4000 CONTINUE
2406 3000 CONTINUE
2407C PRINT *,'REBUILT ARRAY'
2408 DO 5000 ll = 1, jk
2409C DESCRIPTOR
2410 mstack(1,ll) = kprofl(ll)
2411C SCALE
2412 mstack(2,ll) = kprof2(ll)
2413C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
2414 5000 CONTINUE
2415C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
2416 iptr(31) = jk
2417 RETURN
2418 END
2419C> @brief Reformat profiler edition 2 data.
2420C> @author Bill Cavanaugh @date 1993-01-21
2421
2422C> Reformat profiler data in edition 2.
2423C>
2424C> Program history log:
2425C> - Bill Cavanaugh 1993-01-27
2426C>
2427C> @param[in] IDENT Array contains message information extracted from
2428C> bufr message:
2429C> - IDENT(1) - Edition number (byte 4, section 1)
2430C> - IDENT(2) - Originating center (bytes 5-6, section 1)
2431C> - IDENT(3) - Update sequence (byte 7, section 1)
2432C> - IDENT(4) - (byte 8, section 1)
2433C> - IDENT(5) - Bufr message type (byte 9, section 1)
2434C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
2435C> - IDENT(7) - (bytes 11-12, section 1)
2436C> - IDENT(8) - Year of century (byte 13, section 1)
2437C> - IDENT(9) - Month of year (byte 14, section 1)
2438C> - IDENT(10) - Day of month (byte 15, section 1)
2439C> - IDENT(11) - Hour of day (byte 16, section 1)
2440C> - IDENT(12) - Minute of hour (byte 17, section 1)
2441C> - IDENT(13) - Rsvd by adp centers (byte 18, section 1)
2442C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
2443C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
2444C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
2445C> @param[in] MSTACK Working descriptor list and scaling factor
2446C> @param[in] KDATA Array containing decoded reports from bufr message.
2447c> kdata(report number,parameter number)
2448c> (report number limited to value of input argument maxr and parameter number
2449C> limited to value of input argument maxd)
2450C> @param[in] IPTR See w3fi78
2451C> @param[in] MAXR Maximum number of reports/subsets that may be
2452C> contained in a bufr message
2453C> @param[in] MAXD Maximum number of descriptor combinations that
2454C> may be processed; upper air data and some satellite
2455C> data require a value for maxd of 1600, but for most
2456C> other data a value for maxd of 500 will suffice
2457C>
2458C> @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)
2467C LOOP FOR NUMBER OF SUBSETS
2468 DO 3000 i = 1, ident(14)
2469 mk = 1
2470 jk = 0
2471 isw = 0
2472C PRINT *,'IDENTIFICATION'
2473 DO 200 j = 1, 5
2474 IF (mstack(1,mk).EQ.257) THEN
2475C BLOCK NUMBER
2476 isw = isw + 1
2477 ELSE IF (mstack(1,mk).EQ.258) THEN
2478C STATION NUMBER
2479 isw = isw + 2
2480 ELSE IF (mstack(1,mk).EQ.1282) THEN
2481C LATITUDE
2482 isw = isw + 4
2483 ELSE IF (mstack(1,mk).EQ.1538) THEN
2484C LONGITUDE
2485 isw = isw + 8
2486 ELSE IF (mstack(1,mk).EQ.1793) THEN
2487C 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)
2498C PRINT *,JK,KPROFL(JK),KSET2(JK)
2499 mk = mk + 1
2500 200 CONTINUE
2501C PRINT *,'LOCATION ',ISW
2502 IF (isw.NE.31) THEN
2503 print *,'LOCATION ERROR PROCESSING PROFILER'
2504 iptr(10) = 200
2505 RETURN
2506 END IF
2507C PROCESS TIME ELEMENTS
2508 isw = 0
2509 DO 400 j = 1, 7
2510 IF (mstack(1,mk).EQ.1025) THEN
2511C YEAR
2512 isw = isw + 1
2513 ELSE IF (mstack(1,mk).EQ.1026) THEN
2514C MONTH
2515 isw = isw + 2
2516 ELSE IF (mstack(1,mk).EQ.1027) THEN
2517C DAY
2518 isw = isw + 4
2519 ELSE IF (mstack(1,mk).EQ.1028) THEN
2520C HOUR
2521 isw = isw + 8
2522 ELSE IF (mstack(1,mk).EQ.1029) THEN
2523C MINUTE
2524 isw = isw + 16
2525 ELSE IF (mstack(1,mk).EQ.2069) THEN
2526C TIME SIGNIFICANCE
2527 isw = isw + 32
2528 ELSE IF (mstack(1,mk).EQ.1049) THEN
2529C 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)
2539C PRINT *,JK,KPROFL(JK),KSET2(JK)
2540 mk = mk + 1
2541 400 CONTINUE
2542C PRINT *,'TIME ',ISW
2543 IF (isw.NE.127) THEN
2544 print *,'TIME ERROR PROCESSING PROFILER'
2545 iptr(1) = 201
2546 RETURN
2547 END IF
2548C SURFACE DATA
2549 isw = 0
2550C PRINT *,'SURFACE'
2551 DO 600 k = 1, 8
2552C 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
2568C PRINT *,'INITIAL INCREMENT = ',INCRHT
2569 mk = mk + 1
2570C 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)
2579C 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
2592C MUST SAVE THIS HEIGHT VALUE
2593 lhgt = 500 + ihgt - kdata(i,mk)
2594C 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
2599C PROCESS LEVEL DATA
2600C PRINT *,'LEVEL DATA'
2601 DO 2000 l = 1, 43
2602 2020 CONTINUE
2603C PRINT *,'DESC',MK,MSTACK(1,MK),JK
2604 isw = 0
2605C HEIGHT INCREMENT
2606 IF (mstack(1,mk).EQ.1797) THEN
2607 incrht = kdata(i,mk)
2608C 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
2616C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
2617C AT THIS POINT
2618 lhgt = lhgt + incrht
2619C PRINT *,'LEVEL ',L,LHGT
2620 IF (l.EQ.37) THEN
2621 lhgt = lhgt + incrht
2622 END IF
2623 jk = jk + 1
2624C SAVE DESCRIPTOR
2625 kprofl(jk) = 1798
2626C SAVE SCALE
2627 kprof2(jk) = 0
2628C SAVE DATA
2629 kset2(jk) = lhgt
2630C PRINT *,KPROFL(JK),KSET2(JK),JK
2631 isw = 0
2632 icon = 1
2633 DO 800 j = 1, 10
2634750 CONTINUE
2635 IF (mstack(1,mk).EQ.1797) THEN
2636 GO TO 2020
2637 ELSE IF (mstack(1,mk).EQ.6432) THEN
2638C HI/LO MODE
2639 isw = isw + 1
2640 ELSE IF (mstack(1,mk).EQ.6434) THEN
2641C Q/C TEST
2642 isw = isw + 2
2643 ELSE IF (mstack(1,mk).EQ.2070) THEN
2644 IF (icon.EQ.1) THEN
2645C FIRST PASS - U,V CONSENSUS
2646 isw = isw + 4
2647 icon = icon + 1
2648 ELSE
2649C SECOND PASS - W CONSENSUS
2650 isw = isw + 64
2651 END IF
2652 ELSE IF (mstack(1,mk).EQ.2819) THEN
2653C 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
2663C 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
2672C SAVE DD DESCRIPTOR
2673 jk = jk + 1
2674 kprofl(jk) = 2817
2675 kprof2(jk) = 0
2676 kset2(jk) = 32767
2677C 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
2687C PRINT *,' ',NDIR,NSPD
2688C SAVE DD DESCRIPTOR
2689 jk = jk + 1
2690 kprofl(jk) = 2817
2691 kprof2(jk) = 0
2692 kset2(jk) = ndir
2693C IF (I.EQ.1) THEN
2694C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
2695C ENDIF
2696C SAVE FFF DESCRIPTOR
2697 jk = jk + 1
2698 kprofl(jk) = 2818
2699 kprof2(jk) = 1
2700 kset2(jk) = nspd
2701C IF (I.EQ.1) THEN
2702C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
2703C ENDIF
2704 END IF
2705 mk = mk + 1
2706 GO TO 800
2707 END IF
2708 ELSE IF (mstack(1,mk).EQ.2866) THEN
2709C SPEED STD DEVIATION
2710 isw = isw + 32
2711C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568
2712 ELSE IF (mstack(1,mk).EQ.5568) THEN
2713C SIGNAL POWER
2714 isw = isw + 128
2715 ELSE IF (mstack(1,mk).EQ.2822) THEN
2716C W COMPONENT
2717 isw = isw + 256
2718 ELSE IF (mstack(1,mk).EQ.2867) THEN
2719C VERT STD DEVIATION
2720 isw = isw + 512
2721 ELSE
2722 mk = mk + 1
2723 GO TO 750
2724 END IF
2725 jk = jk + 1
2726C SAVE DESCRIPTOR
2727 kprofl(jk) = mstack(1,mk)
2728C SAVE SCALE
2729 kprof2(jk) = mstack(2,mk)
2730C SAVE DATA
2731 kset2(jk) = kdata(i,mk)
2732 mk = mk + 1
2733C 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
2742C MOVE DATA BACK INTO KDATA ARRAY
2743 DO 5000 ll = 1, jk
2744C DATA
2745 kdata(i,ll) = kset2(ll)
2746 5000 CONTINUE
2747 3000 CONTINUE
2748 DO 5005 ll = 1, jk
2749C DESCRIPTOR
2750 mstack(1,ll) = kprofl(ll)
2751C SCALE
2752 mstack(2,ll) = kprof2(ll)
2753C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP
2754C 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
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
fi7809
subroutine fi7809(ident, mstack, kdata, iptr, maxr, maxd)
Reformat profiler w hgt increments.
Definition w3fi78.f:2067
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
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
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
fi7803
subroutine fi7803(iptr, ident, msga, kdata, ivals, mstack, mwidth, mref, mscale, j, jdesc, maxr, maxd)
Process compressed data.
Definition w3fi78.f:1151
fi7810
subroutine fi7810(ident, mstack, kdata, iptr, maxr, maxd)
Reformat profiler edition 2 data.
Definition w3fi78.f:2460
fi7808
subroutine fi7808(iptr, iwork, lf, lx, ly, jdesc, maxd)
Program history log:
Definition w3fi78.f:2009
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