NCEPLIBS-w3emc 2.12.0
Loading...
Searching...
No Matches
w3fi85.f
Go to the documentation of this file.
1C> @file
2C> @brief Generate bufr message
3C> @author Bill Cavanaugh @date 1993-09-29
4
5C> Using information available in supplied arrays, generate
6C> a bufr message (wmo code fm94). there may be a section 2
7C> included in the bufr message if the user follows proper procedure.
8C> messages are constructed in accordance with bufr edition 2. entries
9C> for section 1 must be passed to this routine in the isect1 array.
10C> entries for section 3 must be passed to this routine in isect3.
11C>
12C>
13C> In the event that the user requests a reduction of reports
14C> in a bufr message if a particular message becomes oversized, the
15C> possibility exists of the last block of data producing an oversized
16C> message. the user must verify that isect3(6) does in fact equal
17C> zero to assure that all of the data has been included as output.
18C>
19C> Program history log:
20C> - Bill Cavanaugh 1993-09-29
21C> - J. Hoppa 1994-03-22 Corrected an error when writing the
22C> descriptors into the bufr message
23C> - J. Hoppa 1994-03-31 Added the subset number to the parameter list
24C> of subroutine fi8501()
25C> - J. Hoppa 1994-04-15 Added kbufr to the parameter list of
26C> subroutine fi8502()
27C> - J. Hoppa 1994-04-20 Added the kdata parameter counter to the
28C> parameter list of subroutine fi8501()
29C> - J. Hoppa 1995-04-29 Changed nq and n to kary(2) changed jk to kary(11)
30C> added an assignment to kary(2) so have something to pass to subroutines
31C> deleted jk and ll from call to fi8501()
32C>
33C> @param[in] ISTEP Key for selection of processing step
34C> - 1 = Process integer/text array into kdata.
35C> - 2 = Process real/text array into kdata.
36C> - 3 = Construct bufr message.
37C> @param[in] IUNITB Unit number of device containing table b
38C> @param[in] IUNITD Unit number of device containing table d
39C> @param[in] IBFSIZ Size in bytes of bufr message array (kbufr)
40C> should be a multiple of word size.
41C> @param[in] ISECT1 Contains information to enter into section 1
42C> (1) Edition number
43C> (2) Bufr master table number
44C> 0 = meteorological
45C> others not yet defined
46C> (3) Originating center - subcenter number
47C> (4) Originating center number
48C> (5) Update sequence number
49C> (6) Optional section flag should be set to zero unless user write
50C> additional code to enter local information into section 3
51C> (7) Bufr message type
52C> (8) Bufr message sub_type
53C> (9) Master table version number
54C> (10) Local table version number
55C> (11) Year of century - representative of data
56C> (12) Month - representative of data
57C> (13) Day - representative of data
58C> (14) Hour - representative of data
59C> (15) Minute - representative of data
60C> (16)-(20) Unused
61C> @param[in] ISECT3 Values to be inserted into section 3, and to control
62C> report reduction for oversized messages
63C> - (1) Number of subsets
64C> Defines the number of subsets being passed to the encoder routine for
65C> inclusion into a bufr message. If the user has specified the use of the
66C> subset/report reduction activation switch, then a part of those subsets may
67C> be used for the current message and the remainder retained for a subsequent
68C> message.
69C> - (2) Observed flag
70C> - 0 = observed data
71C> - 1 = other data
72C> - (3) Compressed flag
73C> - 0 = noncompressed
74C> - 1 = compressed
75C> - (4) Subset/report reduction activation switch used to control the number
76C> of reports entered into a bufr message when maximum message size is exceeded
77C> - 0 = option not active
78C> - 1 = option is active. unused subsets will be shifted to low order
79C> positions of entry array.
80C> - 2 = option is active. unused subsets will remain in entry positions.
81C> @note If this flag is set to any other values, program will be terminated
82C> with an error condition.
83C> - (5) Number of reports to decrement by, if oversized message
84C> (minimum value = one). If zero is entered, it will
85C> be replaced by one.
86C> - (6) Number of unused reports returned to user
87C> - (7) Number of reports included in message
88C> - (8) Number of table b entries available to decoder
89C> - (9) Number of table d entries available to decoder
90C> - (10) Text input flag
91C> - 0 = ASCII input
92C> - 1 = EBCIDIC input
93C> @param[in] JIF JDESC input format flag
94C> - 0 = F X Y
95C> - 1 = Decimal format
96C> @param[in] JDESC List of descriptors to go into section 3
97C> Each descriptor = F * 16384 + X * 256 + Y
98C> They may or may not be an exact match of the working descriptor list in kdesc.
99C> This set of descriptors may contain sequence descriptors to provide additional
100C> compression within the bufr message. There may be as few as one sequence
101C> descriptor, or as many descriptors as there are in kdesc.
102C> @param[in] NEWNR NR of descriptors in JDESC
103C> @param[in] IDATA Integer array dimensioned by the number of descriptors to
104C> be used
105C> @param[in] RDATA Real array dimensioned by the number of descriptors to be
106C> used
107C> @param[in] ATEXT Array containing all text data associated with a specific
108C> report. All data identified as text data must be in ASCII.
109C> @param[in] KASSOC Integer array dimensioned by the number of descriptors
110C> to be used, containing the associated field values for any entry in the
111C> descriptor list.
112C> @param[in] KIF KDESC input format flag
113C> - 0 = F X Y
114C> - 1 = DECIMAL FORMAT
115C> @param[in] KDESC List of descriptors to go into section 3 fully expanded set of working
116C> descriptors. there should be an element descriptor for every data entry, but
117C> there should be no sequence descriptors.
118C> @param[in] NRDESC NR of descriptors in kdesc
119C> @param[in] ISEC2D Data or text to be entered into section 2
120C> @param[in] ISEC2B Number of bytes of data in isec2d
121C> @param[out] KDATA Source data array . a 2-dimension integer array where
122C> kdata(subset,param) subset = subset number param = parameter number.
123C> @param[out] KARY Working array for message under construction
124C> - (1) unused
125C> - (2) parameter pointer
126C> - (3) message bit pointer
127C> - (4) delayed replication flag
128C> - 0 = no delayed replication
129C> - 1 = contains delayed replication
130C> - (5) bit pointer for start of section 4
131C> - (6) unused
132C> - (7) nr of bits for parameter/data packing
133C> - (8) total bits for ascii data
134C> - (9) scale change value
135C> - (10) indicator (used in w3fi85)
136C> - 1 = numeric data
137C> - 2 = text data
138C> - (11) pointer to current pos in kdesc
139C> - (12) unused
140C> - (13) unused
141C> - (14) unused
142C> - (15) data type
143C> - (16) unused
144C> - (17) unused
145C> - (18) words added for text or associated fields
146C> - (19) location for total byte count
147C> - (20) size of section 0
148C> - (21) size of section 1
149C> - (22) size of section 2
150C> - (23) size of section 3
151C> - (24) size of section 4
152C> - (25) size of section 5
153C> - (26) nr bits added by table c operator
154C> - (27) bit width of associated field
155C> - (28) jdesc input form flag
156C> - 0 = Descriptor in f x y form
157C> - F in JDESC(1,I)
158C> - X in JDESC(2,I)
159C> - Y in JDESC(3,I)
160C> - 1 = DEscriptor in decimal form in jdesc(1,i)
161C> - (29) kdesc input form flag
162C> - 0 = Descriptor in F X Y form
163C> - F in KDESC(1,I)
164C> - X in KDESC(2,I)
165C> - Y in KDESC(3,I)
166C> - 1 = Descriptor in decimal form in kdesc(1,i)
167C> - (30) bufr message total byte count
168C> @param[out] KBUFR Array to contain completed bufr message
169C> @param[out] IERRTN Error return flag
170C>
171C> IERRTN:
172C> - = 0 Normal return, bufr message resides in kbufr
173C> - if isect3(4)= 0, all reports have been processed into a bufr message
174C> - if isect3(4)= 1, a bufr message has been generated with all or part of
175C> the data passed to this routine. isect3(6) contains the number of reports
176C> that were not used but are being held for the next message.
177C> - = 1 bufr message construction was halted because contents exceeded maximum size
178C> (only when isect3(4) = 0)
179C> - = 2 bufr message construction was halted because of encounter with a
180C> descriptor not found in table b.
181C> - = 3 routine was called with no subsets
182C> - = 4 error occured while reading table b
183C> - = 5 an attempt was made to expand jdesc into kdesc, but a descriptor indicating
184C> delayed replication was encountered
185C> - = 6 error occured while reading table d
186C> - = 7 data value could not be contained in specified bit width
187C> - = 8 delayed replication not permitted in compressed data format
188C> - = 9 an operator descriptor 2 04 yyy opening an associated field (yyy not eq zero)
189C> was not followed by the defining descriptor 0 31 021 (7957 decimal).
190C> - = 10 delayed replication descriptor was not followed by descriptor for delayed
191C> replication factor.
192C> - 0 31 001
193C> - 0 31 002
194C> - 0 31 011
195C> - 0 31 012
196C> - = 11 encountered a reference value that forced a data element to become negative
197C> - = 12 no matching table d entry for sequence descriptor.
198C> - = 13 encountered a non-acceptable data entry flag. isect3(6) should be 0 or 1.
199C> - = 14 converting descriptors fxy->decimal, number to convert = 0
200C> - = 15 no descriptors specified for section 3
201C> - = 16 incomplete table b, number of descriptors in table b does not match number of
202C> descriptors needed to construct bufr message
203C> - = 20 incorrect entry of replication or sequence descriptor in list of reference
204C> value changes
205C> - = 21 incorrect operator descriptor in list of reference value changes
206C> - = 22 attempting to enter new reference value into table b, but descriptor
207C> does not exist in current modified table b
208C>
209C> @author Bill Cavanaugh @date 1993-09-29
210 SUBROUTINE w3fi85(ISTEP,IUNITB,IUNITD,IBFSIZ,ISECT1,ISECT3,
211 * JIF,JDESC,NEWNR,IDATA,RDATA,ATEXT,KASSOC,
212 * KIF,KDESC,NRDESC,ISEC2D,ISEC2B,
213 * KDATA,KARY,KBUFR,IERRTN)
214C
215 REAL RDATA(*)
216C
217 INTEGER IDATA(*),LOWEST,MAXVAL,JSTART
218 INTEGER KARY(*),MISG,LL
219 INTEGER KDESC(3,*),KASSOC(*)
220 INTEGER IBITS(32)
221 INTEGER ZEROS(255)
222 INTEGER INDEXB(16383)
223 CHARACTER*9 CCITT
224 CHARACTER*4 AHOLD(2)
225 CHARACTER*1 ATEXT(*)
226 LOGICAL*1 TEXT
227 LOGICAL*1 MSGFLG,DUPFLG
228C =====================================
229C INFORMATION REQUIRED FOR CONSTRUCTION OF BUFR MESSAGE
230 INTEGER ISECT1(*)
231 INTEGER ISEC2B,ISEC2D(255)
232 INTEGER ISECT3(*)
233 INTEGER JDESC(3,*)
234 INTEGER NEWNR
235 INTEGER KDATA(500,*)
236 INTEGER KBUFR(*)
237C =====================================
238C TABLE B INFORMATION
239 INTEGER LDESC(800),KT(800)
240 INTEGER KSCALE(800)
241 INTEGER KRFVAL(800),KRFVSW(800),NEWRFV(800)
242 INTEGER KWIDTH(800)
243 CHARACTER*40 ANAME(800)
244 CHARACTER*25 AUNITS(800)
245C =====================================
246C TABLE D INFORMATION
247 INTEGER KSEQ(300),KNUM(300)
248 INTEGER KLIST(300,10)
249C =====================================
250 SAVE
251C
252 DATA ccitt /'CCITT IA5'/
253 DATA ibits / 1, 3, 7, 15,
254 * 31, 63, 127, 255,
255 * 511, 1023, 2047, 4095,
256 * 8191, 16383, 32767, 65535,
257 * z'0001FFFF',z'0003FFFF',z'0007FFFF',z'000FFFFF',
258 * z'001FFFFF',z'003FFFFF',z'007FFFFF',z'00FFFFFF',
259 * z'01FFFFFF',z'03FFFFFF',z'07FFFFFF',z'0FFFFFFF',
260 * z'1FFFFFFF',z'3FFFFFFF',z'7FFFFFFF',z'FFFFFFFF'/
261 DATA ll /0/
262 DATA misg /99999/
263 DATA zeros /255*0/
264C =====================================
265C THERE MUST BE DESCRIPTORS IN JDESC
266C AND A COUNT IN NEWNR
267C =====================================
268 IF (newnr.EQ.0) THEN
269 ierrtn = 15
270 RETURN
271 END IF
272C =====================================
273C IF INPUT FORM IS F X Y SEGMENTS THEN
274C CONVERT INPUT FORM OF JDESC FROM FXY TO DECIMAL
275C =====================================
276 IF (jif.EQ.0) THEN
277C CONVERT TO DECIMAL
278 CALL fi8505(jif,jdesc,newnr,ierrtn)
279 IF (ierrtn.NE.0) THEN
280 RETURN
281 END IF
282 END IF
283C =====================================
284C IF PROCESSING DELAYED REPLICATION, MUST RELOAD
285C KDESC FROM JDESC
286C =====================================
287 IF (kary(4).NE.0) THEN
288 nrdesc = 0
289 END IF
290C =====================================
291C IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC
292C =====================================
293C IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC
294 IF (nrdesc.EQ.0) THEN
295 DO 50 i = 1, newnr
296 kdesc(1,i) = jdesc(1,i)
297 50 CONTINUE
298 nrdesc = newnr
299 kif = 1
300 ELSE IF (nrdesc.NE.0) THEN
301C KDESC ALL READY EXISTS
302 IF (kif.EQ.0) THEN
303C CONVERT INPUT FORM OF KDESC FROM FXY TO DECIMAL
304 CALL fi8505(kif,kdesc,nrdesc,ierrtn)
305 IF (ierrtn.NE.0) THEN
306 RETURN
307 END IF
308 END IF
309 END IF
310C =====================================
311C READ IN TABLE B SUBSET, IF NOT ALL READY IN PLACE
312C =====================================
313 IF (isect3(8).EQ.0) THEN
314 CALL fi8512(iunitb,isect3,kdesc,nrdesc,kary,ierrtn,
315 * ldesc,aname,aunits,kscale,krfval,kwidth,krfvsw,
316 * iunitd,kseq,knum,klist,indexb)
317 IF (ierrtn.NE.0) GO TO 9000
318 END IF
319C =====================================
320C ROUTE TO SELECTED PROCESSING
321C =====================================
322 ksub = isect3(1)
323 IF (istep.EQ.1) THEN
324C PROCESSING INTEGER DATA INPUT
325 CALL fi8508(istep,iunitb,idata,kdesc,nrdesc,atext,ksub,kary,
326 * kdata,ldesc,aname,aunits,kscale,krfval,krfvsw,isect3,
327 * kwidth,kassoc,iunitd,kseq,knum,klist,ierrtn,indexb)
328 RETURN
329 ELSE IF (istep.EQ.2) THEN
330C PROCESSING REAL DATA INPUT
331 CALL fi8509(istep,iunitb,rdata,kdesc,nrdesc,atext,ksub,kary,
332 * kdata,ldesc,aname,aunits,kscale,krfval,krfvsw,isect3,
333 * kwidth,kassoc,iunitd,kseq,knum,klist,ierrtn,indexb)
334 RETURN
335 ELSE IF (istep.NE.3) THEN
336 ierrtn = 20
337 RETURN
338 END IF
339C =====================================
340C IF INDICATING ZERO SUBSETS, HAVE AN ERROR CONDITION
341C =====================================
342 IF (isect3(1).LE.0) THEN
343 ierrtn = 3
344 RETURN
345 END IF
346C =====================================
347C SET FOR BUFR MESSAGE
348C =====================================
349C
350C CLEAR OUTPUT AREA
351C BYTES IN EACH FULL WORD
352 kword = 4
353C
354C GET NUMBER OF SUBSETS
355C
356 mxrpts = isect3(1)
357 isect3(7) = isect3(1)
358 isect3(6) = isect3(1)
359C
360C RE-START POINT FOR PACKING FEWER SUBSETS ?
361C
362 5 CONTINUE
363C
364 kary(18) = 0
365 kary(26) = 0
366C =====================================
367C ENTER 'BUFR' - SECTION 0
368C CONSTRUCT UNDER RULES OF EDITION 2
369C =====================================
370 kary(3) = 0
371 nbufr = 1112884818
372 CALL sbyte (kbufr,nbufr,kary(3),32)
373 kary(3) = kary(3) + 32
374C SAVE POINTER FOR TOTAL BYTE COUNT
375C IN MESSAGE
376 kary(19) = kary(3)
377 kary(3) = kary(3) + 24
378C SET EDITION NR IN PLACE
379 CALL sbyte (kbufr,2,kary(3),8)
380 kary(3) = kary(3) + 8
381 kary(20) = 8
382C PRINT *,'SECTION 0'
383C =====================================
384C COMPLETE ENTRIES FOR - SECTION 1
385C =====================================
386C ----- 1,3 SECTION COUNT
387 kary(21) = 18
388 CALL sbyte (kbufr,kary(21),kary(3),24)
389 kary(3) = kary(3) + 24
390C ----- 4 RESERVED
391 CALL sbyte (kbufr,0,kary(3),8)
392 kary(3) = kary(3) + 8
393C ----- 5 ORIGINATING SUB-CENTER
394 CALL sbyte (kbufr,isect1(3),kary(3),8)
395 kary(3) = kary(3) + 8
396C ----- 6 ORIGINATING CENTER
397 CALL sbyte (kbufr,isect1(4),kary(3),8)
398 kary(3) = kary(3) + 8
399C ----- 7 UPDATE SEQUENCE NUMBER
400 CALL sbyte (kbufr,isect1(5),kary(3),8)
401 kary(3) = kary(3) + 8
402C ----- 8
403C INDICATE NO SECTION 2
404 CALL sbyte (kbufr,isect1(6),kary(3),1)
405 kary(3) = kary(3) + 1
406 CALL sbyte (kbufr,0,kary(3),7)
407 kary(3) = kary(3) + 7
408C ----- 9 BUFR MESSAGE TYPE
409 CALL sbyte (kbufr,isect1(7),kary(3),8)
410 kary(3) = kary(3) + 8
411C ----- 10 BUFR MESSAGE SUB-TYPE
412 CALL sbyte (kbufr,isect1(8),kary(3),8)
413 kary(3) = kary(3) + 8
414C ----- 11 VERSION OF MASTER TABLE
415 CALL sbyte (kbufr,isect1(9),kary(3),8)
416 kary(3) = kary(3) + 8
417C ----- 12 VERSION OF LOCAL TABLE
418 CALL sbyte (kbufr,isect1(10),kary(3),8)
419 kary(3) = kary(3) + 8
420C ----- 13 YEAR
421 CALL sbyte (kbufr,isect1(11),kary(3),8)
422 kary(3) = kary(3) + 8
423C ----- 14 MONTH
424 CALL sbyte (kbufr,isect1(12),kary(3),8)
425 kary(3) = kary(3) + 8
426C ---- 15 DAY
427 CALL sbyte (kbufr,isect1(13),kary(3),8)
428 kary(3) = kary(3) + 8
429C ----- 16 HOUR
430 CALL sbyte (kbufr,isect1(14),kary(3),8)
431 kary(3) = kary(3) + 8
432C ----- 17 MINUTE
433 CALL sbyte (kbufr,isect1(15),kary(3),8)
434 kary(3) = kary(3) + 8
435C ----- 18 FILL
436 CALL sbyte (kbufr,0,kary(3),8)
437 kary(3) = kary(3) + 8
438C PRINT *,'SECTION 1'
439C =====================================
440C SKIP - SECTION 2
441C =====================================
442 IF (isect1(6).NE.0) THEN
443C BUILD SECTION COUNT
444 kary(22) = 4 + isec2b
445 IF (mod(kary(22),2).NE.0) kary(22) = kary(22) + 1
446C INSERT SECTION COUNT
447 CALL sbyte (kbufr,kary(22),kary(3),24)
448 kary(3) = kary(3) + 24
449C INSERT RESERVED POSITION
450 CALL sbyte (kbufr,0,kary(3),8)
451 kary(3) = kary(3) + 8
452C INSERT SECTION 2 DATA
453 CALL sbytes(kbufr,isec2d,kary(3),8,0,isec2b)
454 kary(3) = kary(3) + (isec2b * 8)
455 IF (mod(isec2b,2).NE.0) THEN
456 CALL sbyte (kbufr,0,kary(3),8)
457 kary(3) = kary(3) + 8
458 END IF
459 ELSE
460 kary(22) = 0
461 END IF
462C =====================================
463C MAKE PREPARATIONS FOR SECTION 3 DESCRIPTORS
464C =====================================
465 kary(23) = 7 + newnr*2 + 1
466C SECTION 3 SIZE
467 CALL sbyte (kbufr,kary(23),kary(3),24)
468 kary(3) = kary(3) + 24
469C RESERVED BYTE
470 CALL sbyte (kbufr,0,kary(3),8)
471 kary(3) = kary(3) + 8
472C NUMBER OF SUBSETS
473 CALL sbyte (kbufr,isect3(1),kary(3),16)
474 kary(3) = kary(3) + 16
475C SET OBSERVED DATA SWITCH
476 CALL sbyte (kbufr,isect3(2),kary(3),1)
477 kary(3) = kary(3) + 1
478C SET COMPRESSED DATA SWITCH
479 CALL sbyte (kbufr,isect3(3),kary(3),1)
480 kary(3) = kary(3) + 1
481 CALL sbyte (kbufr,0,kary(3),6)
482 kary(3) = kary(3) + 6
483C =====================================
484C DESCRIPTORS - SECTION 3
485C =====================================
486 DO 37 kh = 1, newnr
487C PRINT *,'INSERTING',JDESC(1,KH),' INTO SECTION 3'
488 CALL sbyte (kbufr,jdesc(1,kh),kary(3),16)
489 kary(3) = kary(3) + 16
490 37 CONTINUE
491C FILL TO TWO BYTE BOUNDARY
492 CALL sbyte (kbufr,0,kary(3),8)
493 kary(3) = kary(3) + 8
494C PRINT *,'SECTION 3'
495C =====================================
496C INITIALIZE FOR - SECTION 4
497C =====================================
498C SAVE POINTER TO COUNT POSITION
499C PRINT *,'START OF SECTION 4',KARY(3)
500 kary(5) = kary(3)
501 kary(3) = kary(3) + 24
502 CALL sbyte (kbufr,0,kary(3),8)
503 kary(3) = kary(3) + 8
504C SKIP TO FIRST DATA POSITION
505C =====================================
506C BIT PATTERNS - SECTION 4
507C =====================================
508 kend4 = ibfsiz * 8 - 32
509C PACK ALL DATA INTO BUFR MESSAGE
510C
511 IF (isect3(3).EQ.0) THEN
512C **********************************************
513C * *
514C * PROCESS AS NON-COMPRESSED MESSAGE *
515C * *
516C **********************************************
517 CALL fi8506(istep,isect3,kary,jdesc,newnr,kdesc,nrdesc,
518 * ldesc,aname,aunits,kscale,krfval,kwidth,krfvsw,newrfv,
519 * kseq,knum,klist,ibfsiz,
520 * kdata,kbufr,ierrtn,indexb)
521 IF (ierrtn.NE.0) THEN
522 IF (ierrtn.EQ.1) GO TO 5500
523 RETURN
524 END IF
525 ELSE
526C **********************************************
527C * *
528C * PROCESS AS COMPRESSED MESSAGE *
529C * *
530C **********************************************
531 kary(18) = 0
532C MUST LOOK AT EVERY DESCRIPTOR IN KDESC
533 kary(11) = 1
534 3000 CONTINUE
535 IF (kary(11).GT.nrdesc) THEN
536 GO TO 5200
537 ELSE
538C DO 5000 JK = 1, NRDESC
539C RE-ENTRY POINT FOR INSERTION OF
540C REPLICATION OR SEQUENCES
541 4000 CONTINUE
542C ISOLATE TABLE
543 kfunc = kdesc(1,kary(11)) / 16384
544C ISOLATE CLASS
545 kclass = mod(kdesc(1,kary(11)),16384) / 256
546 kseg = mod(kdesc(1,kary(11)),256)
547 kary(2) = kary(11) + kary(18)
548 IF (kfunc.EQ.1) THEN
549C DELAYED REPLICATION NOT ALLOWED
550C IN COMPRESSED MESSAGE
551 IF (kseg.EQ.0) THEN
552 ierrtn = 8
553 RETURN
554 END IF
555C REPLICATION DESCRIPTOR
556 CALL fi8501(kary,istep,kclass,kseg,idata,rdata,
557 * kdata,ll,kdesc,nrdesc,ierrtn)
558C GO TO 4000
559 ELSE IF (kfunc.EQ.2) THEN
560 CALL fi8502(*4000,kbufr,kclass,kseg,
561 * kdesc,nrdesc,i,istep,
562 * kary,kdata,isect3,krfvsw,newrfv,ldesc,ierrtn,indexb)
563 IF (ierrtn.NE.0) THEN
564 RETURN
565 END IF
566 GO TO 5000
567 ELSE IF (kfunc.EQ.3) THEN
568 CALL fi8503(kary(11),kdesc,nrdesc,
569 * isect3,iunitd,kseq,knum,klist,ierrtn)
570 IF (ierrtn.NE.0) THEN
571 RETURN
572 END IF
573 GO TO 4000
574 END IF
575C FALL THRU WITH ELEMENT DESCRIPTOR
576C POINT TO CORRECT TABLE B ENTRY
577 l = indexb(kdesc(1,kary(11)))
578 IF (l.LT.0) THEN
579 ierrtn = 2
580C PRINT *,'W3FI85 - IERRTN = 2'
581 RETURN
582 END IF
583C
584 IF (aunits(l)(1:9).EQ.ccitt) THEN
585 text = .true.
586 ELSE
587 text = .false.
588 END IF
589 kary(7) = kwidth(l)
590C
591 IF (text) THEN
592C PROCESS TEXT DATA
593 kbz = kary(3) + (isect3(1) + 1) * kary(7) + 6
594 IF (kbz.GT.kend4) THEN
595 GO TO 5500
596 END IF
597C NBINC IS NUMBER OF CHARS
598 nbinc = kary(7) / 8
599C LOWEST = 0
600 CALL sbytes(kbufr,zeros,kary(3),8,0,nbinc)
601 kary(3) = kary(3) + kary(7)
602 CALL sbyte (kbufr,nbinc,kary(3),6)
603 kary(3) = kary(3) + 6
604C HOW MANY FULL WORDS
605 nkpass = kary(7) / 32
606C HOW MANY BYTES IN PARTIAL WORD
607 krem = mod(kary(7),32)
608C KSKIP = KARY(7) - 32
609 DO 4080 nss = 1, isect3(1)
610C POINT TO TEXT FOR THIS SUBSET
611 kary(2) = kary(11) + kary(18)
612 IF (nkpass.GE.1) THEN
613C PROCESS TEXT IN A SUBSET
614 DO 4070 npp = 1, nkpass
615C PROCESS FULL WORDS
616 IF (isect3(10).EQ.1) THEN
617 CALL w3ai38 (kdata(nss,kary(2)),4)
618 END IF
619 CALL sbyte (kbufr,kdata(nss,kary(2)),
620 * kary(3),32)
621 kary(3) = kary(3) + 32
622C POINT TO NEXT DATA WORD FOR MORE TEXT
623 kary(2) = kary(2) + 1
624 4070 CONTINUE
625 END IF
626C PROCESS PARTIALS - LESS THAN 4 BYTES
627 IF (krem.GT.0) THEN
628 IF (isect3(10).EQ.1) THEN
629 CALL w3ai38 (kdata(nss,kary(2)),4)
630 END IF
631 CALL sbyte (kbufr,kdata(nss,kary(2)),
632 * kary(3),krem)
633 kary(3) = kary(3) + krem
634 END IF
635 4080 CONTINUE
636C ADJUST EXTRA WORD COUNT
637 IF (krem.GT.0) THEN
638 kary(18) = kary(18) + nkpass
639 ELSE
640 kary(18) = kary(18) + nkpass - 1
641 END IF
642C -------------------------------------------------------------
643 GO TO 5000
644 ELSE
645 kary(2) = kary(11) + kary(18)
646 kary(7) = kwidth(l) + kary(26)
647C
648C NON TEXT/NUMERIC DATA
649C
650C PROCESS ASSOCIATED FIELD DATA
651 IF (kary(27).GT.0.AND.kdesc(1,kary(11)).NE.7957) THEN
652 dupflg = .true.
653 DO 4130 j = 2, isect3(1)
654 IF (kdata(j,kary(2)).NE.kdata(1,kary(2)))THEN
655 dupflg = .false.
656 GO TO 4131
657 END IF
658 4130 CONTINUE
659 4131 CONTINUE
660 IF (dupflg) THEN
661C ALL VALUES ARE EQUAL
662 kbz = kary(3) + kary(7) + 6
663 IF (kbz.GT.kend4) THEN
664 GO TO 5500
665 END IF
666 nbinc = 0
667C ENTER COMMON VALUE
668 IF (kdata(1,kary(2)).EQ.misg) THEN
669 CALL sbyte(kbufr,ibits(kary(7)),
670 * kary(3),kary(27))
671 ELSE
672 CALL sbyte(kbufr,kdata(1,kary(2)),
673 * kary(3),kary(27))
674 END IF
675 kary(3) = kary(3) + kary(27)
676C ENTER NBINC
677 CALL sbyte (kbufr,nbinc,kary(3),6)
678 kary(3) = kary(3) + 6
679 ELSE
680C MIX OF MISSING AND VALUES
681C GET LARGEST DIFFERENCE VALUE
682 msgflg = .false.
683 DO 4132 j = 1, isect3(7)
684 IF (kdata(j,kary(2)).EQ.misg) THEN
685 msgflg = .true.
686 GO TO 4133
687 END IF
688 4132 CONTINUE
689 4133 CONTINUE
690 DO 4134 j = 1, isect3(7)
691 IF (kdata(j,kary(2)).LT.ibits(kary(27))
692 * .AND.kdata(j,kary(2)).GE.0.AND.
693 * kdata(j,kary(2)).NE.misg) THEN
694 lowest = kdata(j,kary(2))
695 maxval = kdata(j,kary(2))
696 jstart = j + 1
697 GO TO 4135
698 END IF
699 4134 CONTINUE
700 4135 CONTINUE
701 DO 4136 j = jstart, isect3(7)
702 IF (kdata(j,kary(2)).NE.misg) THEN
703 IF (kdata(j,kary(2)).LT.lowest) THEN
704 lowest = kdata(j,kary(2))
705 ELSE IF(kdata(j,kary(2)).GT.maxval)THEN
706 maxval = kdata(j,kary(2))
707 END IF
708 END IF
709 4136 CONTINUE
710 mxdiff = maxval - lowest
711C FIND NBINC
712 mxbits = kary(27)
713 DO 4142 lj = 1, mxbits
714 nbinc = lj
715 IF (mxdiff.LT.ibits(lj)) THEN
716 GO TO 4143
717 END IF
718 4142 CONTINUE
719 4143 CONTINUE
720 kbz = kary(3) + mxbits + 6 + isect3(1) * nbinc
721 IF (kbz.GT.kend4) THEN
722 GO TO 5500
723 END IF
724 IF (nbinc.GT.mxbits) THEN
725 ierrtn = 3
726 RETURN
727 END IF
728C ENTER LOWEST
729 CALL sbyte(kbufr,lowest,kary(3),mxbits)
730 kary(3) = kary(3) + mxbits
731 CALL sbyte(kbufr,nbinc,kary(3),6)
732 kary(3) = kary(3) + 6
733C GET DIFFERENCE VALUES
734 IF (msgflg) THEN
735 DO 4144 m = 1, isect3(1)
736 IF (kdata(m,kary(2)).EQ.misg) THEN
737 kt(m) = ibits(nbinc)
738 ELSE
739 kt(m) = kdata(m,kary(2)) - lowest
740 END IF
741 4144 CONTINUE
742 ELSE
743 DO 4146 m = 1, isect3(1)
744 kt(m) = kdata(m,kary(2)) - lowest
745 4146 CONTINUE
746 END IF
747C ENTER DATA VALUES
748 CALL sbytes(kbufr,kt,kary(3),nbinc,
749 * 0,isect3(1))
750 kary(3) = kary(3) + isect3(1) * nbinc
751 END IF
752 kary(18) = kary(18) + 1
753 END IF
754C ---------------------------------------------------
755C STANDARD DATA
756C ---------------------------------------------------
757 kary(2) = kary(11) + kary(18)
758 mxbits = kary(7) + kary(26)
759 dupflg = .true.
760 DO 4030 j = 2, isect3(7)
761 IF (kdata(j,kary(2)).NE.kdata(1,kary(2))) THEN
762 dupflg = .false.
763 GO TO 4031
764 END IF
765 4030 CONTINUE
766 4031 CONTINUE
767 IF (dupflg) THEN
768C ALL VALUES ARE EQUAL
769 kbz = kary(3) + kary(7) + 6
770 IF (kbz.GT.kend4) THEN
771 GO TO 5500
772 END IF
773 nbinc = 0
774C ENTER COMMON VALUE
775 IF (kdata(1,kary(2)).EQ.misg) THEN
776 CALL sbyte(kbufr,ibits(mxbits),
777 * kary(3),mxbits)
778 ELSE
779 CALL sbyte(kbufr,kdata(1,kary(2)),
780 * kary(3),mxbits)
781 END IF
782 kary(3) = kary(3) + kary(7)
783C ENTER NBINC
784 CALL sbyte (kbufr,nbinc,kary(3),6)
785 kary(3) = kary(3) + 6
786 ELSE
787C MIX OF MISSING AND VALUES
788C GET LARGEST DIFFERENCE VALUE
789 msgflg = .false.
790 DO 4032 j = 1, isect3(7)
791 IF (kdata(j,kary(2)).EQ.misg) THEN
792 msgflg = .true.
793 GO TO 4033
794 END IF
795 4032 CONTINUE
796 4033 CONTINUE
797 DO 4034 j = 1, isect3(7)
798 IF (kdata(j,kary(2)).NE.misg) THEN
799 lowest = kdata(j,kary(2))
800 maxval = kdata(j,kary(2))
801C PRINT *,' '
802C PRINT *,'START VALUES',LOWEST,MAXVAL,
803C * 'J=',J,' KARY(2)=',KARY(2)
804 GO TO 4035
805 END IF
806 4034 CONTINUE
807 4035 CONTINUE
808 DO 4036 j = 1, isect3(1)
809 IF (kdata(j,kary(2)).NE.misg) THEN
810 IF (kdata(j,kary(2)).LT.lowest) THEN
811 lowest = kdata(j,kary(2))
812C PRINT *,'NEW LOWEST=',LOWEST,J
813 ELSE IF (kdata(j,kary(2)).GT.maxval) THEN
814 maxval = kdata(j,kary(2))
815C PRINT *,'NEW MAXVAL=',MAXVAL,J
816 END IF
817 END IF
818 4036 CONTINUE
819 mxdiff = maxval - lowest
820C FIND NBINC
821 DO 4042 lj = 1, mxbits
822 nbinc = lj
823 IF (mxdiff.LT.ibits(lj)) GO TO 4043
824 IF (nbinc.EQ.mxbits) GO TO 4043
825 4042 CONTINUE
826 4043 CONTINUE
827 kbz = kary(3) + mxbits + 38 + isect3(1) * nbinc
828 IF (kbz.GT.kend4) THEN
829 GO TO 5500
830 END IF
831C PRINT 4444,KARY(11),KDESC(1,KARY(11)),LOWEST,
832C * MAXVAL,MXDIFF,KARY(7),NBINC,ISECT3(1),ISECT3(7)
833C4444 FORMAT(9(1X,I8))
834C ENTER LOWEST
835C ADJUST WITH REFERENCE VALUE
836 IF (krfvsw(l).EQ.0) THEN
837 jrv = krfval(l)
838 ELSE
839 jrv = newrfv(l)
840 END IF
841 lval = lowest - jrv
842 CALL sbyte(kbufr,lval,kary(3),mxbits)
843 kary(3) = kary(3) + mxbits
844 IF (nbinc.GT.mxbits) THEN
845 ierrtn = 3
846 RETURN
847 END IF
848 CALL sbyte(kbufr,nbinc,kary(3),6)
849 kary(3) = kary(3) + 6
850C GET DIFFERENCE VALUES
851 IF (msgflg) THEN
852 DO 4044 m = 1, isect3(1)
853 IF (kdata(m,kary(2)).EQ.misg) THEN
854 kt(m) = ibits(nbinc)
855 ELSE
856 kt(m) = kdata(m,kary(2)) - lowest
857 END IF
858 4044 CONTINUE
859 ELSE
860 DO 4046 m = 1, isect3(1)
861 kt(m) = kdata(m,kary(2)) - lowest
862 4046 CONTINUE
863 END IF
864C ENTER DATA VALUES
865 CALL sbytes(kbufr,kt,kary(3),nbinc,
866 * 0,isect3(1))
867 kary(3) = kary(3) + isect3(1) * nbinc
868 END IF
869 GO TO 5000
870 END IF
871C -------------------------------------------------------------
872 5000 CONTINUE
873 kary(11) = kary(11) + 1
874 GO TO 3000
875 ENDIF
876 5200 CONTINUE
877 END IF
878 isect3(6) = 0
879 GO TO 6000
880 5500 CONTINUE
881C THE SEGMENT OF CODE BETWEEN STATEMENTS
882C 5500-6000 ARE ACTIVATED IF AND WHEN THE
883C MAXIMUM MESSAGE SIZE HAS BEEN EXCEEDED
884C
885C ARE WE REDUCING IF OVERSIZED ???
886 IF (isect3(4).NE.0) THEN
887C INCREMENT REDUCTION COUNT
888 isect3(6) = isect3(6) + isect3(5)
889C REDUCE NUMBER TO INCLUDE
890 isect3(7) = isect3(1) - isect3(5)
891 isect3(1) = isect3(7)
892 print *,'REDUCED BY ',isect3(5),' ON THIS PASS'
893 GO TO 5
894 ELSE
895 ierrtn = 1
896 RETURN
897 END IF
898 6000 CONTINUE
899C ---------------------------------------------------------------
900C FILL IN SECTION 4 OCTET COUNT
901 nbufr = mod((kary(3) - kary(5)),16)
902C MAY BE NECESSARY TO ADJUST COUNT
903 IF (nbufr.NE.0) THEN
904 kary(3) = kary(3) + 16 - nbufr
905 END IF
906 kary(24) = (kary(3) - kary(5)) / 8
907 CALL sbyte (kbufr,kary(24),kary(5),24)
908C PRINT *,'SECTION 4'
909C =====================================
910C ENDING KEY '7777' - SECTION 5
911C =====================================
912 kary(25) = 4
913 nbufr = 926365495
914 CALL sbyte (kbufr,nbufr,kary(3),32)
915 kary(3) = kary(3) + 32
916C CONSTRUCT TOTAL BYTE COUNT FOR SECTION 0
917 itotal = kary(3) / 8
918 CALL sbyte (kbufr,itotal,32,24)
919 kary(30) = itotal
920C WRITE (6,8601) ITOTAL
921 8601 FORMAT (1x,22hthis message CONTAINS ,i10,6h bytes)
922C =======================================
923C KBUFR CONTAINS A COMPLETED MESSAGE
924 IF (isect3(4).NE.0.AND.isect3(5).NE.0) THEN
925C ADJUST KDATA ARRAY
926 nr = mxrpts - isect3(1)
927 isect3(7) = isect3(7) + 1
928 DO 7500 i = 1, nr
929 DO 7000 j = 1, nrdesc
930 kdata(i,j) = kdata(isect3(7),j)
931 7000 CONTINUE
932 isect3(7) = isect3(7) + 1
933 7500 CONTINUE
934 kary(14) = nr
935 ELSE
936 isect3(7) = isect3(1)
937 END IF
938C =======================================
939 ierrtn = 0
940 9000 CONTINUE
941 RETURN
942 END
943C> @brief Perform replication of descriptors
944C> @author Bill Cavanaugh @date 1993-12-03
945
946C> Have encountered a replication descriptor. It may include
947C> delayed replication or not. That decision should have been
948C> made prior to calling this routine.
949C>
950C> Program history log:
951C> - Bill Cavanaugh 1993-12-03
952C> - J. Hoppa 1994-03-25 Added line to initialize nxtptr to correct
953C> an error in the standard replication.
954C> - J. Hoppa 1994-03-28 Corrected an error in the standard replication
955C> that was adding extra zeros to the bufr message after the replicated data.
956C> - J. Hoppa 1994-03-31 Added the subset number to the parameter list.
957C> corrected the equation for the number of replications with delayed replication.
958C> (istart and k don't exist)
959C> - J. Hoppa 1994-04-19 Switched the variables next and nxtprt
960C> - J. Hoppa 1994-04-20 Added the kdata parameter counter to the parameter
961C> list. In the assignment of nreps when have delayed replication, changed index
962C> in kdata from n to k.
963C> - J. Hoppa 1994-04-29 Removed n and k from the input list changed n to
964C> kary(11) and k to kary(2)
965C>
966C> @param[in] ISTEP
967C> @param[in] KCLASS
968C> @param[in] KSEG
969C> @param[in] IDATA
970C> @param[in] RDATA
971C> @param[in] KDATA
972C> @param[in] NSUB Current subset
973C> @param[inout] KDESC (modified [out]) List of descriptors
974C> @param[inout] NRDESC Number of (new [out]) descriptors in kdesc
975C> @param[out] IERRTN Error return value
976C> @param KARY
977C>
978C> @author Bill Cavanaugh @date 1993-12-03
979 SUBROUTINE fi8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
980 * KDATA,NSUB,KDESC,NRDESC,IERRTN)
981
982C
983 REAL RDATA(*)
984C
985 INTEGER IDATA(*),NREPS,KARY(*)
986 INTEGER KCLASS,KSEG
987 INTEGER KDESC(3,*),NRDESC,KDATA(500,*)
988 INTEGER IERRTN
989 INTEGER ITAIL(1600)
990 INTEGER IHOLD(1600),ISTEP
991C
992 SAVE
993C
994C TEST KFUNC FOR DESCRIPTOR TYPE
995C DO REPLICATION
996C ****************************************************************
997 ierrtn = 0
998C REPLICATION DESCRIPTOR
999C STANDARD REPLICATION WILL SIMPLY
1000C BE PROCESSED FROM ITS DESCRIPTOR
1001C PARTS
1002C
1003C DELAYED REPLICATION DESCRIPTOR
1004C MUST BE FOLLOWED BY ONE OF THE
1005C DESCRIPTORS FOR A DELAYED
1006C REPLICATION FACTOR
1007C 0 31 001 (7937 DECIMAL)
1008C 0 31 002 (7938 DECIMAL)
1009C 0 31 011 (7947 DECIMAL)
1010C 0 31 012 (7948 DECIMAL)
1011 IF (kseg.NE.0) THEN
1012C HAVE NUMBER OF REPLICATIONS AS KSEG
1013 nreps = kseg
1014 iput = kary(11)
1015 next = iput + 1
1016 nxtptr = iput + 1 + kclass
1017 ELSE IF (kseg.EQ.0) THEN
1018 IF (kdesc(1,kary(11)+1).EQ.7937.OR.
1019 * kdesc(1,kary(11)+1).EQ.7938.OR.
1020 * kdesc(1,kary(11)+1).EQ.7947.OR.
1021 * kdesc(1,kary(11)+1).EQ.7948) THEN
1022C PRINT *,'HAVE DELAYED REPLICATION'
1023 kary(4) = 1
1024C MOVE REPLICATION DEFINITION
1025 kdesc(1,kary(11)) = kdesc(1,kary(11)+1)
1026C MUST DETERMINE HOW MANY REPLICATIONS
1027 IF (istep.EQ.1) THEN
1028 nreps = idata(kary(11))
1029 ELSE IF (istep.EQ.2) THEN
1030 nreps = rdata(kary(11))
1031 ELSE
1032 nreps = kdata(nsub,kary(2))
1033 END IF
1034 iput = kary(11) + 1
1035 nxtptr = iput + kclass + 1
1036 next = iput + 1
1037C POINT TO REPLICATION DESCRIPTOR
1038 END IF
1039 ELSE
1040 ierrtn = 10
1041 RETURN
1042 END IF
1043C EXTRACT DESCRIPTORS TO BE REPLICATED
1044C IF NREPS = 0, THIS LIST OF DESCRIPTORS IS NOT TO
1045C BE USED IN DEFINING THE DATA,
1046C OTHERWISE
1047C IT WILL BE USED TO DEFINE THE DATA
1048 IF (nreps.NE.0) THEN
1049 DO 1000 ij = 1, kclass
1050 ihold(ij) = kdesc(1,next)
1051 next = next + 1
1052 1000 CONTINUE
1053C SKIP THE NUMBER OF DESCRIPTORS DEFINED BY KCLASS
1054 END IF
1055C SAVE OFF TAIL OF DESC STREAM
1056C START AT FIRST POSITION OF TAIL
1057 igot = 0
1058 DO 1100 ij = nxtptr, nrdesc
1059 igot = igot + 1
1060 itail(igot) = kdesc(1,ij)
1061 1100 CONTINUE
1062C INSERT ALL REPLICATED DESC'S
1063 IF (nreps.NE.0) THEN
1064 DO 1300 kr = 1, nreps
1065 DO 1200 kd = 1, kclass
1066 kdesc(1,iput) = ihold(kd)
1067 iput = iput + 1
1068 1200 CONTINUE
1069 1300 CONTINUE
1070 END IF
1071C RESTORE TAIL
1072 DO 1400 itl = 1, igot
1073 kdesc(1,iput) = itail(itl)
1074 iput = iput + 1
1075 1400 CONTINUE
1076C
1077C RESET NUMBER OF DESCRIPTORS IN KDESC
1078 nrdesc = iput - 1
1079C ****************************************************************
1080 RETURN
1081 END
1082C> @brief Process an operator descriptor.
1083C> @author Bill Cavanaugh @date 193-12-03
1084
1085C> Have encountered an operator descriptor.
1086C>
1087C> Program history log:
1088C> - Bill Cavanaugh 1993-12-03
1089C> - J. Hoppa 1994-04-15 Added kbufr to input parameter list.
1090C> added block of data to correctly use sbyte when writing a 205yyy descriptor to the
1091C> bufr message. The previous way didn't work because kdata was getting incremeted
1092C> by the ksub value, not the param value.
1093C> - J. Hoppa 1994-04-29 Changed k to kary(2) removed a line that became obsolete with
1094C> above change
1095C> - J. Hoppa 1994-05-18 Added a kary(2) increment
1096C>
1097C> @param[in] KCLASS
1098C> @param[in] KSEG
1099C> @param[inout] KDESC
1100C> @param[inout] NRDESC
1101C> @param[in] I
1102C> @param[in] ISTEP
1103C> @param[inout] KARY
1104C> @param[out] IERRTN Error return value
1105C> @param KBUFR
1106C> @param KDATA
1107C> @param ISECT3
1108C> @param KRFVSW
1109C> @param NEWRFV
1110C> @param LDESC
1111C> @param INDEXB
1112C>
1113C> @author Bill Cavanaugh @date 193-12-03
1114 SUBROUTINE fi8502(*,KBUFR,KCLASS,KSEG,KDESC,NRDESC,I,ISTEP,
1115 * KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB)
1116
1117C
1118 INTEGER KCLASS,KSEG,ZEROES(255)
1119 INTEGER KRFVSW(*),NEWRFV(*),LDESC(*)
1120 INTEGER I,KDESC(3,*),KDATA(500,*),ISECT3(*)
1121 INTEGER NRDESC
1122 INTEGER KARY(*)
1123 INTEGER IERRTN
1124 INTEGER NLEFT
1125C
1126 SAVE
1127C
1128 DATA zeroes/255*0/
1129C
1130C ****************************************************************
1131 ierrtn = 0
1132C OPERATOR DESCRIPTOR
1133 IF (kclass.EQ.1) THEN
1134C BITS ADDED TO DESCRIPTOR WIDTH
1135 IF (istep.EQ.3) THEN
1136 IF (kseg.NE.0) THEN
1137 kary(26) = kseg - 128
1138 ELSE
1139 kary(26) = 0
1140 END IF
1141 END IF
1142 ELSE IF (kclass.EQ.2) THEN
1143C NEW SCALE VALUE
1144 IF (istep.EQ.3) THEN
1145 IF (kseg.EQ.0) THEN
1146 kary(9) = 0
1147 ELSE
1148 kary(9) = kseg - 128
1149 END IF
1150 END IF
1151 ELSE IF (kclass.EQ.3) THEN
1152C CHANGE REFERENCE VALUE
1153C MUST ACCEPT INTO OUTPUT THE
1154C REFERENCE VALUE CHANGE AND ACTIVATE
1155C THE CHANGE WHILE PROCESSING
1156 IF (istep.EQ.3) THEN
1157C HAVE OPERATOR DESCRIPTOR FOR REFERENCE VALUES
1158 IF (kseg.EQ.0) THEN
1159 DO 100 iq = 1, isect3(8)
1160C RESET ALL NEW REFERENCE VALUES
1161 krfvsw(iq) = 0
1162 100 CONTINUE
1163 END IF
1164 200 CONTINUE
1165C GET NEXT DESCRIPTOR
1166 kary(11) = kary(11) + 1
1167 IF (kdesc(1,kary(11)).GT.16383) THEN
1168C NOT AN ELEMENT DESCRIPTOR
1169 nfunc = kdesc(1,kary(11)) / 16384
1170 IF (nfunc.EQ.1.OR.nfunc.EQ.3) THEN
1171 ierrtn = 20
1172 print *,'INCORRECT ENTRY OF REPLICATION OR ',
1173 * 'SEQUENCE DESCRIPTOR IN LIST OF ',
1174 * 'REFERENCE VALUE CHANGES'
1175 RETURN
1176 END IF
1177 nclass = (kdesc(1,kary(11)) - nfunc*16384) / 256
1178 IF (nclass.EQ.3) THEN
1179 nseg = mod(kdesc(1,kary(11)),256)
1180 IF (nseg.EQ.255) THEN
1181 RETURN
1182 END IF
1183 END IF
1184 ierrtn = 21
1185 print *,'INCORRECT OPERATOR DESCRIPTOR ENTRY ',
1186 * 'IN LIST OF REFERENCE VALUE CHANGES'
1187 RETURN
1188 END IF
1189C ELEMENT DESCRIPTOR W/NEW REFERENCE VALUE
1190C FIND MATCH FOR CURRENT DESCRIPTOR
1191 iq = indexb(kdesc(1,kary(11)))
1192 IF (iq.LT.1) THEN
1193 ierrtn = 22
1194 print *,'ATTEMPTING TO ENTER NEW REFERENCE VALUE ',
1195 * 'INTO TABLE B, BUT DESCRIPTOR DOES NOT EXIST IN ',
1196 * 'CURRENT MODIFIED TABLE B'
1197 RETURN
1198 END IF
1199 END IF
1200 ELSE IF (kclass.EQ.4) THEN
1201C SET/RESET ASSOCIATED FIELD WIDTH
1202 IF (istep.EQ.3) THEN
1203 kary(27) = kseg
1204 END IF
1205 ELSE IF (kclass.EQ.5) THEN
1206C SET TO PROCESS TEXT/ASCII DATA
1207C SET TO TEXT
1208C PROCESS TEXT
1209
1210 kary(2) = kary(11) + kary(18)
1211 IF (istep.EQ.3) THEN
1212C KSEG TELLS HOW MANY BYTES EACH ITERATION
1213 IF (mod(kseg,4).NE.0) THEN
1214 iter = kseg / 4 + 1
1215 ELSE
1216 iter = kseg / 4
1217 END IF
1218C POINT AT CORRECT KDATA WORD
1219 IF (isect3(3).NE.0) THEN
1220C COMPRESSED
1221C ---------------------------------------------------
1222 CALL sbytes(kbufr,zeroes,kary(3),32,0,iter)
1223 kary(3) = kary(3) + kseg * 8
1224C
1225 CALL sbyte (kbufr,kseg*8,kary(3),6)
1226 kary(3) = kary(3) + 6
1227C TEXT ENTRY BY SUBSET
1228 DO 2000 m = 1, isect3(1)
1229 jay = kary(3)
1230C NUMBER OF SUBSETS
1231 DO 1950 kl = 1, iter
1232C NUMBER OF WORDS
1233 kk = kary(2) + kl - 1
1234 IF (isect3(10).EQ.1) THEN
1235 CALL w3ai38(kdata(m,kk),4)
1236 END IF
1237 CALL sbyte (kbufr,kdata(m,kk),jay,32)
1238 jay = jay + 32
1239 1950 CONTINUE
1240 kary(3) = kary(3) + kseg * 8
1241 2000 CONTINUE
1242C ---------------------------------------------------
1243 ELSE
1244C NOT COMPRESSED
1245
1246C CALL SBYTE FOR EACH KDATA VALUE (4 CHARACTERS PER VALUE).
1247C AN ADDITIONAL CALL IS DONE IF HAVE A VALUE WITH LESS THAN
1248C 4 CHARACTERS.
1249 nbit = 32
1250 nleft = mod(kseg,4)
1251 DO 3000 j=kary(2),iter+kary(2)-1
1252 IF((j.EQ.(iter+kary(2)-1)).AND.(nleft.NE.0))THEN
1253 nbit = 8 * nleft
1254 ENDIF
1255 IF (isect3(10).NE.0) THEN
1256 CALL w3ai38 (kdata(i,j),4)
1257 END IF
1258 CALL sbyte(kbufr,kdata(i,j),kary(3),nbit)
1259 kary(3) = kary(3) + nbit
1260 3000 CONTINUE
1261
1262C ADJUST FOR EXTRA WORDS
1263 kary(18) = kary(18) + iter - 1
1264 END IF
1265 kary(2) = kary(2) + iter
1266 END IF
1267 ELSE IF (kclass.EQ.6) THEN
1268C SET TO SKIP PROCESSING OF NEXT DESCRIPTOR
1269C IF IT IS NOT IN BUFR TABLE B
1270C DURING THE ENCODING PROCESS, THIS HAS NO MEANING
1271C ELIMINATE IN PROCESSING
1272C MOVE DESCRIPTOR LIST UP ONE POSITION AND RESTART
1273C PROCESSING AT SAME LOCATION.
1274 km = i - 1
1275 DO 9000 kl = i+1, nrdesc
1276 km = km + 1
1277 kdesc(1,km) = kdesc(1,kl)
1278 9000 CONTINUE
1279 nrdesc = km
1280 RETURN 1
1281 END IF
1282C ****************************************************************
1283 RETURN
1284 END
1285C> @brief Expand sequence descriptor.
1286C> @author Bill Cavanaugh @date 1993-12-03
1287
1288C> Have encountered a sequence descriptor. must perform proper replacment of
1289C> descriptors in line.
1290C>
1291C> Program history log:
1292C> - Bill Cavanaugh 1993-12-03
1293C>
1294C> @param[inout] I Current position in descriptor list
1295C> @param[inout] KDESC List (modified [out]) of descriptors
1296C> @param[inout] NRDESC Number (new [out]) of descriptors in kdesc
1297C> @param[in] IUNITD
1298C> @param[in] KSEQ
1299C> @param[in] KNUM
1300C> @param[in] KLIST
1301C> @param[out] IERRTN Error return value
1302C> @param ISECT3
1303C>
1304C> @author Bill Cavanaugh @date 1993-12-03
1305 SUBROUTINE fi8503(I,KDESC,NRDESC,
1306 * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
1307
1308C
1309 INTEGER I
1310 INTEGER KDESC(3,*)
1311 INTEGER NRDESC
1312 INTEGER ISECT3(*)
1313 INTEGER IUNITD
1314 INTEGER KSEQ(*)
1315 INTEGER KNUM(*)
1316 INTEGER KLIST(300,*)
1317 INTEGER IERRTN
1318 INTEGER ITAIL(1600)
1319C INTEGER IHOLD(200)
1320C
1321 SAVE
1322C
1323C ****************************************************************
1324 ierrtn = 0
1325C READ IN TABLE D IF NEEDED
1326 IF (isect3(9).EQ.0) THEN
1327 CALL fi8513 (iunitd,isect3,kseq,
1328 * knum,klist,ierrtn)
1329 IF (ierrtn.NE.0) THEN
1330C PRINT *,'EXIT FI8503A'
1331 RETURN
1332 END IF
1333 END IF
1334C HAVE TABLE D
1335C
1336C FIND MATCHING SEQUENCE DESCRIPTOR
1337 DO 100 l = 1, isect3(9)
1338 IF (kdesc(1,i).EQ.kseq(l)) THEN
1339C JEN - DELETE NEXT PRINT LINE
1340C PRINT *,'FOUND ',KDESC(1,I)
1341C HAVE A MATCH
1342 GO TO 200
1343 END IF
1344 100 CONTINUE
1345 ierrtn = 12
1346 RETURN
1347 200 CONTINUE
1348C REPLACE SEQUENCE DESCRIPTOR WITH IN LINE SEQUENCE
1349 iput = i
1350C SAVE TAIL
1351 istart = i + 1
1352 kk = 0
1353 DO 400 ij = istart, nrdesc
1354 kk = kk + 1
1355 itail(kk) = kdesc(1,ij)
1356 400 CONTINUE
1357C INSERT SEQUENCE OF DESCRIPTORS AT
1358C CURRENT LOCATION
1359 kl = 0
1360 DO 600 kq = 1, knum(l)
1361 kdesc(1,iput) = klist(l,kq)
1362 iput = iput + 1
1363 600 CONTINUE
1364
1365C RESTORE TAIL
1366 DO 800 kl = 1, kk
1367 kdesc(1,iput) = itail(kl)
1368 iput = iput + 1
1369 800 CONTINUE
1370C RESET NUMBER OF DESCRIPTORS IN KDESC
1371 nrdesc = iput - 1
1372C JEN - DELETE NEXT PRINT LINE
1373C PRINT *,' NRDESC IS ',NRDESC
1374
1375C RESET CURRENT POSITION & RETURN
1376 RETURN
1377 END
1378C> @brief Convert descriptors fxy to decimal
1379C> @author Bill Cavanaugh @date 1993-12-03
1380
1381C> Construct decimal descriptor values from f x and y segments
1382C>
1383C> Program history log:
1384C> - Bill Cavanaugh 1993-12-03
1385C>
1386C> @param[in] MIF input flag
1387C> @param[inout] MDESC list of descriptors in f x y (decimal [out]) form
1388C> @param[in] NR number of descriptors in mdesc
1389C> @param[out] IERRTN error return value
1390C>
1391C> @author Bill Cavanaugh @date 1993-12-03
1392 SUBROUTINE fi8505(MIF,MDESC,NR,IERRTN)
1393
1394C
1395 INTEGER MDESC(3,*), NR
1396C
1397 SAVE
1398C
1399 IF (nr.EQ.0) THEN
1400 ierrtn = 14
1401 RETURN
1402 END IF
1403C
1404 DO 100 i = 1, nr
1405 mdesc(1,i) = mdesc(1,i) * 16384 + mdesc(2,i) * 256
1406 * + mdesc(3,i)
1407C JEN - DELETE NEXT PRINT LINE
1408C PRINT *,MDESC(2,I),MDESC(3,I),' BECOMES ',MDESC(1,I)
1409 100 CONTINUE
1410 mif = 1
1411 RETURN
1412 END
1413C> @brief Process data in non-compressed format
1414C> @author Bill Cavanaugh @date 1993-12-03
1415
1416C> Process data into non-compressed format for inclusion into
1417C> section 4 of the bufr message
1418C>
1419C> Program history log:
1420C> - Bill Cavanaugh 1993-12-03
1421C> - J. Hoppa 1994-03-24 Changed the inner loop from a do loop to a
1422C> goto loop so nrdesc isn't a set value.
1423C> corrected a value in the call to fi8503().
1424C> - J. Hoppa 1994-03-31 Corrected an error in sending the subset
1425C> number rather than the descriptor number
1426C> to subroutine fi8501(). Added the subset number to the fi8501() parameter list.
1427C> - J. Hoppa 1994-04015 Added line to keep the parameter pointer
1428C> kary(2) up to date. this variable is used
1429C> in subroutine fi8502().
1430C> added kbufr to the parameter list in the call
1431C> to subroutine fi8502().
1432C> corrected an infinite loop when have an
1433C> operator descriptor that was caused by
1434C> a correction made 94-03-24
1435C> - J. Hoppa 1994-04-20 Added k to call to subroutine w3fi01
1436C> - J. Hoppa 1994-04-29 Changed n to kary(11) and k to kary(2)
1437C> removed k and n from the call to fi8501()
1438C> - J. Hoppa 1994-05-03 Added an increment to kary(11) to prevent
1439C> and infinite loop when have a missing value
1440C> - J. Hoppa 1994-05-18 Changed so increments kary(2) after each
1441C> call to sbyte and deleted
1442C> kary(2) = kary(11) + kary(18)
1443C>
1444C> @param[in] ISTEP
1445C> @param[in] ISECT3
1446C> @param[in] KARY
1447C> @param[in] JDESC
1448C> @param[in] NEWNR
1449C> @param[in] KDESC
1450C> @param[in] NRDESC
1451C> @param[in] LDESC
1452C> @param[in] ANAME
1453C> @param[in] AUNITS
1454C> @param[in] KSCALE
1455C> @param[in] KRFVAL
1456C> @param[in] KWIDTH
1457C> @param[in] KRFVSW
1458C> @param[in] NEWRFV
1459C> @param[in] KSEQ
1460C> @param[in] KNUM
1461C> @param[in] KLIST
1462C> @param[out] KDATA
1463C> @param[out] KBUFR
1464C> @param[out] IERRTN
1465C> @param IBFSIZ
1466C> @param INDEXB
1467C>
1468C> @author Bill Cavanaugh @date 1993-12-03
1469 SUBROUTINE fi8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC,
1470 * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV,
1471 * KSEQ,KNUM,KLIST,IBFSIZ,
1472 * KDATA,KBUFR,IERRTN,INDEXB)
1473
1474C
1475C -------------------------------------------------------------
1476 INTEGER ISTEP,INDEXB(*)
1477 INTEGER KBUFR(*)
1478 INTEGER ISECT3(*)
1479 INTEGER KARY(*)
1480 INTEGER NRDESC,NEWNR,KDESC(3,*),JDESC(3,*)
1481 INTEGER KDATA(500,*)
1482 INTEGER KRFVSW(*),KSCALE(*),KRFVAL(*),KWIDTH(*),NEWRFV(*)
1483 INTEGER IERRTN
1484 INTEGER LDESC(*)
1485 INTEGER IBITS(32)
1486 INTEGER MISG
1487 INTEGER KSEQ(*),KNUM(*),KLIST(300,*)
1488 CHARACTER*40 ANAME(*)
1489 CHARACTER*25 AUNITS(*)
1490 CHARACTER*9 CCITT
1491 LOGICAL TEXT
1492C
1493 SAVE
1494C -------------------------------------------------------------
1495 DATA ibits / 1, 3, 7, 15,
1496 * 31, 63, 127, 255,
1497 * 511, 1023, 2047, 4095,
1498 * 8191, 16383, 32767, 65535,
1499 * z'0001FFFF',z'0003FFFF',z'0007FFFF',z'000FFFFF',
1500 * z'001FFFFF',z'003FFFFF',z'007FFFFF',z'00FFFFFF',
1501 * z'01FFFFFF',z'03FFFFFF',z'07FFFFFF',z'0FFFFFFF',
1502 * z'1FFFFFFF',z'3FFFFFFF',z'7FFFFFFF',z'FFFFFFFF'/
1503 DATA ccitt /'CCITT IA5'/
1504 DATA misg /99999/
1505C -------------------------------------------------------------
1506 kend = ibfsiz * 8 - 32
1507C **********************************************
1508C * *
1509C * PROCESS AS NON-COMPRESSED MESSAGE *
1510C * *
1511C * I POINTS TO SUBSET *
1512C * N POINTS TO DESCRIPTOR *
1513C * K ADJUSTS N TO CORRECT DATA ENTRY *
1514C * *
1515C **********************************************
1516 DO 4500 i = 1, isect3(1)
1517C OUTER LOOP FOR EACH SUBSET
1518C DO UNTIL ALL DESCRIPTORS HAVE
1519C BEEN PROCESSED
1520C SET ADDED BIT FOR WIDTH TO 0
1521 kary(26) = 0
1522C SET ASSOCIATED FIELD WIDTH TO 0
1523 kary(27) = 0
1524 kary(18) = 0
1525C IF MESSAGE CONTAINS DELAYED REPLICATION
1526C WE NEED TO EXPAND THE ORIGINAL DESCRIPTOR LIST
1527C TO MATCH THE INPUT DATA.
1528C START WITH JDESC
1529 IF (kary(4).NE.0) THEN
1530 DO 100 m = 1, newnr
1531 kdesc(1,m) = jdesc(1,m)
1532 100 CONTINUE
1533 nrdesc = newnr
1534 END IF
1535 kary(11) = 1
1536 kary(2) = 1
1537 4300 CONTINUE
1538 IF(kary(11).GT.nrdesc) GOTO 4305
1539C INNER LOOP FOR PARAMETER
1540 4200 CONTINUE
1541C KARY(2) = KARY(11) + KARY(18)
1542C PRINT *,'LOOKING AT DESCRIPTOR',KARY(11),
1543C * KDESC(1,KARY(11)),
1544C * KARY(2),KDATA(I,KARY(2))
1545C
1546C PROCESS ONE DESCRIPTOR AT A TIME
1547C
1548C ISOLATE TABLE
1549C
1550 kfunc = kdesc(1,kary(11)) / 16384
1551C ISOLATE CLASS
1552 kclass = mod(kdesc(1,kary(11)),16384) / 256
1553 kseg = mod(kdesc(1,kary(11)),256)
1554 IF (kfunc.EQ.1) THEN
1555C REPLICATION DESCRIPTOR
1556 CALL fi8501(kary,istep,kclass,kseg,idata,rdata,
1557 * kdata,i,kdesc,nrdesc,ierrtn)
1558 IF (ierrtn.NE.0) THEN
1559 RETURN
1560 END IF
1561 GO TO 4200
1562 ELSE IF (kfunc.EQ.2) THEN
1563C OPERATOR DESCRIPTOR
1564 CALL fi8502(*4200,kbufr,kclass,kseg,
1565 * kdesc,nrdesc,i,istep,
1566 * kary,kdata,isect3,krfvsw,newrfv,ldesc,ierrtn,indexb)
1567 IF (ierrtn.NE.0) THEN
1568 RETURN
1569 END IF
1570 kary(11) = kary(11) + 1
1571 GO TO 4300
1572 ELSE IF (kfunc.EQ.3) THEN
1573C SEQUENCE DESCRIPTOR
1574 CALL fi8503(kary(11),kdesc,nrdesc,
1575 * isect3,iunitd,kseq,knum,klist,ierrtn)
1576 IF (ierrtn.NE.0) THEN
1577 RETURN
1578 END IF
1579 GO TO 4200
1580 END IF
1581C FALL THRU WITH ELEMENT DESCRIPTOR
1582C FIND MATCHING TABLE B ENTRY
1583 lk = indexb(kdesc(1,kary(11)))
1584 IF (lk.LT.1) THEN
1585C FALL THRU WITH NO MATCHING B ENTRY
1586 print *,'FI8506 3800',kary(11),kdesc(1,kary(11)),
1587 * nrdesc,lk,ldesc(lk)
1588 ierrtn = 2
1589 RETURN
1590 END IF
1591C
1592 IF (aunits(lk).EQ.ccitt) THEN
1593 text = .true.
1594 ELSE
1595 text = .false.
1596 END IF
1597C
1598 IF (text) THEN
1599 jwide = kwidth(lk)
1600 3775 CONTINUE
1601 IF (jwide.GT.32) THEN
1602 IF(isect3(10).NE.0) THEN
1603 CALL w3ai38 (kdata(i,kary(2)),4)
1604 END IF
1605 IF ((kary(3)+32).GT.kend) THEN
1606 ierrtn = 1
1607 RETURN
1608 END IF
1609 CALL sbyte (kbufr,kdata(i,kary(2)),kary(3),32)
1610 kary(3) = kary(3) + 32
1611C ADD A WORD HERE ONLY
1612 kary(18) = kary(18) + 1
1613C KARY(2) = KARY(11) + KARY(18)
1614 kary(2) = kary(2) + 1
1615 jwide = jwide - 32
1616 GO TO 3775
1617 ELSE IF (jwide.EQ.32) THEN
1618 IF(isect3(10).NE.0) THEN
1619 CALL w3ai38 (kdata(i,kary(2)),4)
1620 END IF
1621 IF ((kary(3)+32).GT.kend) THEN
1622 ierrtn = 1
1623 RETURN
1624 END IF
1625 CALL sbyte (kbufr,kdata(i,kary(2)),kary(3),32)
1626 kary(3) = kary(3) + 32
1627 kary(2) = kary(2) + 1
1628 jwide = jwide - 32
1629 ELSE IF (jwide.GT.0) THEN
1630 IF(isect3(10).NE.0) THEN
1631 CALL w3ai38 (kdata(i,kary(2)),4)
1632 END IF
1633 IF ((kary(3)+jwide).GT.kend) THEN
1634 ierrtn = 1
1635 RETURN
1636 END IF
1637 CALL sbyte (kbufr,kdata(i,kary(2)),kary(3),jwide)
1638 kary(3) = kary(3) + jwide
1639 kary(2) = kary(2) + 1
1640 END IF
1641 ELSE
1642C NOT TEXT
1643 IF (kary(27).NE.0.AND.kdesc(1,kary(11)).NE.7957) THEN
1644C ENTER ASSOCIATED FIELD
1645 IF ((kary(3)+kary(27)).GT.kend) THEN
1646 ierrtn = 1
1647 RETURN
1648 END IF
1649 CALL sbyte (kbufr,kdata(i,kary(2)),kary(3),
1650 * kary(27))
1651 kary(3) = kary(3) + kary(27)
1652 kary(18) = kary(18) + 1
1653C KARY(2) = KARY(11) + KARY(18)
1654 kary(2) = kary(2) + 1
1655 END IF
1656C
1657 jwide = kwidth(lk) + kary(26)
1658 IF (kdata(i,kary(2)).EQ.misg) THEN
1659C MISSING DATA, SET ALL BITS ON
1660 IF ((kary(3)+jwide).GT.kend) THEN
1661 ierrtn = 1
1662 RETURN
1663 END IF
1664 CALL sbyte (kbufr,ibits(jwide),kary(3),jwide)
1665 kary(3) = kary(3) + jwide
1666 kary(2) = kary(2) + 1
1667 kary(11) = kary(11) + 1
1668 GO TO 4300
1669 END IF
1670C CAN DATA BE CONTAINED IN SPECIFIED
1671C BIT WIDTH, IF NOT - ERROR
1672 IF (kdata(i,kary(2)).GT.ibits(jwide)) THEN
1673 ierrtn = 1
1674 RETURN
1675 END IF
1676C ADJUST WITH REFERENCE VALUE
1677 IF (krfvsw(lk).EQ.0) THEN
1678 jrv = krfval(lk)
1679 ELSE
1680 jrv = newrfv(lk)
1681 END IF
1682C
1683 kdata(i,kary(2)) = kdata(i,kary(2)) - jrv
1684C IF NEW VALUE IS NEGATIVE - ERROR
1685 IF (kdata(i,kary(2)).LT.0) THEN
1686 ierrtn = 11
1687 RETURN
1688 END IF
1689C PACK DATA INTO OUTPUT ARRAY
1690 IF ((kary(3)+jwide).GT.kend) THEN
1691 ierrtn = 1
1692 RETURN
1693 END IF
1694 CALL sbyte (kbufr,kdata(i,kary(2)),kary(3),jwide)
1695 kary(2) = kary(2) + 1
1696 kary(3) = kary(3) + jwide
1697 END IF
1698 kary(11) = kary(11) + 1
1699 GOTO 4300
1700 4305 CONTINUE
1701C RESET ALL REFERENCE VALUES TO ORIGINAL
1702 DO 4310 lx = 1, isect3(8)
1703 krfvsw(lx) = 0
1704 4310 CONTINUE
1705 4500 CONTINUE
1706 RETURN
1707 END
1708C> @brief Combine integer/text data
1709C> @author Bill Cavanaugh @date 1993-12-03
1710
1711C> Construct integer subset from real and text data
1712C>
1713C> Program history log:
1714C> - Bill Cavanaugh 1993-12-03
1715C> - J. Hoppa 1994-03-31 added ksub to fi8501() parameter list.
1716C> - J. Hoppa 1994-04-18 added dummy variable idum to fi8502() parameter list.
1717C> - J. Hoppa 1994-04-20 added dummy variable ll to fi8501() parameter list.
1718C> - J. Hoppa 1994-04-29 changed i to kary(11) added a kary(2) assignment so have something
1719C> to pass to subroutines ** test this ** removed i and ll from call to fi8501()
1720C> - J. Hoppa 1994-05-13 added code to calculate kwords when kfunc=2
1721C> - J. Hoppa 1994-05-18 deleted kary(2) assignment
1722C>
1723C> @param[in] ISTEP
1724C> @param[in] IUNITB Unit number of device containing table b
1725C> @param[in] IDATA Integer working array
1726C> @param[in] KDESC Expanded descriptor set
1727C> @param[in] NRDESC Number of descriptors in kdesc
1728C> @param[in] ATEXT Text data for ccitt ia5 and text operator fields
1729C> @param[in] KSUB Subset number
1730C> @param[in] KARY Working array
1731C> @param[in] ISECT3
1732C> @param[out] KDATA Array containing integer subsets
1733C> @param[out] LDESC List of table b descriptors (decimal)
1734C> @param[out] ANAME List of descriptor names
1735C> @param[out] AUNITS Units for each descriptor
1736C> @param[out] KSCALE Base 10 scale factor for each descriptor
1737C> @param[out] KRFVAL Reference value for each descriptor
1738C> @param[out] KRFVSW
1739C> @param[out] KWIDTH Standard bit width to contain each value for specific descriptor
1740C> @param[out] KASSOC
1741C> @param[out] IERRTN Error return flag
1742C> @param IUNITD
1743C> @param KSEQ
1744C> @param KNUM
1745C> @param KLIST
1746C> @param INDEXB
1747C>
1748C> @author Bill Cavanaugh @date 1993-12-03
1749 SUBROUTINE fi8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
1750 * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
1751 * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
1752
1753C TAKE EACH NON-TEXT ENTRY OF SECTION 2
1754C ACCEPT IT
1755C
1756C TAKE EACH TEXT ENTRY
1757C INSERT INTO INTEGER ARRAY,
1758C ADDING FULL WORDS AS NECESSARY
1759C MAKE SURE ANY LAST WORD HAS TEXT DATA
1760C RIGHT JUSTIFIED
1761C ---------------------------------------------------------------------
1762C PASS BACK CONVERTED ENTRY TO LOCATION
1763C SPECIFIED BY USER
1764C
1765C REFERENCE VALUE WILL BE APPLIED DURING
1766C ENCODING OF MESSAGE
1767C ---------------------------------------------------------------------
1768 INTEGER IUNITB,IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
1769 INTEGER KDESC(3,*),NRDESC,KASSOC(*)
1770 INTEGER IDATA(*),ISTEP
1771 INTEGER KDATA(500,*)
1772 INTEGER KARY(*),INDEXB(*)
1773 INTEGER KSUB,K
1774 INTEGER LDESC(*)
1775 INTEGER IBITS(32)
1776 INTEGER KSCALE(*)
1777 INTEGER KRFVAL(*)
1778 INTEGER KRFVSW(*)
1779 INTEGER KWIDTH(*)
1780 INTEGER MISG
1781 INTEGER MPTR,ISECT3(*)
1782 CHARACTER*1 ATEXT(*)
1783 CHARACTER*1 AHOLD1(256)
1784 INTEGER IHOLD4(64)
1785 CHARACTER*25 AUNITS(*)
1786 CHARACTER*25 CCITT
1787 CHARACTER*40 ANAME(*)
1788C
1789 SAVE
1790C
1791 equivalence(ahold1,ihold4)
1792C
1793C =====================================
1794 DATA ccitt /'CCITT IA5 '/
1795 DATA ibits / 1, 3, 7, 15,
1796 * 31, 63, 127, 255,
1797 * 511, 1023, 2047, 4095,
1798 * 8191, 16383, 32767, 65535,
1799 * z'0001FFFF',z'0003FFFF',z'0007FFFF',z'000FFFFF',
1800 * z'001FFFFF',z'003FFFFF',z'007FFFFF',z'00FFFFFF',
1801 * z'01FFFFFF',z'03FFFFFF',z'07FFFFFF',z'0FFFFFFF',
1802 * z'1FFFFFFF',z'3FFFFFFF',z'7FFFFFFF',z'FFFFFFFF'/
1803 DATA misg /99999/
1804C
1805 IF (isect3(8).EQ.0) THEN
1806 CALL fi8512(iunitb,isect3,kdesc,nrdesc,kary,ierrtn,
1807 * ldesc,aname,aunits,kscale,krfval,kwidth,krfvsw,
1808 * iunitd,kseq,knum,klist,indexb)
1809 IF (ierrtn.NE.0) THEN
1810 RETURN
1811 END IF
1812 END IF
1813C HAVE TABLE B AVAILABLE NOW
1814C
1815C LOOK AT EACH DATA ENTRY
1816C CONVERT NON TEXT
1817C MOVE TEXT
1818C
1819 kpos = 0
1820 mptr = 0
1821 kary(11) = 0
1822 1000 CONTINUE
1823 kary(11) = kary(11) + 1
1824 IF (kary(11).GT.nrdesc) GO TO 1500
1825C
1826C RE-ENTRY POINT FOR REPLICATION AND SEQUENCE DESCR'S
1827C
1828 500 CONTINUE
1829 kfunc = kdesc(1,kary(11)) / 16384
1830 kl = kdesc(1,kary(11)) - 16384 * kfunc
1831 kclass = kl / 256
1832 kseg = mod(kl,256)
1833C KARY(2) = KARY(11) + KARY(18)
1834 IF (kfunc.EQ.1) THEN
1835C REPLICATION DESCRIPTOR
1836 CALL fi8501(kary,istep,kclass,kseg,idata,rdata,
1837 * kdata,ksub,kdesc,nrdesc,ierrtn)
1838 IF (ierrtn.NE.0) THEN
1839 RETURN
1840 END IF
1841 GO TO 500
1842 ELSE IF (kfunc.EQ.2) THEN
1843 IF (kclass.EQ.5) THEN
1844C HANDLE TEXT OPERATORS
1845CC
1846 kavail = idata(kary(11))
1847C UNUSED POSITIONS IN LAST WORD
1848 krem = mod(kavail,4)
1849 IF (krem.NE.0) THEN
1850 kwords = kavail / 4 + 1
1851 ELSE
1852 kwords = kavail / 4
1853 END IF
1854CC
1855 jwide = kseg * 8
1856 GO TO 1200
1857 END IF
1858 ELSE IF (kfunc.EQ.3) THEN
1859C SEQUENCE DESCRIPTOR - ERROR
1860 CALL fi8503(kary(11),kdesc,nrdesc,
1861 * isect3,iunitd,kseq,knum,klist,ierrtn)
1862 IF (ierrtn.NE.0) THEN
1863 RETURN
1864 END IF
1865 GO TO 500
1866 ELSE
1867C
1868C FIND MATCHING DESCRIPTOR
1869C
1870 k = indexb(kdesc(1,kary(11)))
1871 IF (k.LT.1) THEN
1872 print *,'FI8508-NOT FOUND',kary(11),kdesc(1,kary(11)),
1873 * isect3(8),ldesc(k)
1874 ierrtn = 2
1875 RETURN
1876 END IF
1877C HAVE MATCHING DESCRIPTOR
1878 200 CONTINUE
1879 IF (aunits(k)(1:9).NE.ccitt(1:9)) THEN
1880 IF (kary(27).NE.0) THEN
1881 IF (kdesc(1,kary(11)).LT.7937.OR.
1882 * kdesc(1,kary(11)).GT.8191) THEN
1883C ASSOC FLD FOR ALL BUT CLASS 31
1884 kpos = kpos + 1
1885 IF (kassoc(kary(11)).EQ.ibits(kary(27))) THEN
1886 kdata(ksub,kpos) = misg
1887 ELSE
1888 kdata(ksub,kpos) = kassoc(kary(11))
1889 END IF
1890 END IF
1891 END IF
1892C IF NOT MISSING DATA
1893 IF (idata(kary(11)).EQ.99999) THEN
1894 kpos = kpos + 1
1895 kdata(ksub,kpos) = misg
1896 ELSE
1897C PROCESS INTEGER VALUES
1898 kpos = kpos + 1
1899 kdata(ksub,kpos) = idata(kary(11))
1900 END IF
1901 ELSE
1902C PROCESS TEXT
1903C NUMBER OF BYTES REQUIRED BY TABLE B
1904 kreq = kwidth(k) / 8
1905C NUMBER BYTES AVAILABLE IN ATEXT
1906 kavail = idata(kary(11))
1907C UNUSED POSITIONS IN LAST WORD
1908 krem = mod(kavail,4)
1909 IF (krem.NE.0) THEN
1910 kwords = kavail / 4 + 1
1911 ELSE
1912 kwords = kavail / 4
1913 END IF
1914C MOVE TEXT CHARACTERS TO KDATA
1915 jwide = kwidth(k)
1916 GO TO 1200
1917 END IF
1918 END IF
1919 GO TO 1000
1920 1200 CONTINUE
1921 300 CONTINUE
1922 nptr = mptr
1923 DO 400 ij = 1, kwords
1924 kpos = kpos + 1
1925 CALL gbyte(atext,kdata(ksub,kpos),nptr,32)
1926 nptr = nptr + 32
1927 400 CONTINUE
1928 mptr = mptr + jwide
1929 GO TO 1000
1930 1500 CONTINUE
1931 RETURN
1932 END
1933C> @brief Convert real/text input to integer
1934C> @author Bill Cavanaugh @date 1993-12-03
1935
1936C> Construct integer subset from real and text data.
1937C>
1938C> Program history log:
1939C> - Bill Cavanaugh 1993-12-03
1940C> - J. Hoppa 1994-03-31 Added ksub to the fi8501 parameter list.
1941C> - J. Hoppa 1994-04-18 Added dummy variable idum to fi8502 parameter list.
1942C> - J. Hoppa 1994-04-20 Added dummy variable ll to fi8501 parameter list.
1943C> - J. Hoppa 1994-04-29 Changed i to kary(11) added a kary(2) assignment so have something
1944C> to pass to subroutines ** test this ** removed i and ll from call to fi8501
1945C> - J. Hoppa 1994-05-18 Deleted kary(2) assignment
1946C>
1947C> @param[in] IUNITB unit number of device containing table b
1948C> @param[in] RDATA real working array
1949C> @param[in] KDESC expanded descriptor set
1950C> @param[in] NRDESC number of descriptors in kdesc
1951C> @param[in] ATEXT text data for ccitt ia5 and text operator fields
1952C> @param[in] KSUB subset number
1953C> @param[in] KARY working array
1954C> @param[in] ISECT3
1955C> @param[in] IUNITD
1956C> @param[out] KDATA Array containing integer subsets
1957C> @param[out] LDESC List of table b descriptors (decimal)
1958C> @param[out] ANAME List of descriptor names
1959C> @param[out] AUNITS Units for each descriptor
1960C> @param[out] KSCALE Base 10 scale factor for each descriptor
1961C> @param[out] KRFVAL Reference value for each descriptor
1962C> @param[out] KRFVSW
1963C> @param[out] KASSOC
1964C> @param[out] KWIDTH Standard bit width to contain each value for specific descriptor
1965C> @param[out] IERRTN Error return flag
1966C> @param[out] KNUM
1967C> @param[out] KLIST
1968C> @param ISTEP
1969C> @param KSEQ
1970C> @param INDEXB
1971C>
1972C> @author Bill Cavanaugh @date 1993-12-03
1973 SUBROUTINE fi8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
1974 * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
1975 * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
1976
1977C TAKE EACH NON-TEXT ENTRY OF SECTION 2
1978C SCALE IT
1979C ROUND IT
1980C CONVERT TO INTEGER
1981C
1982C TAKE EACH TEXT ENTRY
1983C INSERT INTO INTEGER ARRAY,
1984C ADDING FULL WORDS AS NECESSARY
1985C MAKE SURE ANY LAST WORD HAS TEXT DATA
1986C RIGHT JUSTIFIED
1987C PASS BACK CONVERTED ENTRY TO LOCATION
1988C SPECIFIED BY USER
1989C
1990C REFERENCE VALUE WILL BE APPLIED DURING
1991C ENCODING OF MESSAGE
1992C ---------------------------------------------------------------------
1993 REAL RDATA(*)
1994 INTEGER IUNITB,IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
1995 INTEGER IBITS(32),INDEXB(*)
1996 INTEGER KDESC(3,*),ISTEP
1997 INTEGER KDATA(500,*)
1998 INTEGER KASSOC(*)
1999 INTEGER KARY(*)
2000 INTEGER KSUB,K
2001 INTEGER LDESC(*)
2002 INTEGER NRDESC
2003 INTEGER IERRTN
2004 INTEGER KSCALE(*)
2005 INTEGER KRFVAL(*)
2006 INTEGER KRFVSW(*)
2007 INTEGER KWIDTH(*)
2008 INTEGER MPTR,ISECT3(*)
2009 INTEGER MISG
2010 CHARACTER*1 AHOLD1(256)
2011 INTEGER IHOLD4(64)
2012 CHARACTER*1 ATEXT(*)
2013 CHARACTER*25 AUNITS(*)
2014 CHARACTER*25 CCITT
2015 CHARACTER*40 ANAME(*)
2016C
2017 SAVE
2018C =====================================
2019 equivalence(ahold1,ihold4)
2020C
2021 DATA ibits/ 1, 3, 7, 15,
2022 * 31, 63, 127, 255,
2023 * 511, 1023, 2047, 4095,
2024 * 8191, 16383, 32767, 65535,
2025 * z'0001FFFF',z'0003FFFF',z'0007FFFF',z'000FFFFF',
2026 * z'001FFFFF',z'003FFFFF',z'007FFFFF',z'00FFFFFF',
2027 * z'01FFFFFF',z'03FFFFFF',z'07FFFFFF',z'0FFFFFFF',
2028 * z'1FFFFFFF',z'3FFFFFFF',z'7FFFFFFF',z'FFFFFFFF'/
2029C
2030 DATA ccitt /'CCITT IA5 '/
2031 DATA misg /99999/
2032C =====================================
2033C
2034 IF (isect3(8).EQ.0) THEN
2035 CALL fi8512(iunitb,isect3,kdesc,nrdesc,kary,ierrtn,
2036 * ldesc,aname,aunits,kscale,krfval,kwidth,krfvsw,
2037 * iunitd,kseq,knum,klist,indexb)
2038 IF (ierrtn.NE.0) THEN
2039 RETURN
2040 END IF
2041 END IF
2042C HAVE TABLE B AVAILABLE NOW
2043C
2044C LOOK AT EACH DATA ENTRY
2045C CONVERT NON TEXT
2046C MOVE TEXT
2047C
2048 kpos = 0
2049 mptr = 0
2050 kary(11) = 0
2051 1000 CONTINUE
2052 kary(11) = kary(11) + 1
2053 IF (kary(11).GT.nrdesc) GO TO 1500
2054C RE-ENRY POINT FOR REPLICATION AND
2055C SEQUENCE DESCRIPTORS
2056 500 CONTINUE
2057 kfunc = kdesc(1,kary(11)) / 16384
2058 kl = kdesc(1,kary(11)) - 16384 * kfunc
2059 kclass = kl / 256
2060 kseg = mod(kl,256)
2061C KARY(2) = KARY(11) + KARY(18)
2062 IF (kfunc.EQ.1) THEN
2063C REPLICATION DESCRIPTOR
2064 CALL fi8501(kary,istep,kclass,kseg,idata,rdata,
2065 * kdata,ksub,kdesc,nrdesc,ierrtn)
2066 IF (ierrtn.NE.0) THEN
2067 RETURN
2068 END IF
2069 GO TO 500
2070 ELSE IF (kfunc.EQ.2) THEN
2071C HANDLE OPERATORS
2072 IF (kclass.EQ.5) THEN
2073C NUMBER BYTES AVAILABLE IN ATEXT
2074 kavail = rdata(kary(11))
2075C UNUSED POSITIONS IN LAST WORD
2076 krem = mod(kavail,4)
2077 IF (krem.NE.0) THEN
2078 kwords = kavail / 4 + 1
2079 ELSE
2080 kwords = kavail / 4
2081 END IF
2082 jwide = kseg * 8
2083 GO TO 1200
2084 ELSE IF (kclass.EQ.2) THEN
2085 IF (kseg.EQ.0) THEN
2086 kary(9) = 0
2087 ELSE
2088 kary(9) = kseg - 128
2089 END IF
2090 GO TO 1200
2091 END IF
2092 ELSE IF (kfunc.EQ.3) THEN
2093C SEQUENCE DESCRIPTOR - ERROR
2094 CALL fi8503(kary(11),kdesc,nrdesc,
2095 * isect3,iunitd,kseq,knum,klist,ierrtn)
2096 IF (ierrtn.NE.0) THEN
2097 RETURN
2098 END IF
2099 GO TO 500
2100 ELSE
2101C
2102C FIND MATCHING DESCRIPTOR
2103C
2104 k = indexb(kdesc(1,kary(11)))
2105 IF (k.LT.1) THEN
2106 ierrtn = 2
2107C PRINT *,'FI8509 - IERRTN = 2'
2108 RETURN
2109 END IF
2110C HAVE MATCHING DESCRIPTOR
2111 200 CONTINUE
2112 IF (aunits(k)(1:9).NE.ccitt(1:9)) THEN
2113 IF (kary(27).NE.0) THEN
2114 IF (kdesc(1,kary(11)).LT.7937.OR.
2115 * kdesc(1,kary(11)).GT.8191) THEN
2116C ASSOC FLD FOR ALL BUT CLASS 31
2117 kpos = kpos + 1
2118 IF (kassoc(kary(11)).EQ.ibits(kary(27))) THEN
2119 kdata(ksub,kpos) = misg
2120 ELSE
2121 kdata(ksub,kpos) = kassoc(kary(11))
2122 END IF
2123 END IF
2124 END IF
2125C IF NOT MISSING DATA
2126 IF (rdata(kary(11)).EQ.99999.) THEN
2127 kpos = kpos + 1
2128 kdata(ksub,kpos) = misg
2129 ELSE
2130C PROCESS REAL VALUES
2131 IF (kscale(k).NE.0) THEN
2132C SCALING ALLOWING FOR CHANGE SCALE
2133 scale = 10. **(iabs(kscale(k)) + kary(9))
2134 IF (kscale(k).LT.0) THEN
2135 rdata(kary(11)) = rdata(kary(11)) / scale
2136 ELSE
2137 rdata(kary(11)) = rdata(kary(11)) * scale
2138 END IF
2139 END IF
2140C PERFORM ROUNDING
2141 rdata(kary(11)) = rdata(kary(11)) +
2142 * sign(0.5,rdata(kary(11)))
2143C CONVERT TO INTEGER
2144 kpos = kpos + 1
2145 kdata(ksub,kpos) = rdata(kary(11))
2146C
2147 END IF
2148 ELSE
2149C PROCESS TEXT
2150C NUMBER OF BYTES REQUIRED BY TABLE B
2151 kreq = kwidth(k) / 8
2152C NUMBER BYTES AVAILABLE IN ATEXT
2153 kavail = rdata(kary(11))
2154C UNUSED POSITIONS IN LAST WORD
2155 krem = mod(kavail,4)
2156 IF (krem.NE.0) THEN
2157 kwords = kavail / 4 + 1
2158 ELSE
2159 kwords = kavail / 4
2160 END IF
2161C MOVE TEXT CHARACTERS TO KDATA
2162 jwide = kwidth(k)
2163 GO TO 1200
2164 END IF
2165 END IF
2166 GO TO 1000
2167 1200 CONTINUE
2168 300 CONTINUE
2169 nptr = mptr
2170 DO 400 ij = 1, kwords
2171 kpos = kpos + 1
2172 CALL gbyte(atext,kdata(ksub,kpos),nptr,32)
2173 nptr = nptr + 32
2174 400 CONTINUE
2175 mptr = mptr + jwide
2176 GO TO 1000
2177 1500 CONTINUE
2178C DO 2000 I = 1, KPOS
2179C2000 CONTINUE
2180 RETURN
2181 END
2182C> @brief Rebuild kdesc from jdesc
2183C> @author Bill Cavanaugh @date 1993-12-03
2184
2185C> Construct working descriptor list from list of descriptors in section 3.
2186C>
2187C> Program history log:
2188C> - Bill Cavanaugh 1993-12-03
2189C>
2190C> @param[in] ISECT3
2191C> @param[in] KARY Utility - array see main routine
2192C> @param[in] JIF Descriptor input form flag
2193C> @param[in] JDESC List of descriptors for section 3
2194C> @param[in] NEWNR Number of descriptors in jdesc
2195C> @param[out] KIF Descriptor form
2196C> @param[out] KDESC Working list of descriptors
2197C> @param[out] NRDESC Number of descriptors in kdesc
2198C> @param[out] IERRTN Error return
2199C> - IERRTN = 0 Normal return
2200C> - IERRTN = 5 Found delayed replication during expansion
2201C>
2202C> @author Bill Cavanaugh @date 1993-12-03
2203 SUBROUTINE fi8511(ISECT3,KARY,JIF,JDESC,NEWNR,
2204 * KIF,KDESC,NRDESC,IERRTN)
2205
2206C
2207 INTEGER JDESC(3,*), NEWNR, KDESC(3,*), NRDESC
2208 INTEGER KARY(*),IERRTN,KIF,JIF
2209 INTEGER ISECT3(*)
2210C
2211 SAVE
2212C
2213 IF (NEWNR.EQ.0) THEN
2214 IERRTN = 3
2215 return
2216 END IF
2217C
2218 nrdesc = newnr
2219 IF (jif.EQ.0) THEN
2220 jif = 1
2221 DO 90 i = 1, newnr
2222 kdesc(1,i) = jdesc(1,i)*16384 + jdesc(2,i)*256 + jdesc(3,i)
2223 jdesc(1,i) = jdesc(1,i)*16384 + jdesc(2,i)*256 + jdesc(3,i)
2224 90 CONTINUE
2225 ELSE
2226 DO 100 i = 1, newnr
2227 kdesc(1,i) = jdesc(1,i)
2228 100 CONTINUE
2229 nrdesc = newnr
2230 END IF
2231 kif = 1
2232 9000 CONTINUE
2233 RETURN
2234 END
2235C> @brief Read in table B
2236C> @author Bill Cavanaugh @date 1993-12-03
2237
2238C> Read in tailored set of table B descriptors.
2239C>
2240C> Program history log:
2241C> - Bill Cavanaugh 1993-12-03
2242C> - J. Hoppa 1994-04-18 An error has been corrected to prevent later
2243C> searching table b if there are only operator
2244C> descriptors in the descriptor list.
2245C> - J. Hoppa 1994-05-17 Changed the loop for expanding sequence
2246C> descriptors from a do loop to a goto loop
2247C>
2248C> @param[in] IUNITB Unit where table b entries reside
2249C> @param[in] KDESC Working descriptor list
2250C> @param[in] NRDESC Number of descriptors in kdesc
2251C> @param[in] IUNITD Unit where table d entries reside
2252C> @param[out] KARY
2253C> @param[out] IERRTN
2254C> @param[out] LDESC Descriptors in table b (decimal values)
2255C> @param[out] ANAME Array containing names of descriptors
2256C> @param[out] AUNITS Array containing units of descriptors
2257C> @param[out] KSCALE Scale values for each descriptor
2258C> @param[out] KRFVAL Reference values for each descriptor
2259C> @param[out] KWIDTH Bit width of each descriptor
2260C> @param[out] KRFVSW New reference value switch
2261C> @param[out] KSEQ Sequence descriptor
2262C> @param[out] KNUM Number of descriptors in sequence
2263C> @param[out] KLIST Sequence of descriptors
2264C> @param ISECT3
2265C> @param INDEXB
2266C>
2267C> @author Bill Cavanaugh @date 1993-12-03
2268 SUBROUTINE fi8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
2269 * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
2270 * IUNITD,KSEQ,KNUM,KLIST,INDEXB)
2271
2272C
2273 INTEGER KARY(*),LDESC(*),KSCALE(*),KRFVAL(*),KWIDTH(*)
2274 INTEGER KDESC(3,*), NRDESC, IUNITB, IERRTN, KRFVSW(*)
2275 INTEGER ISECT3(*),KEY(3,1600),INDEXB(*)
2276 INTEGER IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
2277 CHARACTER*40 ANAME(*)
2278 CHARACTER*25 AUNITS(*)
2279C
2280 INTEGER MDESC(800),MR,I,J
2281C
2282 SAVE
2283C
2284C ===================================================================
2285 ierrtn = 0
2286 DO 100 i = 1, 30
2287 kary(i) = 0
2288 100 CONTINUE
2289C INITIALIZE DESCRIPTOR POINTERS TO MISSING
2290 DO 105 i = 1, 16383
2291 indexb(i) = -1
2292 105 CONTINUE
2293C
2294C ===================================================================
2295C MAKE A COPY OF THE DESCRIPTOR LIST
2296C ELIMINATING REPLICATION/OPERATORS
2297 j = 0
2298 DO 110 i = 1, nrdesc
2299 IF (kdesc(1,i).GE.49152.OR.kdesc(1,i).LT.16384) THEN
2300 j = j + 1
2301 key(1,j) = kdesc(1,i)
2302 END IF
2303 110 CONTINUE
2304 kcnt = j
2305C ===================================================================
2306C REPLACE ALL SEQUENCE DESCRIPTORS
2307C JEN - FIXED NEXT BLOCK
2308C DO 300 I = 1, KCNT
2309 i = 1
2310 300 IF(i.LE.kcnt)THEN
2311 200 CONTINUE
2312 IF (key(1,i).GE.49152) THEN
2313 CALL fi8503(i,key,kcnt,
2314 * isect3,iunitd,kseq,knum,klist,ierrtn)
2315 IF (ierrtn.NE.0) THEN
2316 RETURN
2317 END IF
2318 GO TO 200
2319 END IF
2320 i=i+1
2321 GOTO 300
2322 ENDIF
2323C 300 CONTINUE
2324C ===================================================================
2325C ISOLATE SINGLE COPIES OF DESCRIPTORS
2326 mr = 1
2327C THE FOLLOWING LINE IS TO PREVENT LATER SEARCHING TABLE B WHEN
2328C HAVE ONLY OPERATOR DESCRIPTORS
2329 IF(kcnt.EQ.0) GOTO 9000
2330 mdesc(mr) = key(1,1)
2331 DO 500 i = 2, kcnt
2332 DO 400 j = 1, mr
2333 IF (key(1,i).EQ.mdesc(j)) THEN
2334 GO TO 500
2335 END IF
2336 400 CONTINUE
2337 mr = mr + 1
2338 mdesc(mr) = key(1,i)
2339 500 CONTINUE
2340C ===================================================================
2341C SORT INTO ASCENDING ORDER
2342C READ IN MATCHING ENTRIES FROM TABLE B
2343 DO 700 kcur = 1, mr
2344 next = kcur + 1
2345 IF (next.LE.mr) THEN
2346 DO 600 lr = next, mr
2347 IF (mdesc(kcur).GT.mdesc(lr)) THEN
2348 ihold = mdesc(lr)
2349 mdesc(lr) = mdesc(kcur)
2350 mdesc(kcur) = ihold
2351 END IF
2352 600 CONTINUE
2353 END IF
2354 700 CONTINUE
2355C ===================================================================
2356 rewind iunitb
2357C
2358C READ IN A MODIFIED TABLE B -
2359C MODIFIED TABLE B CONTAINS ONLY
2360C THOSE DESCRIPTORS ASSOCIATED WITH
2361C CURRENT DATA.
2362C
2363 ktry = 0
2364 DO 1500 nrtblb = 1, mr
2365 1000 CONTINUE
2366 1001 FORMAT (i1,i2,i3,a40,a25,i4,8x,i7,i5)
2367 READ (iunitb,1001,END=2000,ERR=8000)KF,KX,KY,ANAME(NRTBLB),
2368 * aunits(nrtblb),kscale(nrtblb),krfval(nrtblb),kwidth(nrtblb)
2369 krfvsw(nrtblb) = 0
2370 ldesc(nrtblb) = kx*256 + ky
2371C
2372 IF (ldesc(nrtblb).EQ.mdesc(nrtblb)) THEN
2373C PRINT *,'1001',NRTBLB,LDESC(NRTBLB)
2374C PRINT *,LDESC(NRTBLB),ANAME(NRTBLB),KSCALE(NRTBLB),
2375C * KRFVAL(NRTBLB),KWIDTH(NRTBLB)
2376 ktry = ktry + 1
2377 indexb(ldesc(nrtblb)) = ktry
2378C PRINT *,'INDEX(',LDESC(NRTBLB),' = ',KTRY
2379 ELSE IF (ldesc(nrtblb).GT.mdesc(nrtblb)) THEN
2380C PRINT *,'FI8512 - IERRTN=2'
2381 ierrtn = 2
2382 RETURN
2383 ELSE
2384 GO TO 1000
2385 END IF
2386 1500 CONTINUE
2387 IF (ktry.NE.mr) THEN
2388 print *,'DO NOT HAVE A COMPLETE SET OF TABLE B ENTRIES'
2389 ierrtn = 2
2390 RETURN
2391 END IF
2392C DO 1998 I = 1, 16383, 30
2393C WRITE (6,1999) (INDEXB(I+J),J=0,23)
2394C1998 CONTINUE
2395C1999 FORMAT(30(1X,I3))
2396C
2397 2000 CONTINUE
2398 ierrtn = 0
2399 isect3(8) = mr
2400 GO TO 9000
2401 8000 CONTINUE
2402 ierrtn = 4
2403 9000 CONTINUE
2404 RETURN
2405 END
2406C> @brief Read in table D
2407C> @author Bill Cavanaugh @date 1993-12-03
2408
2409C> Read in table D
2410C>
2411C> Program history log:
2412C> - Bill Cavanaugh 1993-12-03
2413C>
2414C> @param[in] IUNITD Unit number of input device
2415C> @param[out] KSEQ Key for sequence descriptors
2416C> @param[out] KNUM Number if descriptors in list
2417C> @param[out] KLIST Descriptors list
2418C> @param[out] IERRTN Error return flag
2419C> @param ISECT3
2420C>
2421C> @author Bill Cavanaugh @date 1993-12-03
2422 SUBROUTINE fi8513 (IUNITD,ISECT3,KSEQ,KNUM,KLIST,IERRTN)
2423
2424C
2425 INTEGER IUNITD, ISECT3(*)
2426 INTEGER KSEQ(*),KNUM(*),KLIST(300,*)
2427 INTEGER KKF(10),KKX(10),KKY(10),KF,KX,KY
2428C
2429 SAVE
2430C
2431 REWIND IUNITD
2432 J = 0
2433 ierrtn = 0
2434 1000 CONTINUE
2435 READ (iunitd,1001,END=9000,ERR=8000)KF,KX,KY,
2436 * kkf(1),kkx(1),kky(1),
2437 * kkf(2),kkx(2),kky(2),
2438 * kkf(3),kkx(3),kky(3),
2439 * kkf(4),kkx(4),kky(4),
2440 * kkf(5),kkx(5),kky(5),
2441 * kkf(6),kkx(6),kky(6),
2442 * kkf(7),kkx(7),kky(7),
2443 * kkf(8),kkx(8),kky(8),
2444 * kkf(9),kkx(9),kky(9),
2445 * kkf(10),kkx(10),kky(10)
2446 1001 FORMAT (11(i1,i2,i3,1x),3x)
2447 j = j + 1
2448C BUILD SEQUENCE KEY
2449 kseq(j) = 16384*kf + 256*kx + ky
2450 DO 2000 lm = 1, 10
2451C BUILD KLIST
2452 klist(j,lm) = 16384*kkf(lm) + 256*kkx(lm) + kky(lm)
2453 IF(klist(j,lm).NE.0) THEN
2454 knum(j) = lm
2455 END IF
2456 2000 CONTINUE
2457 GO TO 1000
2458 8000 CONTINUE
2459 ierrtn = 6
2460 9000 CONTINUE
2461 isect3(9) = j
2462 RETURN
2463 END
gbyte
subroutine gbyte(ipackd, iunpkd, noff, nbits)
This is the fortran version of gbyte.
Definition gbyte.f:27
sbyte
subroutine sbyte(iout, in, iskip, nbyte)
Definition sbyte.f:12
w3ai38
subroutine w3ai38(ie, nc)
Convert EBCDIC to ASCII by character.
Definition w3ai38.f:37
fi8511
subroutine fi8511(isect3, kary, jif, jdesc, newnr, kif, kdesc, nrdesc, ierrtn)
Rebuild kdesc from jdesc.
Definition w3fi85.f:2205
fi8503
subroutine fi8503(i, kdesc, nrdesc, isect3, iunitd, kseq, knum, klist, ierrtn)
Expand sequence descriptor.
Definition w3fi85.f:1307
fi8509
subroutine fi8509(istep, iunitb, rdata, kdesc, nrdesc, atext, ksub, kary, kdata, ldesc, aname, aunits, kscale, krfval, krfvsw, isect3, kwidth, kassoc, iunitd, kseq, knum, klist, ierrtn, indexb)
Convert real/text input to integer.
Definition w3fi85.f:1976
fi8505
subroutine fi8505(mif, mdesc, nr, ierrtn)
Convert descriptors fxy to decimal.
Definition w3fi85.f:1393
w3fi85
subroutine w3fi85(istep, iunitb, iunitd, ibfsiz, isect1, isect3, jif, jdesc, newnr, idata, rdata, atext, kassoc, kif, kdesc, nrdesc, isec2d, isec2b, kdata, kary, kbufr, ierrtn)
Using information available in supplied arrays, generate a bufr message (wmo code fm94).
Definition w3fi85.f:214
fi8501
subroutine fi8501(kary, istep, kclass, kseg, idata, rdata, kdata, nsub, kdesc, nrdesc, ierrtn)
Perform replication of descriptors.
Definition w3fi85.f:981
fi8506
subroutine fi8506(istep, isect3, kary, jdesc, newnr, kdesc, nrdesc, ldesc, aname, aunits, kscale, krfval, kwidth, krfvsw, newrfv, kseq, knum, klist, ibfsiz, kdata, kbufr, ierrtn, indexb)
Process data in non-compressed format.
Definition w3fi85.f:1473
fi8508
subroutine fi8508(istep, iunitb, idata, kdesc, nrdesc, atext, ksub, kary, kdata, ldesc, aname, aunits, kscale, krfval, krfvsw, isect3, kwidth, kassoc, iunitd, kseq, knum, klist, ierrtn, indexb)
Combine integer/text data.
Definition w3fi85.f:1752
fi8512
subroutine fi8512(iunitb, isect3, kdesc, nrdesc, kary, ierrtn, ldesc, aname, aunits, kscale, krfval, kwidth, krfvsw, iunitd, kseq, knum, klist, indexb)
Read in table B.
Definition w3fi85.f:2271
fi8502
subroutine fi8502(, kbufr, kclass, kseg, kdesc, nrdesc, i, istep, kary, kdata, isect3, krfvsw, newrfv, ldesc, ierrtn, indexb)
Process an operator descriptor.
Definition w3fi85.f:1116
fi8513
subroutine fi8513(iunitd, isect3, kseq, knum, klist, ierrtn)
Read in table D.
Definition w3fi85.f:2423