NCEPLIBS-w3emc 2.12.0
Loading...
Searching...
No Matches
w3fi67.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. Those arrays are described in the output
8C> argument list. This routine does not include ifod processing.
9C>
10C> Program history log:
11C> - Bill Cavanaugh 1988-08-31
12C> - Bill Cavanaugh 1990-12-07 Now utilizing gbyte routines to gather
13C> and separate bit fields. This should improve
14C> (decrease) the time it takes to decode any
15C> BUFR message. Have entered coding that will
16C> permit processing BUFR editions 1 and 2.
17C> Improved and corrected the conversion into
18C> ifod format of decoded BUFR messages.
19C> - Bill Cavanaugh 1991-01-18 Program/routines modified to properly handle
20C> serial profiler data.
21C> - Bill Cavanaugh 1991-04-04 Modified to handle text supplied thru
22C> descriptor 2 05 yyy.
23C> - Bill Cavanaugh 1991-04-17 Errors in extracting and scaling data
24C> corrected. Improved handling of nested queue descriptors is added.
25C> - Bill Cavanaugh 1991-05-10 Array 'data' has been enlarged to real*8
26C> to better contain very large numbers more accurately. The preious size
27C> real*4 could not contain sufficient significant digits. Coding has been
28C> introduced to process new table c descriptor 2 06 yyy which permits in
29C> line processing of a local descriptor even if the descriptor is not
30C> contained in the users table b. A second routine to process ifod messages
31C> (ifod0) has been removed in favor of the improved processing of the one
32C> remaining (ifod1). New coding has been introduced to permit processing of
33C> BUFR messages based on BUFR edition up to and including edition 2. Please
34C> note increased size requirements for arrays ident(20) and iptr(40).
35C> - Bill Cavanaugh 1991-07-26 Add array mtime to calling sequence to
36C> permit inclusion of receipt/transfer times to ifod messages.
37C> - Bill Cavanaugh 1991-09-25 All processing of decoded BUFR data into
38C> ifod (a local use reformat of BUFR data) has been isolated from this set of
39C> routines. For those interested in the ifod form, see w3fl05 in the w3lib
40C> routines.
41C> - Processing of BUFR messages containing delayed replication has been
42C> altered so that single subsets (reports) and and a matching descriptor list
43C> for that particular subset will be passed to the user will be passed to the
44C> user one at a time to assure that each subset can be fully defined with a
45C> minimum of reprocessing.
46C> - Processing of associated fields has been tested with messages containing
47C> non-compressed data.
48C> - In order to facilitate user processing a matching list of scale factors
49C> are included with the expanded descriptor list (mstack).
50C> - Bill Cavanaugh 1991-11-21 Processing of descriptor 2 03 yyy
51C> has corrected to agree with fm94 standards.
52C> - Bill Cavanaugh 1991-12-19 Calls to fi6703() and fi6704() have been
53C> corrected to agree called program argument list. Some additional entries
54C> have been included for communicating with data access routines. Additional
55C> error exit provided for the case where table b is damaged.
56C> - Bill Cavanaugh 1992-01-24 Routines fi6701(), fi6703() and fi6704()
57C> have been modified to handle associated fields all descriptors are set to
58C> echo to mstack(1,n)
59C> - Bill Cavanaugh 1992-05-21 Further expansion of information collected from
60C> within upper air soundings has produced the necessity to expand some of the
61C> processing and output arrays. (see remarks below)
62C> - Bill Cavanaugh 1992-06-29 Corrected descriptor denoting height of
63C> each wind level for profiler conversions.
64C> - Bill Cavanaugh 1992-07-23 Expansion of table b requires adjustment
65C> of arrays to contain table b values needed to assist in the decoding process.
66C> - Arrays containing data from table b:
67C> - kdesc descriptor
68C> - aname descriptor name
69C> - aunits units for descriptor
70C> - mscale scale for value of descriptor
71C> - mref reference value for descriptor
72C> - mwidth bit width for value of descriptor
73C> - Bill Cavanaugh 1992-09-09 First encounter with operator descriptor
74C> 2 05 yyy showed error in decoding. That error is corrected with this
75C> implementation. Further testing of upper air data has encountered the
76C> condition of large (many level) soundings arrays in the decoder have been
77C> expanded (again) to allow for this condition.
78C> - Bill Cavanaugh 1992-10-02 Modified routine to reformat profiler data
79C> (fi6709) to show descriptors, scale value and data in proper order.
80C> Corrected an error that prevented user from assigning the second dimension
81C> of kdata(500,*).
82C> - Bill Cavanaugh 1992-10-20 Removed error that prevented full implementation
83C> of previous corrections and made corrections to table b to bring it up to
84C> date. Changes include proper reformat of profiler data and user capability
85C> for assigning second dimension of kdata array.
86C> - Bill Cavanaugh 1993-01-26 Added routine fi6710() to permit reformatting
87C> profiler data in BUFR edition 2.
88C>
89C> @param[in] MSGA Array containing supposed bufr message.
90C> @param[out] ISTACK Original array of descriptors extracted from
91C> source bufr message.
92C> @param[out] MSTACK (A,B)
93C> - LEVEL B - Descriptor number
94C> - LEVEL A = 1 Descriptor
95C> - = 2 10**N Scaling to return to original value
96C> @param[out] IPTR Utility array.
97C> - IPTR( 1)- Error return.
98C> - IPTR( 2)- Byte count section 1.
99C> - IPTR( 3)- Pointer to start of section 1.
100C> - IPTR( 4)- Byte count section 2.
101C> - IPTR( 5)- Pointer to start of section 2.
102C> - IPTR( 6)- Byte count section 3.
103C> - IPTR( 7)- Pointer to start of section 3.
104C> - IPTR( 8)- Byte count section 4.
105C> - IPTR( 9)- Pointer to start of section 4.
106C> - IPTR(10)- Start of requested subset, reserved for dar.
107C> - IPTR(11)- Current descriptor ptr in iwork.
108C> - IPTR(12)- Last descriptor pos in iwork.
109C> - IPTR(13)- Last descriptor pos in istack.
110C> - IPTR(14)- Number of table b entries.
111C> - IPTR(15)- Requested subset pointer, reserved for dar.
112C> - IPTR(16)- Indicator for existance of section 2.
113C> - IPTR(17)- Number of reports processed.
114C> - IPTR(18)- Ascii/text event.
115C> - IPTR(19)- Pointer to start of bufr message.
116C> - IPTR(20)- Number of lines from table d.
117C> - IPTR(21)- Table b switch.
118C> - IPTR(22)- Table d switch.
119C> - IPTR(23)- Code/flag table switch.
120C> - IPTR(24)- Aditional words added by text info.
121C> - IPTR(25)- Current bit number.
122C> - IPTR(26)- Data width change.
123C> - IPTR(27)- Data scale change.
124C> - IPTR(28)- Data reference value change.
125C> - IPTR(29)- Add data associated field.
126C> - IPTR(30)- Signify characters.
127C> - IPTR(31)- Number of expanded descriptors in mstack.
128C> - IPTR(32)- Current descriptor segment f.
129C> - IPTR(33)- Current descriptor segment x.
130C> - IPTR(34)- Current descriptor segment y.
131C> - IPTR(35)- Unused.
132C> - IPTR(36)- Next descriptor may be undecipherable.
133C> - IPTR(37)- Unused.
134C> - IPTR(38)- Unused.
135C> - IPTR(39)- Delayed replication flag.
136C> - 0 - No delayed replication.
137C> - 1 - Message contains delayed replication.
138C> - IPTR(40)- Number of characters in text for curr descriptor.
139C> @param[out] IDENT Array contains message information extracted from bufr message
140C> - IDENT( 1)-Edition number (byte 4, section 1).
141C> - IDENT( 2)-Originating center (bytes 5-6, section 1).
142C> - IDENT( 3)-Update sequence (byte 7, section 1).
143C> - IDENT( 4)-Optional section (byte 8, section 1).
144C> - IDENT( 5)-Bufr message type (byte 9, section 1).
145C> - 0 = Surface (land)
146C> - 1 = Surface (ship)
147C> - 2 = Vertical soundings other than satellite
148C> - 3 = Vertical soundings (satellite)
149C> - 4 = Sngl lvl upper-air other than satellite
150C> - 5 = Sngl lvl upper-air (satellite)
151C> - 6 = Radar
152C> - IDENT( 6)-Bufr msg sub-type (byte 10, section 1)
153C> | type | sbtyp |
154C> | :--- | :---- |
155C> | 2 | 7 = profiler |
156C> - IDENT(7) - bytes 11-12, section 1).
157C> - IDENT(8) - Year of century (byte 13, section 1).
158C> - IDENT(9) - Month of year (byte 14, section 1).
159C> - IDENT(10) - Day of month (byte 15, section 1).
160C> - IDENT(11) - Hour of day (byte 16, section 1).
161C> - IDENT(12) - Minute of hour (byte 17, section 1).
162C> - IDENT(13) - Rsvd by adp centers (byte 18, section 1).
163C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3).
164C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3).
165C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3).
166C> - IDENT(17) - Master table number (byte 4, section 1, ed 2 or gtr).
167C> @param[out] KDATA Array containing decoded reports from bufr message.
168C> @param[in] KNR
169C> kdata(report number,parameter number) arrays containing data from table b
170C> - ANAME Descriptor name.
171C> - AUNITS Units for descriptor.
172C> - MSCALE Scale for value of descriptor.
173C> - MREF Reference value for descriptor.
174C> - MWIDTH Bit width for value of descriptor.
175C> @param[out] INDEX Pointer to available subset.
176C>
177C> @note Error returns:
178C> - IPTR(1):
179C> - = 1 'BUFR' Not found in first 125 characters.
180C> - = 2 '7777' Not found in location determined by
181C> by using counts found in each section. one or
182C> more sections have an erroneous byte count or
183C> characters '7777' are not in test message.
184C> - = 3 Message contains a descriptor with f=0 that does
185C> not exist in table b.
186C> - = 4 Message contains a descriptor with f=3 that does
187C> not exist in table d.
188C> - = 5 Message contains a descriptor with f=2 with the
189C> value of x outside the range 1-5.
190C> - = 6 Descriptor element indicated to have a flag value
191C> does not have an entry in the flag table
192C> (to be activated).
193C> - = 7 Descriptor indicated to have a code value does
194C> not have an entry in the code table
195C> (to be activated).
196C> - = 8 Error reading table d.
197C> - = 9 Error reading table b.
198C> - = 10 Error reading code/flag table.
199C> - = 11 Descriptor 2 04 004 not followed by 0 31 021.
200C> - = 12 Data descriptor operator qualifier does not follow
201C> delayed replication descriptor.
202C> - = 13 Bit width on ascii characters not a multiple of 8.
203C> - = 14 Subsets = 0, no content bulletin.
204C> - = 20 Exceeded count for delayed replication pass.
205C> - = 21 Exceeded count for non-delayed replication pass.
206C> - = 22 Section 1 count exceeds 10000.
207C> - = 23 Section 2 count exceeds 10000.
208C> - = 24 Section 3 count exceeds 10000.
209C> - = 25 Section 4 count exceeds 10000.
210C> - = 27 Non zero lowest on text data.
211C> - = 28 Nbinc not nr of characters.
212C> - = 29 Table b appears to be damaged.
213C> - = 99 No more subsets (reports) available in current
214C> bufr mesage.
215C> - = 400 Number of subsets exceeds capability of routine.
216C> - = 401 Number of parameters (and associated fields)
217C> exceeds limits of this program.
218C> - = 500 Value for nbinc has been found that exceeds
219C> standard width plus any bit width change
220C> check all bit widths up to point of error.
221C> - = 501 Corrected width for descriptor is 0 or less.
222C>
223C> On the initial call to w3fi67() with a bufr message the argument
224C> index must be set to zero (index = 0). on the return from w3fi67()
225C> 'index' will be set to the next available subset/report. when
226C> there are no more subsets available a 99 err return will occur.
227C>
228C> If the original bufr message does not contain delayed replication
229C> the bufr message will be completely decoded and 'index' will point
230C> to the first decoded subset. The users will then have the option
231C> of indexing through the subsets on their own or by recalling this
232C> routine (without resetting 'index') to have the routine do the
233C> indexing.
234C>
235C> If the original bufr message does contain delayed replication
236C> one subset/report will be decoded at a time and passed back to
237C> the user. this is not an option.
238C>
239C> =============================================
240C> TO USE THIS ROUTINE
241C> --------------------------------
242C> 1. READ IN BUFR MESSAGE
243C> 2. SET INDEX = 0
244C> 3. CALL W3FI67( )
245C> 4. IF (IPTR(1).EQ.99) THEN
246C> NO MORE SUBSETS
247C> EITHER GO TO 1
248C> OR TERMINATE IN NO MORE BUFR MESSAGES
249C> END IF
250C> 5. IF (IPTR(1).NE.0) THEN
251C> ERROR CONDITION
252C> EITHER GO TO 1
253C> OR TERMINATE IN NO MORE BUFR MESSAGES
254C> END IF
255C> 6. THE VALUE OF INDEX INDICATES THE ACTIVE SUBSET SO
256C> IF INTERESTED IN GENERATING AN IFOD MESSAGE
257C> CALL W3FL05 ( )
258C> ELSE
259C> PROCESS DECODED INFORMATION AS REQUIRED
260C> END IF
261C> 7. GO TO 3
262C>
263C> =============================================
264C> THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED
265C> AS FOLLOWS:
266C> KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE)
267C> WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS
268C> (FOR THIS VERSION OF THE DECODER A=500)
269C> THAT MAY BE CONTAINED IN THE BUFR MESSAGE, AND
270C> WHERE B IS THE MAXIMUM NUMBER OF DESCRIPTOR
271C> COMBINATIONS THAT MAY BE PROCESSED.
272C> UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE
273C> A VALUE FOR B OF 1600, BUT FOR MOST OTHER DATA
274C> A VALUE FOR B OF 500 WILL SUFFICE
275C> MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE
276C> DATA ENTRY
277C> MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO
278C> THE DATA
279C>
280C> ATTRIBUTES:
281C> LANGUAGE: FORTRAN 77
282C> MACHINE: NAS
283C>
284 SUBROUTINE w3fi67(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX)
285C
286 CHARACTER*40 ANAME(700)
287 CHARACTER*24 AUNITS(700)
288C
289C
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
300C
301 CHARACTER*4 DIRID(2)
302C
303 LOGICAL SEC2
304C
305 SAVE
306C
307C PRINT *,' W3FI67 DECODER'
308C INITIALIZE ERROR RETURN
309 iptr(1) = 0
310 IF (index.GT.0) THEN
311C HAVE RE-ENTRY
312 index = index + 1
313C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
314 IF (index.GT.ident(14)) THEN
315C 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
328C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
329 END IF
330 iptr(39) = 0
331C 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
340C 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
351C TEST FOR EDITION NUMBER
352C ======================
353 CALL gbyte (msga,ident(1),inofst+24,8)
354C 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
361C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
362 inofst = inofst + 32
363 END IF
364 iptr(3) = inofst
365C SECTION 1 COUNT
366 CALL gbyte (msga,ivals,inofst,24)
367C 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
374C GET BUFR MASTER TABLE
375 CALL gbyte (msga,ivals,inofst,8)
376 inofst = inofst + 8
377 ident(17) = ivals(1)
378C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
379 ELSE
380 iptr(3) = inofst
381C SECTION 1 COUNT
382 CALL gbyte (msga,ivals,inofst,24)
383C 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
391C ======================
392C ORIGINATING CENTER
393 CALL gbyte (msga,ivals,inofst,16)
394 inofst = inofst + 16
395 ident(2) = ivals(1)
396C UPDATE SEQUENCE
397 CALL gbyte (msga,ivals,inofst,8)
398 inofst = inofst + 8
399 ident(3) = ivals(1)
400C 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
406C PRINT *,' NO OPTIONAL SECTION 2'
407 sec2 = .false.
408 END IF
409 inofst = inofst + 8
410C MESSAGE TYPE
411 CALL gbyte (msga,ivals,inofst,8)
412 ident(5) = ivals(1)
413 inofst = inofst + 8
414C MESSAGE SUB-TYPE
415 CALL gbyte (msga,ivals,inofst,8)
416 ident(6) = ivals(1)
417 inofst = inofst + 8
418C IF BUFR EDITION 0 OR 1 THEN
419C NEXT 2 BYTES ARE BUFR TABLE VERSION
420C ELSE
421C BYTE 11 IS VER NR OF MASTER TABLE
422C 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
428C BYTE 11 IS VER NR OF MASTER TABLE
429 CALL gbyte (msga,ivals,inofst,8)
430 ident(18) = ivals(1)
431 inofst = inofst + 8
432C 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
438C YEAR OF CENTURY
439 CALL gbyte (msga,ivals,inofst,8)
440 ident(8) = ivals(1)
441 inofst = inofst + 8
442C MONTH
443 CALL gbyte (msga,ivals,inofst,8)
444 ident(9) = ivals(1)
445 inofst = inofst + 8
446C DAY
447 CALL gbyte (msga,ivals,inofst,8)
448 ident(10) = ivals(1)
449 inofst = inofst + 8
450C HOUR
451 CALL gbyte (msga,ivals,inofst,8)
452 ident(11) = ivals(1)
453 inofst = inofst + 8
454C MINUTE
455 CALL gbyte (msga,ivals,inofst,8)
456 ident(12) = ivals(1)
457C RESET POINTER (INOFST) TO START OF
458C NEXT SECTION
459C (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
465C SECTION 2 COUNT
466 CALL gbyte (msga,iptr(4),inofst,24)
467 inofst = inofst + 32
468C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
469 kentry = (iptr(4) - 4) / 14
470C 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
485C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
486 2000 CONTINUE
487 END IF
488C RESET POINTER (INOFST) TO START OF
489C SECTION 3
490 inofst = iptr(5) + iptr(4) * 8
491 END IF
492C BIT OFFSET TO START OF SECTION 3
493 iptr( 7) = inofst
494C SECTION 3 COUNT
495 CALL gbyte (msga,iptr(6),inofst,24)
496C 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
503C 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
514C OBSERVED DATA FLAG
515 CALL gbyte (msga,ivals,inofst,1)
516 ident(15) = ivals(1)
517 inofst = inofst + 1
518C COMPRESSED DATA FLAG
519 CALL gbyte (msga,ivals,inofst,1)
520 ident(16) = ivals(1)
521 inofst = inofst + 7
522C CALCULATE NUMBER OF DESCRIPTORS
523 nrdesc = (iptr( 6) - 8) / 2
524 iptr(12) = nrdesc
525 iptr(13) = nrdesc
526C EXTRACT DESCRIPTORS
527 CALL gbytes (msga,istack,inofst,16,0,nrdesc)
528C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
529 DO 10 l = 1, nrdesc
530 iwork(l) = istack(l)
531C PRINT *,L,ISTACK(L)
532 10 CONTINUE
533 iptr(13) = nrdesc
534C RESET POINTER TO START OF SECTION 4
535 inofst = iptr(7) + iptr(6) * 8
536C BIT OFFSET TO START OF SECTION 4
537 iptr( 9) = inofst
538C 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
544C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
545 iptr( 8) = ivals(1)
546 inofst = inofst + 32
547C SET FOR STARTING BIT OF DATA
548 iptr(25) = inofst
549C FIND OUT IF '7777' TERMINATOR IS THERE
550 inofst = iptr(9) + iptr(8) * 8
551 CALL gbyte (msga,ivals,inofst,32)
552C 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)
562C PRINT *,'HAVE RETURNED FROM FI6701'
563 IF (iptr(1).NE.0) THEN
564 RETURN
565 END IF
566C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
567 IF (ident(5).EQ.2) THEN
568 IF (ident(6).EQ.7) THEN
569C DO 151 I = 1, 40
570C IF (I.LE.20) THEN
571C PRINT *,'IPTR(',I,')=',IPTR(I),
572C * ' IDENT(',I,')= ',IDENT(I)
573C ELSE
574C PRINT *,'IPTR(',I,')=',IPTR(I)
575C END IF
576C 151 CONTINUE
577C DO 153 I = 1, KNR(INDEX)
578C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
579C 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
589C DO 154 I = 1, KNR(INDEX)
590C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
591C 154 CONTINUE
592 END IF
593 END IF
594 RETURN
595 END
596
597C> @brief Data extraction.
598C> @author Bill Cavanaugh @date 1988-09-01
599
600C> Control the extraction of data from section 4 based on
601C> data descriptors.
602C>
603C> Program history log:
604C> - Bill Cavanaugh 1988-09-01
605C> - Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed
606C> data.
607C> - Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with
608C> delayed replication.
609C> - Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
610C>
611C> @param[in] IPTR See w5fi67 routine docblock.
612C> @param[in] IDENT See w3fi67 routine docblock.
613C> @param[in] MSGA Array containing bufr message.
614C> @param[inout] ISTACK [in] Original array of descriptors extracted from
615C> source bufr message. [out] Arrays containing data from table b.
616C> @param[in] MSTACK Working array of descriptors (expanded)and scaling
617C> factor.
618C> @param[inout] KDESC Image of current descriptor.
619C> @param[in] INDEX
620C> @param KNR
621C> @param[out] IWORK Working descriptor list
622C> @param IVALS
623C> @param[out] KDATA Array containing decoded reports from bufr message
624C> kdata(report number,parameter number).
625C> @param[out] ANAME Descriptor name..
626C> @param[out] AUNITS Units for descriptor.
627C> @param[out] MSCALE Scale for value of descriptor.
628C> @param[out] MREF Reference value for descriptor.
629C> @param[out] MWIDTH Bit width for value of descriptor.
630C>
631C> @note Error return:
632C> - IPTR(1)
633C> - = 8 ERROR READING TABLE B
634C> - = 9 ERROR READING TABLE D
635C> - = 11 ERROR OPENING TABLE B
636C>
637C> @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
642C
643 CHARACTER*40 ANAME(*)
644 CHARACTER*24 AUNITS(*)
645C
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)
661C
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/
668C
669C PRINT *,' DECOLL FI6701'
670 IF (index.GT.1) THEN
671 GO TO 1000
672 END IF
673C --------- 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
681C INITIALIZE OUTPUT AREA
682C SET POINTER TO BEGINNING OF DATA
683C SET BIT
684 iptr(17) = 1
685 1000 CONTINUE
686C IPTR(12) = IPTR(13)
687 ll = 0
688 iptr(11) = 1
689 IF (iptr(10).EQ.0) THEN
690C RE-ENTRY POINT FOR MULTIPLE
691C 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
699C PRINT *,'FI6701 - RPT',IPTR(17),' STARTS AT',IPTR(25)
700 iptr(24) = 0
701 iptr(31) = 0
702C POINTING AT NEXT AVAILABLE DESCRIPTOR
703 mm = 0
704 IF (iptr(21).EQ.0) THEN
705C 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
721C PRINT *,I
722C WRITE(6,21) MF,MX,MY,KDESC(I),
723C * (ANAME(I)(K:K),K=1,40),
724C * (AUNITS(I)(K:K),K=1,24),
725C * 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
732C CLOSE(UNIT=20,STATUS='KEEP')
733 iptr(21) = 1
734 END IF
735C DO WHILE MM <= 500
736 10 CONTINUE
737C PROCESS THRU THE FOLLOWING
738C 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
744C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
745 IF (iptr(11).GT.iptr(12)) THEN
746C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
747 IF (ident(16).NE.0) THEN
748C PRINT *,' PROCESSING COMPRESSED REPORTS'
749C REFORMAT DATA FROM DESCRIPTOR
750C FORM TO USER FORM
751 RETURN
752 ELSE
753C WRITE (6,1)
754C 1 FORMAT (1H1)
755C 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
764C RESET POINTERS
765 ll = 0
766 iptr(1) = 0
767 iptr(11) = 1
768 iptr(12) = iptr(13)
769C IS THIS LAST REPORT ?
770C PRINT *,'READY',IPTR(39),INDEX
771 IF (iptr(39).GT.0) THEN
772 IF (index.GT.0) THEN
773C 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
781C GET NEXT DESCRIPTOR
782 CALL fi6708 (iptr,iwork,lf,lx,ly,jdesc)
783C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
784C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
785C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
786C * ' FOR LOC',IPTR(17),IPTR(25)
787 IF (iptr(11).GT.1600) THEN
788 iptr(1) = 401
789 RETURN
790 END IF
791C
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
800C REPLICATION PROCESSING
801 IF (lf.EQ.1) THEN
802C ---------- 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
808C PRINT *,'FI6701-1',KPRM,MSTACK(1,KPRM),
809C * 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
817C
818C 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
827C PRINT *,'FI6701-2',KPRM,MSTACK(1,KPRM),
828C * 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
836C DESCRIPTOR SEQUENCE STRINGS
837 ELSE IF (lf.EQ.3) THEN
838C PRINT *,'F3 SEQUENCE DESCRIPTOR'
839 IF (iptr(22).EQ.0) THEN
840C READ IN TABLE D, BUT JUST ONCE
841 ierr = 0
842C 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
853C PRINT 16,(ITBLD(I,L),L=1,11)
854 GO TO 50
855 END IF
856 25 CONTINUE
857C 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
869C
870C STANDARD DESCRIPTOR PROCESSING
871 ELSE
872C 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)
876C 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
891C END IF
892C END DO WHILE
893 200 CONTINUE
894 IF (ident(16).NE.0) THEN
895C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
896 ELSE
897C 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
909C> @brief Process standard descriptor.
910C> @author Bill Cavanaugh @date 1988-09-01
911
912C> Process a standard descriptor (f = 0) and store data
913C> in output array.
914C>
915C> Program history log:
916C> - Bill Cavanaugh 1988-09-01
917C> - Bill Cavanaugh 1991-04-04 Changed to pass width of text fields in bytes.
918C>
919C> @param[in] IPTR See w3fi67 routine docblock.
920C> @param[in] IDENT See w3fi67 routine docblock.
921C> @param[in] MSGA Array containing bufr message.
922C> @param[inout] KDATA Array containing decoded reports from bufr message.
923C> KDATA(Report number, parameter number)
924C> @param[inout] KDESC Image of current descriptor.
925C> @param[in] MSTACK
926C> @param LL
927C> @param[out] AUNITS Units for descriptor.
928C> @param[out] MSCALE Scale for value of descriptor.
929C> @param[out] MREF Reference value for descriptor.
930C> @param[out] MWIDTH Bit width for value of descriptor.
931C> @param JDESC
932C> @param[in] IVALS Array of single parameter values.
933C> @param J
934C>
935C> @note Error return:
936C> IPTR(1) = 3 - Message contains a descriptor with f=0
937C> that does not exist in table b.
938C>
939C> @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
944C TABLE B ENTRY
945 CHARACTER*24 ASKEY
946 CHARACTER*24 AUNITS(*)
947C 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(*)
956C TABLE B ENTRY
957C
958 DATA askey /'CCITT IA5 '/
959C
960C PRINT *,' FI6702 - STANDARD DESCRIPTOR PROCESSOR'
961C GET A MATCH BETWEEN CURRENT
962C DESCRIPTOR (JDESC) AND
963C TABLE B ENTRY
964C IF (KDESC(356).EQ.0) THEN
965C PRINT *,'FI6702 - KDESC(356) WENT TO ZER0'
966C IPTR(1) = 600
967C RETURN
968C 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
977C HAVE SKIP FLAG
978 IF (ident(16).NE.0) THEN
979C SKIP OVER COMPRESSED DATA
980C LOWEST
981 iptr(25) = iptr(25) + iptr(36)
982C 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
992C 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
1003C SKIP OVER NON-COMPRESSED DATA
1004C 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
1038C HAVE A MATCH
1039C 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
1047C 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
1054C NOT COMPRESSED
1055 CALL fi6704(iptr,msga,kdata,ivals,mstack,
1056 * mwidth,mref,mscale,j,ll,jdesc)
1057 END IF
1058 RETURN
1059 END
1060C> @brief Process compressed data and place individual elements into output
1061C> array
1062C> @author Bill Cavanaugh @date 1988-09-01
1063
1064C> Program history log:
1065C> - Bill Cavanaugh 1988-09-01
1066C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
1067C> modified to hanle width of fields in bytes.
1068C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
1069C> and uncompressed form gave different results. This has been corrected.
1070C> - Bill Cavanaugh 1991-06-21 Processing of text data has been changed to
1071C> provide exact reproduction of all characters.
1072C>
1073C> @param[in] IPTR See w3fi67() routine docblock.
1074C> @param[in] IDENT See w3fi67() routine docblock.
1075C> @param[in] MSGA Array containing bufr message, mstack.
1076C> @param[in] MSTACK
1077C> @param[in] IVALS Array of single parameter values.
1078C> @param[inout] J
1079C> @param[out] KDATA Array containing decoded reports from bufr message.
1080C> kdata(report number,parameter number).
1081C> @param JDESC
1082C> Arrays Containing data from table b.
1083C> @param[out] MSCALE Scale for value of descriptor.
1084C> @param[out] MREF Reference value for descriptor.
1085C> @param[out] MWIDTH Bit width for value of descriptor.
1086C>
1087C> @note List caveats, other helpful hints or information.
1088C>
1089C> @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
1094C
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)
1104C
1105 LOGICAL TEXT
1106C
1107 INTEGER MSK(28)
1108C
1109C
1110 DATA msk /1,3,7,15,31,63,127,
1111C 1 2 3 4 5 6 7
1112 * 255,511,1023,2047,4095,
1113C 8 9 10 11 12
1114 * 8191,16383,32767,65535,
1115C 13 14 15 16
1116 * 131071,262143,524287,
1117C 17 18 19
1118 * 1048575,2097151,4194303,
1119C 20 21 22
1120 * 8388607,16777215,33554431,
1121C 23 24 25
1122 * 67108863,134217727,268435455/
1123C 26 27 28
1124C
1125C PRINT *,' FI6703 COMPR J=',J,' MWIDTH(J) =',MWIDTH(J),
1126C * ' 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
1132C PRINT *,'DESCRIPTOR',KPRM
1133 IF (.NOT.text) THEN
1134 IF (iptr(29).GT.0) THEN
1135C WORKING WITH ASSOCIATED FIELDS HERE
1136 iptr(31) = iptr(31) + 1
1137 kprm = iptr(31) + iptr(24)
1138C GET LOWEST
1139 CALL gbyte (msga,lowest,iptr(25),iptr(29))
1140 iptr(25) = iptr(25) + iptr(29)
1141C GET NBINC
1142 CALL gbyte (msga,nbinc,iptr(25),6)
1143 iptr(25) = iptr(25) + 6
1144C 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
1164C SET PARAMETER
1165C ISOLATE STANDARD BIT WIDTH
1166 jwide = mwidth(j) + iptr(26)
1167C SINGLE VALUE FOR LOWEST
1168 nrvals = 1
1169C LOWEST
1170C PRINT *,'PARAM',KPRM
1171 CALL gbyte (msga,lowest,iptr(25),jwide)
1172C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
1173 iptr(25) = iptr(25) + jwide
1174C ISOLATE COMPRESSED BIT WIDTH
1175 CALL gbyte (msga,nbinc,iptr(25),6)
1176C 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
1180C PRINT *,'FOR DESCRIPTOR',JDESC
1181C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' MWIDTH(J)=',
1182C * MWIDTH(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
1183C DO 110 I = 1, KPRM
1184C WRITE (6,111)I,(KDATA(J,I),J=1,6)
1185C 110 CONTINUE
1186 111 FORMAT (1x,5hdata ,i3,6(2x,i10))
1187 iptr(1) = 500
1188C 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
1194C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
1195C IF TEXT EVENT, PROCESS TEXT
1196C GET COMPRESSED VALUES
1197C 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
1204C RECALCULATE TO ORIGINAL VALUES
1205 DO 100 i = 1, nrvals
1206C 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
1217C PRINT *,I,JDESC,LOWEST,MREF(J,1),MREF(J,3)
1218C 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
1235C 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
1242C WRITE (6,80) (DATA(I,KPRM),I=1,10)
1243C 80 FORMAT(2X,10(F10.2,1X))
1244 ELSE IF (text) THEN
1245C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
1246C GET LOWEST
1247C 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
1257C GET NBINC
1258 CALL gbyte (msga,nbinc,iptr(25),6)
1259C 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
1266C 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
1276C 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
1281C CONVERTS ASCII TO EBCIDIC
1282C COMMENT OUT IF NOT IBM370 COMPUTER
1283C PRINT *,IDATA
1284 CALL w3ai39 (idata,4)
1285 mstack(1,kprm) = jdesc
1286 mstack(2,kprm) = 0
1287 kdata(n,kprm) = idata
1288C SET FOR NEXT PART
1289 kprm = kprm + 1
1290 iptr(24) = iptr(24) + 1
1291C 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
1303C CONVERTS ASCII TO EBCIDIC
1304C 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
1309C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
1310 nbits = 0
1311 END IF
1312C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
1313C1800 FORMAT (2X,I4,2X,3A4)
1314 1900 CONTINUE
1315 END IF
1316 RETURN
1317 END
1318C> @brief Process data that is not compressed.
1319C> @author Bill Cavanaugh @date 1988-09-01
1320
1321C> Program history log:
1322C> - Bill Cavanaugh 1988-09-01
1323C> - Bill Cavanaugh 1991-01-18 Modified to properly handle non-compressed
1324C> data.
1325C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
1326C> modified to handle field width in bytes.
1327C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
1328C> and uncompressed form gave different results. This has been corrected.
1329C>
1330C> @param[in] IPTR See w3fi67 routine docblock
1331C> @param[in] MSGA Array containing bufr message
1332C> @param[inout] IVALS Array of single parameter values
1333C> @param[out] KDATA Array containing decoded reports from bufr message.
1334C> kdata(report number,parameter number)
1335C> @param[inout] J [in] ? [out] arrays containing data from table b
1336C> @param[out] MSCALE Scale for value of descriptor
1337C> @param[in] MSTACK
1338C> @param LL
1339C> @param JDESC
1340C> @param[out] MREF Reference value for descriptor
1341C> @param[out] MWIDTH Bit width for value of descriptor
1342C>
1343C> @note Error return:
1344C> - IPTR(1) = 13 - Bit width on ASCII chars not a multiple of 8.
1345C>
1346C> @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
1351C
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
1360C
1361C
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/
1369C
1370C 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
1375C -------- NOCMP --------
1376C ISOLATE BIT WIDTH
1377 jwide = mwidth(j) + iptr(26)
1378C IF NOT TEXT EVENT, PROCESS
1379 IF (iptr(18).NE.1) THEN
1380C 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)
1390C PRINT *,'FI6704-A',KPRM,MSTACK(1,KPRM),
1391C * 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
1402C GET VALUES
1403C CALL TO GET DATA OF GIVEN BIT WIDTH
1404 CALL gbyte (msga,ivals,iptr(25),jwide)
1405C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
1406 iptr(25) = iptr(25) + jwide
1407C 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
1417C PRINT *,'FI6704-B',KPRM,MSTACK(1,KPRM),
1418C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
1419C IF(JDESC.EQ.2049) THEN
1420C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
1421C END IF
1422C PRINT *,'FI6704 ',KPRM,MSTACK(1,KPRM),
1423C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1424 ELSE
1425C IF TEXT EVENT, PROCESS TEXT
1426C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
1427 nrchrs = iptr(40)
1428 nrbits = nrchrs * 8
1429C 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)
1436C PRINT 1801,KANY,IDATA,IPTR(17),KPRM
1437C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4))
1438C CONVERTS ASCII TO EBCIDIC
1439C 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
1445C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
1446C * 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
1452C PRINT *,'LAST TEXT WORD'
1453 CALL gbyte (msga,idata,iptr(25),nrbits)
1454 iptr(25) = iptr(25) + nrbits
1455C CONVERTS ASCII TO EBCIDIC
1456C 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
1464C PRINT 1723,IDATA
1465 1723 FORMAT (12x,z8)
1466 1722 CONTINUE
1467 END IF
1468 kdata(iptr(17),kprm) = idata
1469C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
1470 mstack(1,kprm) = jdesc
1471 mstack(2,kprm) = 0
1472C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
1473C * KDATA(IPTR(17),KPRM)
1474 END IF
1475C TURN OFF TEXT
1476 iptr(18) = 0
1477 END IF
1478 RETURN
1479 END
1480C> @brief Process a replication descriptor, must extract number
1481C> of replications of n descriptors from the data stream.
1482C> @author Bill Cavanaugh @date 1988-09-01
1483
1484C> Process a replication descriptor, must extract number
1485C> of replications of n descriptors from the data stream.
1486C>
1487C> Program history log:
1488C> - Bill Cavanaugh 1988-09-01
1489C>
1490C> @param[in] IWORK Working descriptor list
1491C> @param[in] IPTR See w3fi67 routine docblock
1492C> @param[in] IDENT See w3fi67 routine docblock
1493C> @param[inout] LX X portion of current descriptor
1494C> @param[inout] LY Y portion of current descriptor
1495C> @param[out] KDATA Array containing decoded reports from bufr message.
1496C> kdata(report number,parameter number)
1497C> @param LL
1498C> @param KNR
1499C> @param MSTACK
1500C> @param MSGA
1501C>
1502C> @note Error return:
1503C> - IPTR(1)
1504C> - = 12 Data descriptor qualifier does not follow
1505C> delayed replication descriptor.
1506C> - = 20 Exceeded count for delayed replication pass.
1507C>
1508C> @author Bill Cavanaugh @date 1988-09-01
1509 SUBROUTINE fi6705(IPTR,IDENT,MSGA,IWORK,LX,LY,
1510 * KDATA,LL,KNR,MSTACK)
1511
1512 SAVE
1513C
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(*)
1523C
1524C PRINT *,' REPLICATION FI6705'
1525C DO 100 I = 1, IPTR(13)
1526C PRINT *,I,IWORK(I)
1527C 100 CONTINUE
1528C NUMBER OF DESCRIPTORS
1529 nrset = lx
1530C NUMBER OF REPLICATIONS
1531 nrreps = ly
1532 icurr = iptr(11) - 1
1533 ipick = iptr(11) - 1
1534C
1535 IF (nrreps.EQ.0) THEN
1536 iptr(39) = 1
1537C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
1538C IPTR(31) = IPTR(31) + 1
1539C KPRM = IPTR(31) + IPTR(24)
1540C MSTACK(1,KPRM) = JDESC
1541C MSTACK(2,KPRM) = 0
1542C KDATA(IPTR(17),KPRM) = 0
1543C PRINT *,'FI6705-1',KPRM,MSTACK(1,KPRM),
1544C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
1545C DELAYED REPLICATION - MUST GET NUMBER OF
1546C REPLICATIONS FROM DATA.
1547C GET NEXT DESCRIPTOR
1548 CALL fi6708(iptr,iwork,lf,lx,ly,jdesc)
1549C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
1550C MUST BE DATA DESCRIPTION
1551C 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
1561C SET SINGLE VALUE FOR SEQUENTIAL,
1562C MULTIPLE VALUES FOR COMPRESSED
1563 IF (ident(16).EQ.0) THEN
1564C NON COMPRESSED
1565 CALL gbyte (msga,kvals,iptr(25),jwide)
1566C 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)
1574C PRINT *,'FI6705-2',KPRM,MSTACK(1,KPRM),
1575C * 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
1591C PRINT *,'NOT DELAYED REPLICATION'
1592 END IF
1593C RESTRUCTURE WORKING STACK W/REPLICATIONS
1594C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
1595C 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
1599C PRINT *,'REPLICATION ',I,ITEMP(I)
1600 1000 CONTINUE
1601C MOVE TRAILING DESCRIPTORS TO HOLD AREA
1602 lax = iptr(12) - iptr(11) + 1
1603C 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
1607C PRINT *,' ',I,KTEMP(I)
1608 2000 CONTINUE
1609C REPLICATIONS INTO ISTACK
1610C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
1611C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
1612 DO 4000 i = 1, nrreps
1613 DO 3000 j = 1, nrset
1614 iwork(icurr) = itemp(j)
1615C PRINT *,'FI6705 A',ICURR,IWORK(ICURR)
1616 icurr = icurr + 1
1617 3000 CONTINUE
1618 4000 CONTINUE
1619C PRINT *,' TO LOC',ICURR-1
1620C RESTORE TRAILING DESCRIPTORS
1621C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
1622 DO 5000 i = 1, lax
1623 iwork(icurr) = ktemp(i)
1624C 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
1632C> @brief Process operator descriptors.
1633C> @author Bill Cavanaugh @date 1988-09-01
1634
1635C> Extract and save indicated change values for use
1636C> until changes are rescinded, or extract text strings indicated
1637C> through 2 05 yyy.
1638C>
1639C> Program history log:
1640C> - Bill Cavanaugh 1988-09-01
1641C> - Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
1642C> - Bill Cavanaugh 1991-05-10 Coding has been added to process proposed
1643C> table c descriptor 2 06 yyy.
1644C> - Bill Cavanaugh 1991-11-21 Coding has been added to properly process
1645C> table c descriptor 2 03 yyy, the change
1646C> to new reference value for selected
1647C> descriptors.
1648C>
1649C> @param[in] IPTR See w3fi67 routine docblock.
1650C> @param[in] LX X portion of current descriptor.
1651C> @param[in] LY Y portion of current descriptor.
1652C> @param[out] KDATA Array containing decoded reports from bufr message.
1653C> kdata(report number,parameter number)
1654C> arrays containing data from table b
1655C> @param[out] MSCALE Scale for value of descriptor
1656C> @param[out] MREF Reference value for descriptor
1657C> @param[out] MWIDTH Bit width for value of descriptor
1658C> @param IDENT
1659C> @param MSGA
1660C> @param IVALS
1661C> @param MSTACK
1662C> @param J
1663C> @param LL
1664C> @param KDESC
1665C> @param IWORK
1666C> @param JDESC
1667C>
1668C> @note Error return:
1669C> - IPTR(1) = 5 - Erroneous x value in data descriptor operator
1670C>
1671C> @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
1685C
1686C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
1687 IF (lx.EQ.1) THEN
1688C CHANGE BIT WIDTH
1689 IF (ly.EQ.0) THEN
1690C PRINT *,' RETURN TO NORMAL WIDTH'
1691 iptr(26) = 0
1692 ELSE
1693C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
1694 iptr(26) = ly - 128
1695 END IF
1696 ELSE IF (lx.EQ.2) THEN
1697C CHANGE SCALE
1698 IF (ly.EQ.0) THEN
1699C RESET TO STANDARD SCALE
1700 iptr(27) = 0
1701 ELSE
1702C SET NEW SCALE
1703 iptr(27) = ly - 128
1704 END IF
1705 ELSE IF (lx.EQ.3) THEN
1706C CHANGE REFERENCE VALUE
1707C FOR EACH OF THOSE DESCRIPTORS BETWEEN
1708C 2 03 YYY WHERE Y LT 255 AND
1709C 2 03 255, EXTRACT THE NEW REFERENCE
1710C VALUE (BIT WIDTH YYY) AND PLACE
1711C IN TERTIARY TABLE B REF VAL POSITION,
1712C SET FLAG IN SECONDARY REFVAL POSITION
1713C THOSE DESCRIPTORS DO NOT HAVE DATA
1714C ASSOCIATED WITH THEM, BUT ONLY
1715C IDENTIFY THE TABLE B ENTRIES THAT
1716C ARE GETTING NEW REFERENCE VALUES.
1717 kyyy = ly
1718 IF (kyyy.GT.0.AND.kyyy.LT.255) THEN
1719C START CYCLING THRU DESCRIPTORS UNTIL
1720C TERMINATE NEW REF VALS IS FOUND
1721 300 CONTINUE
1722 CALL fi6708 (iptr,iwork,lf,lx,ly,jdesc)
1723 IF (jdesc.EQ.33791) THEN
1724C IF 2 03 255 THEN RETURN
1725 RETURN
1726 ELSE
1727C FIND MATCHING TABLE B ENTRY
1728 DO 500 lj = 1, iptr(14)
1729 IF (jdesc.EQ.kdesc(lj)) THEN
1730C TURN ON NEW REF VAL FLAG
1731 mref(lj,2) = 1
1732C INSERT NEW REF VAL
1733 CALL gbyte (msga,mref(lj,3),iptr(25),kyyy)
1734C GO GET NEXT DESCRIPTOR
1735 GO TO 300
1736 END IF
1737 500 CONTINUE
1738C 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
1743C MUST TURN OFF ALL NEW
1744C REFERENCE VALUES
1745 DO 400 i = 1, iptr(14)
1746 mref(i,2) = 0
1747 400 CONTINUE
1748 END IF
1749C LX = 3
1750C MUST BE CONCLUDED WITH Y=255
1751 ELSE IF (lx.EQ.4) THEN
1752C ASSOCIATED VALUES
1753 IF (ly.EQ.0) THEN
1754 iptr(29) = 0
1755C 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
1762C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
1763 END IF
1764 ELSE IF (lx.EQ.5) THEN
1765C PROCESS TEXT DATA
1766 iptr(40) = ly
1767 iptr(18) = 1
1768 IF (ident(16).EQ.0) THEN
1769C PRINT *,'2 05 YYY - TEXT - NONCOMPRESSED MODE'
1770 CALL fi6704(iptr,msga,kdata,ivals,mstack,
1771 * mwidth,mref,mscale,j,ll,jdesc)
1772 ELSE
1773C 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
1782C SKIP NEXT DESCRIPTOR
1783C SET TO PASS OVER DESCRIPTOR AND DATA
1784C IF DESCRIPTOR NOT IN TABLE B
1785 iptr(36) = ly
1786C 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
1797C> @brief Substitute descriptor queue for queue descriptor
1798C> @author Bill Cavanaugh @date 1988-09-01
1799
1800C> Substitute descriptor queue for queue descriptor
1801C>
1802C> Program history log:
1803C> - Bill Cavanaugh 1988-09-01
1804C> - Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors.
1805C> - Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors.
1806C> based on tests with live data.
1807C>
1808C> @param[in] IWORK Working descriptor list.
1809C> @param[in] IPTR See w3fi67 routine docblock.
1810C> @param[in] ITBLD Array containing descriptor queues.
1811C> @param[in] JDESC Queue descriptor to be expanded.
1812C>
1813C> @author Bill Cavanaugh @date 1988-09-01
1814 SUBROUTINE fi6707(IPTR,IWORK,ITBLD,JDESC)
1815
1816 SAVE
1817C
1818 INTEGER IPTR(*),JDESC
1819 INTEGER IWORK(*),IHOLD(1600)
1820 INTEGER ITBLD(500,11)
1821C
1822C PRINT *,' FI6707 F3 ENTRY',IPTR(11),IPTR(12)
1823C SET FOR BINARY SEARCH IN TABLE D
1824C DO 2020 I = 1, IPTR(12)
1825C PRINT *,'ENTRY IWORK',I,IWORK(I)
1826C2020 CONTINUE
1827 jlo = 1
1828 jhi = iptr(20)
1829C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC
1830 10 CONTINUE
1831 jmid = (jlo + jhi) / 2
1832C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1)
1833C
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
1862C HAVE TABLE D MATCH
1863C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11)
1864C 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)
1871C 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
1879C NOTHING MORE TO APPEND
1880C PRINT *,'NOTHING MORE TO APPEND'
1881 ELSE
1882C APPEND TRAILING IWORK TO IHOLD
1883C 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
1889C RESET IHOLD TO IWORK
1890C 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
1897C PRINT *,' FI6707 F3 EXIT ',IPTR(11),IPTR(12)
1898C DO 2000 I = 1, IPTR(12)
1899C PRINT *,'EXIT IWORK',I,IWORK(I)
1900C2000 CONTINUE
1901C RESET POINTERS
1902 iptr(11) = iptr(11) - 1
1903 RETURN
1904 END
1905C> @brief Subroutine FI6708
1906C> @author Bill Cavanaugh @date 1989-01-17
1907
1908C> Program history log:
1909C> - Bill Cavanaugh 1988-09-01
1910C>
1911C> @param[inout] IPTR See w3fi67() routine docblock.
1912C> @param[in] IWORK Working descriptor list.
1913C> @param LF
1914C> @param LX
1915C> @param LY
1916C> @param[in] JDESC Queue descriptor to be expanded.
1917C>
1918C> @note List caveats, other helpful hints or information.
1919C>
1920C> @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
1925C
1926C 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
1934C PRINT *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY
1935 iptr(11) = iptr(11) + 1
1936 RETURN
1937 END
1938C> @brief Reformat decoded profiler data to show heights instead of
1939C> height increments.
1940C> @author Bill Cavanaugh @date 1990-02-14
1941
1942C> Reformat decoded profiler data to show heights instead of
1943C> height increments.
1944C>
1945C> Program history log:
1946C> - Bill Cavanaugh 1990-02-14
1947C>
1948C> @param[in] IDENT Array contains message information extracted from
1949C> BUFR message:
1950C> - IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1)
1951C> - IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1)
1952C> - IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1)
1953C> - IDENT( 4)- (BYTE 8, SECTION 1)
1954C> - IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1)
1955C> - IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1)
1956C> - IDENT( 7)- (BYTES 11-12, SECTION 1)
1957C> - IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1)
1958C> - IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1)
1959C> - IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1)
1960C> - IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1)
1961C> - IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1)
1962C> - IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1)
1963C> - IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3)
1964C> - IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3)
1965C> - IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3)
1966C> @param[in] MSTACK Working descriptor list and scaling factor
1967C> @param[in] KDATA Array containing decoded reports
1968C> @param[in] IPTR See w3fi67
1969C>
1970C> @note List caveats, other helpful hints or information.
1971C>
1972C> @author Bill Cavanaugh @date 1990-02-14
1973 SUBROUTINE fi6709(IDENT,MSTACK,KDATA,IPTR)
1974
1975 SAVE
1976C ----------------------------------------------------------------
1977C
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)
1984C
1985C ----------------------------------------------------------
1986C LOOP FOR NUMBER OF SUBSETS/REPORTS
1987 DO 3000 i = 1, ident(14)
1988C INIT FOR DATA INPUT ARRAY
1989 mk = 1
1990C INIT FOR DESC OUTPUT ARRAY
1991 jk = 0
1992C LOCATION
1993 isw = 0
1994 DO 200 j = 1, 3
1995C LATITUDE
1996 IF (mstack(1,mk).EQ.1282) THEN
1997 isw = isw + 1
1998 GO TO 100
1999C LONGITUDE
2000 ELSE IF (mstack(1,mk).EQ.1538) THEN
2001 isw = isw + 2
2002 GO TO 100
2003C 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
2012C SAVE DESCRIPTOR
2013 kprofl(jk) = mstack(1,mk)
2014C SAVE SCALE
2015 kprof2(jk) = mstack(2,mk)
2016C 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
2025C TIME
2026 isw = 0
2027 DO 400 j = 1, 7
2028C YEAR
2029 IF (mstack(1,mk).EQ.1025) THEN
2030 isw = isw + 1
2031 GO TO 300
2032C MONTH
2033 ELSE IF (mstack(1,mk).EQ.1026) THEN
2034 isw = isw + 2
2035 GO TO 300
2036C DAY
2037 ELSE IF (mstack(1,mk).EQ.1027) THEN
2038 isw = isw + 4
2039 GO TO 300
2040C HOUR
2041 ELSE IF (mstack(1,mk).EQ.1028) THEN
2042 isw = isw + 8
2043 GO TO 300
2044C MINUTE
2045 ELSE IF (mstack(1,mk).EQ.1029) THEN
2046 isw = isw + 16
2047 GO TO 300
2048C 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
2059C SAVE DESCRIPTOR
2060 kprofl(jk) = mstack(1,mk)
2061C SAVE SCALE
2062 kprof2(jk) = mstack(2,mk)
2063C 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
2072C SURFACE DATA
2073 krg = 0
2074 isw = 0
2075 DO 600 j = 1, 10
2076C WIND SPEED
2077 IF (mstack(1,mk).EQ.2818) THEN
2078 isw = isw + 1
2079 GO TO 500
2080C WIND DIRECTION
2081 ELSE IF (mstack(1,mk).EQ.2817) THEN
2082 isw = isw + 2
2083 GO TO 500
2084C PRESS REDUCED TO MSL
2085 ELSE IF (mstack(1,mk).EQ.2611) THEN
2086 isw = isw + 4
2087 GO TO 500
2088C TEMPERATURE
2089 ELSE IF (mstack(1,mk).EQ.3073) THEN
2090 isw = isw + 8
2091 GO TO 500
2092C RAINFALL RATE
2093 ELSE IF (mstack(1,mk).EQ.3342) THEN
2094 isw = isw + 16
2095 GO TO 500
2096C RELATIVE HUMIDITY
2097 ELSE IF (mstack(1,mk).EQ.3331) THEN
2098 isw = isw + 32
2099 GO TO 500
2100C 1ST RANGE GATE OFFSET
2101 ELSE IF (mstack(1,mk).EQ.1982.OR.
2102 * mstack(1,mk).EQ.1983) THEN
2103C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
2104C 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
2114C PRINT *,'INITIAL INCR =',INCRHT
2115 ELSE
2116 lhgt = 500 + ihgt - kdata(i,mk)
2117 isw = isw + 64
2118C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
2119 END IF
2120 END IF
2121C MODE #1
2122 ELSE IF (mstack(1,mk).EQ.8128) THEN
2123 isw = isw + 128
2124 GO TO 500
2125C 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
2132C SAVE DESCRIPTOR
2133 jk = jk + 1
2134 kprofl(jk) = mstack(1,mk)
2135C SAVE SCALE
2136 kprof2(jk) = mstack(2,mk)
2137C SAVE DATA
2138 kset2(jk) = kdata(i,mk)
2139C IF (I.EQ.1) THEN
2140C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
2141C 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
2150C 43 LEVELS
2151 DO 2000 l = 1, 43
2152 2020 CONTINUE
2153 isw = 0
2154C HEIGHT INCREMENT
2155 IF (mstack(1,mk).EQ.1982) THEN
2156C 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
2165C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
2166C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
2167 lhgt = lhgt + incrht
2168C PRINT *,'LEVEL ',L,LHGT
2169 IF (l.EQ.37) THEN
2170 lhgt = lhgt + incrht
2171 END IF
2172 jk = jk + 1
2173C SAVE DESCRIPTOR
2174 kprofl(jk) = 1798
2175C SAVE SCALE
2176 kprof2(jk) = 0
2177C SAVE DATA
2178 kset2(jk) = lhgt
2179C IF (I.EQ.10) THEN
2180C PRINT *,' '
2181C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
2182C 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
2188C 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
2198C 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
2207C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
2208C DESCRIPTORS AND DATA
2209 IF (iand(isw,1).NE.0) THEN
2210 IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
2211C SAVE DD DESCRIPTOR
2212 jk = jk + 1
2213 kprofl(jk) = 2817
2214C SAVE SCALE
2215 kprof2(jk) = 0
2216C SAVE DD DATA
2217 kset2(jk) = 32767
2218C SAVE FFF DESCRIPTOR
2219 jk = jk + 1
2220 kprofl(jk) = 2818
2221C SAVE SCALE
2222 kprof2(jk) = 1
2223C SAVE FFF DATA
2224 kset2(jk) = 32767
2225 ELSE
2226C GENERATE DDFFF
2227 CALL w3fc05 (vectu,vectv,dir,spd)
2228 ndir = dir
2229 spd = spd
2230 nspd = spd
2231C PRINT *,' ',NDIR,NSPD
2232C SAVE DD DESCRIPTOR
2233 jk = jk + 1
2234 kprofl(jk) = 2817
2235C SAVE SCALE
2236 kprof2(jk) = 0
2237C SAVE DD DATA
2238 kset2(jk) = dir
2239C IF (I.EQ.1) THEN
2240C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
2241C END IF
2242C SAVE FFF DESCRIPTOR
2243 jk = jk + 1
2244 kprofl(jk) = 2818
2245C SAVE SCALE
2246 kprof2(jk) = 1
2247C SAVE FFF DATA
2248 kset2(jk) = spd
2249C IF (I.EQ.1) THEN
2250C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
2251C END IF
2252 END IF
2253 END IF
2254 GO TO 800
2255C W VECTOR VALUE
2256 ELSE IF (mstack(1,mk).EQ.3010) THEN
2257 isw = isw + 4
2258 GO TO 700
2259C Q/C TEST RESULTS
2260 ELSE IF (mstack(1,mk).EQ.8130) THEN
2261 isw = isw + 8
2262 GO TO 700
2263C 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
2267C 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
2271C SPECTRAL PEAK POWER
2272 ELSE IF (mstack(1,mk).EQ.5568) THEN
2273 isw = isw + 64
2274 GO TO 700
2275C U,V VARIABILITY
2276 ELSE IF (mstack(1,mk).EQ.3011) THEN
2277 isw = isw + 128
2278 GO TO 700
2279C 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
2290C SAVE DESCRIPTOR
2291 kprofl(jk) = mstack(1,mk)
2292C SAVE SCALE
2293 kprof2(jk) = mstack(2,mk)
2294C SAVE DATA
2295 kset2(jk) = kdata(i,mk)
2296 mk = mk + 1
2297C IF (I.EQ.1) THEN
2298C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
2299C 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
2308C MOVE DATA BACK INTO KDATA ARRAY
2309 DO 4000 ll = 1, jk
2310 kdata(i,ll) = kset2(ll)
2311 4000 CONTINUE
2312 3000 CONTINUE
2313C PRINT *,'REBUILT ARRAY'
2314 DO 5000 ll = 1, jk
2315C DESCRIPTOR
2316 mstack(1,ll) = kprofl(ll)
2317C SCALE
2318 mstack(2,ll) = kprof2(ll)
2319C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
2320 5000 CONTINUE
2321C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
2322 iptr(31) = jk
2323 RETURN
2324 END
2325C> @brief Reformat profiler edition 2 data
2326C> @author Bill Cavanaugh @date 1993-01-27
2327
2328C> Reformat profiler data in edition 2
2329C>
2330C> Program history log:
2331C> - Bill Cavanaugh 1993-01-27
2332C>
2333C> @param[in] IDENT Array contains message information extracted from
2334C> BUFR message:
2335C> - IDENT( 1)-Edition number (byte 4, section 1)
2336C> - IDENT( 2)-Originating center (bytes 5-6, section 1)
2337C> - IDENT( 3)-Update sequence (byte 7, section 1)
2338C> - IDENT( 4)- (byte 8, section 1)
2339C> - IDENT( 5)-BUFR message type (byte 9, section 1)
2340C> - IDENT( 6)-BUFR msg sub-type (byte 10, section 1)
2341C> - IDENT( 7)- (bytes 11-12, section 1)
2342C> - IDENT( 8)-Year of century (byte 13, section 1)
2343C> - IDENT( 9)-Month of year (byte 14, section 1)
2344C> - IDENT(10)-Day of month (byte 15, section 1)
2345C> - IDENT(11)-Hour of day (byte 16, section 1)
2346C> - IDENT(12)-Minute of hour (byte 17, section 1)
2347C> - IDENT(13)-Rsvd by adp centers(byte 18, section 1)
2348C> - IDENT(14)-Nr of data subsets (byte 5-6, section 3)
2349C> - IDENT(15)-Observed flag (byte 7, bit 1, section 3)
2350C> - IDENT(16)-Compression flag (byte 7, bit 2, section 3)
2351C> @param[in] MSTACK Working descriptor list and scaling factor
2352C> @param[in] KDATA Array containing decoded reports from bufr message.
2353C> kdata(report number,parameter number)
2354C> (report number limited to value of input argument
2355C> maxr and parameter number limited to value of input
2356C> argument maxd)
2357C> @param[in] IPTR See w3fi67
2358C>
2359C> @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)
2368C 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
2375C BLOCK NUMBER
2376 isw = isw + 1
2377 ELSE IF (mstack(1,mk).EQ.258) THEN
2378C STATION NUMBER
2379 isw = isw + 2
2380 ELSE IF (mstack(1,mk).EQ.1282) THEN
2381C LATITUDE
2382 isw = isw + 4
2383 ELSE IF (mstack(1,mk).EQ.1538) THEN
2384C LONGITUDE
2385 isw = isw + 8
2386 ELSE IF (mstack(1,mk).EQ.1793) THEN
2387C 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)
2398C PRINT *,JK,KPROFL(JK),KSET2(JK)
2399 mk = mk + 1
2400 200 CONTINUE
2401C PRINT *,'LOCATION ',ISW
2402 IF (isw.NE.31) THEN
2403 print *,'LOCATION ERROR PROCESSING PROFILER'
2404 iptr(10) = 200
2405 RETURN
2406 END IF
2407C PROCESS TIME ELEMENTS
2408 isw = 0
2409 DO 400 j = 1, 7
2410 IF (mstack(1,mk).EQ.1025) THEN
2411C YEAR
2412 isw = isw + 1
2413 ELSE IF (mstack(1,mk).EQ.1026) THEN
2414C MONTH
2415 isw = isw + 2
2416 ELSE IF (mstack(1,mk).EQ.1027) THEN
2417C DAY
2418 isw = isw + 4
2419 ELSE IF (mstack(1,mk).EQ.1028) THEN
2420C HOUR
2421 isw = isw + 8
2422 ELSE IF (mstack(1,mk).EQ.1029) THEN
2423C MINUTE
2424 isw = isw + 16
2425 ELSE IF (mstack(1,mk).EQ.2069) THEN
2426C TIME SIGNIFICANCE
2427 isw = isw + 32
2428 ELSE IF (mstack(1,mk).EQ.1049) THEN
2429C 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)
2439C PRINT *,JK,KPROFL(JK),KSET2(JK)
2440 mk = mk + 1
2441 400 CONTINUE
2442C PRINT *,'TIME ',ISW
2443 IF (isw.NE.127) THEN
2444 print *,'TIME ERROR PROCESSING PROFILER'
2445 iptr(1) = 201
2446 RETURN
2447 END IF
2448C SURFACE DATA
2449 isw = 0
2450C 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
2467C 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)
2480C 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
2493C MUST SAVE THIS HEIGHT VALUE
2494 lhgt = 500 + ihgt - kdata(i,mk)
2495C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT
2496 mk = mk + 1
2497C PROCESS LEVEL DATA
2498 DO 2000 l = 1, 43
2499 2020 CONTINUE
2500 isw = 0
2501C HEIGHT INCREMENT
2502 IF (mstack(1,mk).EQ.1797) THEN
2503 incrht = kdata(i,mk)
2504C 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
2512C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
2513C AT THIS POINT
2514 lhgt = lhgt + incrht
2515C PRINT *,'LEVEL ',L,LHGT
2516 IF (l.EQ.37) THEN
2517 lhgt = lhgt + incrht
2518 END IF
2519 jk = jk + 1
2520C SAVE DESCRIPTOR
2521 kprofl(jk) = 1798
2522C SAVE SCALE
2523 kprof2(jk) = 0
2524C SAVE DATA
2525 kset2(jk) = lhgt
2526C PRINT *,JK,KPROFL(JK),KSET2(JK)
2527 isw = 0
2528 icon = 1
2529 DO 800 j = 1, 10
2530750 CONTINUE
2531 IF (mstack(1,mk).EQ.1797) THEN
2532 GO TO 2020
2533 ELSE IF (mstack(1,mk).EQ.6432) THEN
2534C HI/LO MODE
2535 isw = isw + 1
2536 ELSE IF (mstack(1,mk).EQ.6434) THEN
2537C Q/C TEST
2538 isw = isw + 2
2539 ELSE IF (mstack(1,mk).EQ.2070) THEN
2540 IF (icon.EQ.1) THEN
2541C FIRST PASS - U,V CONSENSUS
2542 isw = isw + 4
2543 icon = icon + 1
2544 ELSE
2545C SECOND PASS - W CONSENSUS
2546 isw = isw + 64
2547 END IF
2548 ELSE IF (mstack(1,mk).EQ.2819) THEN
2549C 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
2559C 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
2568C SAVE DD DESCRIPTOR
2569 jk = jk + 1
2570 kprofl(jk) = 2817
2571 kprof2(jk) = 0
2572 kset2(jk) = 32767
2573C 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
2583C PRINT *,' ',NDIR,NSPD
2584C SAVE DD DESCRIPTOR
2585 jk = jk + 1
2586 kprofl(jk) = 2817
2587 kprof2(jk) = 0
2588 kset2(jk) = ndir
2589C IF (I.EQ.1) THEN
2590C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
2591C ENDIF
2592C SAVE FFF DESCRIPTOR
2593 jk = jk + 1
2594 kprofl(jk) = 2818
2595 kprof2(jk) = 1
2596 kset2(jk) = nspd
2597C IF (I.EQ.1) THEN
2598C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
2599C ENDIF
2600 END IF
2601 mk = mk + 1
2602 GO TO 800
2603 END IF
2604 ELSE IF (mstack(1,mk).EQ.2866) THEN
2605C SPEED STD DEVIATION
2606 isw = isw + 32
2607C -- A CHANGE BY KEYSER : POWER DESC. BACK TO 5568
2608 ELSE IF (mstack(1,mk).EQ.5568) THEN
2609C SIGNAL POWER
2610 isw = isw + 128
2611 ELSE IF (mstack(1,mk).EQ.2822) THEN
2612C W COMPONENT
2613 isw = isw + 256
2614 ELSE IF (mstack(1,mk).EQ.2867) THEN
2615C VERT STD DEVIATION
2616 isw = isw + 512
2617 ELSE
2618 mk = mk + 1
2619 GO TO 750
2620 END IF
2621 jk = jk + 1
2622C SAVE DESCRIPTOR
2623 kprofl(jk) = mstack(1,mk)
2624C SAVE SCALE
2625 kprof2(jk) = mstack(2,mk)
2626C SAVE DATA
2627 kset2(jk) = kdata(i,mk)
2628 mk = mk + 1
2629C 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
2642C MOVE DATA BACK INTO KDATA ARRAY
2643 DO 5000 ll = 1, jk
2644C DESCRIPTOR
2645 mstack(1,ll) = kprofl(ll)
2646C SCALE
2647 mstack(2,ll) = kprof2(ll)
2648C DATA
2649C 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
fi6709
subroutine fi6709(ident, mstack, kdata, iptr)
Reformat decoded profiler data to show heights instead of height increments.
Definition w3fi67.f:1974
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
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
fi6707
subroutine fi6707(iptr, iwork, itbld, jdesc)
Substitute descriptor queue for queue descriptor.
Definition w3fi67.f:1815
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
fi6710
subroutine fi6710(ident, mstack, kdata, iptr)
Reformat profiler edition 2 data.
Definition w3fi67.f:2361
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
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
fi6708
subroutine fi6708(iptr, iwork, lf, lx, ly, jdesc)
Subroutine FI6708.
Definition w3fi67.f:1922
fi6704
subroutine fi6704(iptr, msga, kdata, ivals, mstack, mwidth, mref, mscale, j, ll, jdesc)
Process data that is not compressed.
Definition w3fi67.f:1349
fi6702
subroutine fi6702(iptr, ident, msga, kdata, kdesc, ll, mstack, aunits, mwidth, mref, mscale, jdesc, ivals, j)
Process standard descriptor.
Definition w3fi67.f:942