NCEPLIBS-w3emc  2.11.0
w3fi85.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Generate bufr message
3 C> @author Bill Cavanaugh @date 1993-09-29
4 
5 C> Using information available in supplied arrays, generate
6 C> a bufr message (wmo code fm94). there may be a section 2
7 C> included in the bufr message if the user follows proper procedure.
8 C> messages are constructed in accordance with bufr edition 2. entries
9 C> for section 1 must be passed to this routine in the isect1 array.
10 C> entries for section 3 must be passed to this routine in isect3.
11 C>
12 C>
13 C> In the event that the user requests a reduction of reports
14 C> in a bufr message if a particular message becomes oversized, the
15 C> possibility exists of the last block of data producing an oversized
16 C> message. the user must verify that isect3(6) does in fact equal
17 C> zero to assure that all of the data has been included as output.
18 C>
19 C> Program history log:
20 C> - Bill Cavanaugh 1993-09-29
21 C> - J. Hoppa 1994-03-22 Corrected an error when writing the
22 C> descriptors into the bufr message
23 C> - J. Hoppa 1994-03-31 Added the subset number to the parameter list
24 C> of subroutine fi8501()
25 C> - J. Hoppa 1994-04-15 Added kbufr to the parameter list of
26 C> subroutine fi8502()
27 C> - J. Hoppa 1994-04-20 Added the kdata parameter counter to the
28 C> parameter list of subroutine fi8501()
29 C> - J. Hoppa 1995-04-29 Changed nq and n to kary(2) changed jk to kary(11)
30 C> added an assignment to kary(2) so have something to pass to subroutines
31 C> deleted jk and ll from call to fi8501()
32 C>
33 C> @param[in] ISTEP Key for selection of processing step
34 C> - 1 = Process integer/text array into kdata.
35 C> - 2 = Process real/text array into kdata.
36 C> - 3 = Construct bufr message.
37 C> @param[in] IUNITB Unit number of device containing table b
38 C> @param[in] IUNITD Unit number of device containing table d
39 C> @param[in] IBFSIZ Size in bytes of bufr message array (kbufr)
40 C> should be a multiple of word size.
41 C> @param[in] ISECT1 Contains information to enter into section 1
42 C> (1) Edition number
43 C> (2) Bufr master table number
44 C> 0 = meteorological
45 C> others not yet defined
46 C> (3) Originating center - subcenter number
47 C> (4) Originating center number
48 C> (5) Update sequence number
49 C> (6) Optional section flag should be set to zero unless user write
50 C> additional code to enter local information into section 3
51 C> (7) Bufr message type
52 C> (8) Bufr message sub_type
53 C> (9) Master table version number
54 C> (10) Local table version number
55 C> (11) Year of century - representative of data
56 C> (12) Month - representative of data
57 C> (13) Day - representative of data
58 C> (14) Hour - representative of data
59 C> (15) Minute - representative of data
60 C> (16)-(20) Unused
61 C> @param[in] ISECT3 Values to be inserted into section 3, and to control
62 C> report reduction for oversized messages
63 C> - (1) Number of subsets
64 C> Defines the number of subsets being passed to the encoder routine for
65 C> inclusion into a bufr message. If the user has specified the use of the
66 C> subset/report reduction activation switch, then a part of those subsets may
67 C> be used for the current message and the remainder retained for a subsequent
68 C> message.
69 C> - (2) Observed flag
70 C> - 0 = observed data
71 C> - 1 = other data
72 C> - (3) Compressed flag
73 C> - 0 = noncompressed
74 C> - 1 = compressed
75 C> - (4) Subset/report reduction activation switch used to control the number
76 C> of reports entered into a bufr message when maximum message size is exceeded
77 C> - 0 = option not active
78 C> - 1 = option is active. unused subsets will be shifted to low order
79 C> positions of entry array.
80 C> - 2 = option is active. unused subsets will remain in entry positions.
81 C> @note If this flag is set to any other values, program will be terminated
82 C> with an error condition.
83 C> - (5) Number of reports to decrement by, if oversized message
84 C> (minimum value = one). If zero is entered, it will
85 C> be replaced by one.
86 C> - (6) Number of unused reports returned to user
87 C> - (7) Number of reports included in message
88 C> - (8) Number of table b entries available to decoder
89 C> - (9) Number of table d entries available to decoder
90 C> - (10) Text input flag
91 C> - 0 = ASCII input
92 C> - 1 = EBCIDIC input
93 C> @param[in] JIF JDESC input format flag
94 C> - 0 = F X Y
95 C> - 1 = Decimal format
96 C> @param[in] JDESC List of descriptors to go into section 3
97 C> Each descriptor = F * 16384 + X * 256 + Y
98 C> They may or may not be an exact match of the working descriptor list in kdesc.
99 C> This set of descriptors may contain sequence descriptors to provide additional
100 C> compression within the bufr message. There may be as few as one sequence
101 C> descriptor, or as many descriptors as there are in kdesc.
102 C> @param[in] NEWNR NR of descriptors in JDESC
103 C> @param[in] IDATA Integer array dimensioned by the number of descriptors to
104 C> be used
105 C> @param[in] RDATA Real array dimensioned by the number of descriptors to be
106 C> used
107 C> @param[in] ATEXT Array containing all text data associated with a specific
108 C> report. All data identified as text data must be in ASCII.
109 C> @param[in] KASSOC Integer array dimensioned by the number of descriptors
110 C> to be used, containing the associated field values for any entry in the
111 C> descriptor list.
112 C> @param[in] KIF KDESC input format flag
113 C> - 0 = F X Y
114 C> - 1 = DECIMAL FORMAT
115 C> @param[in] KDESC List of descriptors to go into section 3 fully expanded set of working
116 C> descriptors. there should be an element descriptor for every data entry, but
117 C> there should be no sequence descriptors.
118 C> @param[in] NRDESC NR of descriptors in kdesc
119 C> @param[in] ISEC2D Data or text to be entered into section 2
120 C> @param[in] ISEC2B Number of bytes of data in isec2d
121 C> @param[out] KDATA Source data array . a 2-dimension integer array where
122 C> kdata(subset,param) subset = subset number param = parameter number.
123 C> @param[out] KARY Working array for message under construction
124 C> - (1) unused
125 C> - (2) parameter pointer
126 C> - (3) message bit pointer
127 C> - (4) delayed replication flag
128 C> - 0 = no delayed replication
129 C> - 1 = contains delayed replication
130 C> - (5) bit pointer for start of section 4
131 C> - (6) unused
132 C> - (7) nr of bits for parameter/data packing
133 C> - (8) total bits for ascii data
134 C> - (9) scale change value
135 C> - (10) indicator (used in w3fi85)
136 C> - 1 = numeric data
137 C> - 2 = text data
138 C> - (11) pointer to current pos in kdesc
139 C> - (12) unused
140 C> - (13) unused
141 C> - (14) unused
142 C> - (15) data type
143 C> - (16) unused
144 C> - (17) unused
145 C> - (18) words added for text or associated fields
146 C> - (19) location for total byte count
147 C> - (20) size of section 0
148 C> - (21) size of section 1
149 C> - (22) size of section 2
150 C> - (23) size of section 3
151 C> - (24) size of section 4
152 C> - (25) size of section 5
153 C> - (26) nr bits added by table c operator
154 C> - (27) bit width of associated field
155 C> - (28) jdesc input form flag
156 C> - 0 = Descriptor in f x y form
157 C> - F in JDESC(1,I)
158 C> - X in JDESC(2,I)
159 C> - Y in JDESC(3,I)
160 C> - 1 = DEscriptor in decimal form in jdesc(1,i)
161 C> - (29) kdesc input form flag
162 C> - 0 = Descriptor in F X Y form
163 C> - F in KDESC(1,I)
164 C> - X in KDESC(2,I)
165 C> - Y in KDESC(3,I)
166 C> - 1 = Descriptor in decimal form in kdesc(1,i)
167 C> - (30) bufr message total byte count
168 C> @param[out] KBUFR Array to contain completed bufr message
169 C> @param[out] IERRTN Error return flag
170 C>
171 C> IERRTN:
172 C> - = 0 Normal return, bufr message resides in kbufr
173 C> - if isect3(4)= 0, all reports have been processed into a bufr message
174 C> - if isect3(4)= 1, a bufr message has been generated with all or part of
175 C> the data passed to this routine. isect3(6) contains the number of reports
176 C> that were not used but are being held for the next message.
177 C> - = 1 bufr message construction was halted because contents exceeded maximum size
178 C> (only when isect3(4) = 0)
179 C> - = 2 bufr message construction was halted because of encounter with a
180 C> descriptor not found in table b.
181 C> - = 3 routine was called with no subsets
182 C> - = 4 error occured while reading table b
183 C> - = 5 an attempt was made to expand jdesc into kdesc, but a descriptor indicating
184 C> delayed replication was encountered
185 C> - = 6 error occured while reading table d
186 C> - = 7 data value could not be contained in specified bit width
187 C> - = 8 delayed replication not permitted in compressed data format
188 C> - = 9 an operator descriptor 2 04 yyy opening an associated field (yyy not eq zero)
189 C> was not followed by the defining descriptor 0 31 021 (7957 decimal).
190 C> - = 10 delayed replication descriptor was not followed by descriptor for delayed
191 C> replication factor.
192 C> - 0 31 001
193 C> - 0 31 002
194 C> - 0 31 011
195 C> - 0 31 012
196 C> - = 11 encountered a reference value that forced a data element to become negative
197 C> - = 12 no matching table d entry for sequence descriptor.
198 C> - = 13 encountered a non-acceptable data entry flag. isect3(6) should be 0 or 1.
199 C> - = 14 converting descriptors fxy->decimal, number to convert = 0
200 C> - = 15 no descriptors specified for section 3
201 C> - = 16 incomplete table b, number of descriptors in table b does not match number of
202 C> descriptors needed to construct bufr message
203 C> - = 20 incorrect entry of replication or sequence descriptor in list of reference
204 C> value changes
205 C> - = 21 incorrect operator descriptor in list of reference value changes
206 C> - = 22 attempting to enter new reference value into table b, but descriptor
207 C> does not exist in current modified table b
208 C>
209 C> @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)
214 C
215  REAL RDATA(*)
216 C
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
228 C =====================================
229 C 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(*)
237 C =====================================
238 C 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)
245 C =====================================
246 C TABLE D INFORMATION
247  INTEGER KSEQ(300),KNUM(300)
248  INTEGER KLIST(300,10)
249 C =====================================
250  SAVE
251 C
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/
264 C =====================================
265 C THERE MUST BE DESCRIPTORS IN JDESC
266 C AND A COUNT IN NEWNR
267 C =====================================
268  IF (newnr.EQ.0) THEN
269  ierrtn = 15
270  RETURN
271  END IF
272 C =====================================
273 C IF INPUT FORM IS F X Y SEGMENTS THEN
274 C CONVERT INPUT FORM OF JDESC FROM FXY TO DECIMAL
275 C =====================================
276  IF (jif.EQ.0) THEN
277 C CONVERT TO DECIMAL
278  CALL fi8505(jif,jdesc,newnr,ierrtn)
279  IF (ierrtn.NE.0) THEN
280  RETURN
281  END IF
282  END IF
283 C =====================================
284 C IF PROCESSING DELAYED REPLICATION, MUST RELOAD
285 C KDESC FROM JDESC
286 C =====================================
287  IF (kary(4).NE.0) THEN
288  nrdesc = 0
289  END IF
290 C =====================================
291 C IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC
292 C =====================================
293 C 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
301 C KDESC ALL READY EXISTS
302  IF (kif.EQ.0) THEN
303 C 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
310 C =====================================
311 C READ IN TABLE B SUBSET, IF NOT ALL READY IN PLACE
312 C =====================================
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
319 C =====================================
320 C ROUTE TO SELECTED PROCESSING
321 C =====================================
322  ksub = isect3(1)
323  IF (istep.EQ.1) THEN
324 C 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
330 C 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
339 C =====================================
340 C IF INDICATING ZERO SUBSETS, HAVE AN ERROR CONDITION
341 C =====================================
342  IF (isect3(1).LE.0) THEN
343  ierrtn = 3
344  RETURN
345  END IF
346 C =====================================
347 C SET FOR BUFR MESSAGE
348 C =====================================
349 C
350 C CLEAR OUTPUT AREA
351 C BYTES IN EACH FULL WORD
352  kword = 4
353 C
354 C GET NUMBER OF SUBSETS
355 C
356  mxrpts = isect3(1)
357  isect3(7) = isect3(1)
358  isect3(6) = isect3(1)
359 C
360 C RE-START POINT FOR PACKING FEWER SUBSETS ?
361 C
362  5 CONTINUE
363 C
364  kary(18) = 0
365  kary(26) = 0
366 C =====================================
367 C ENTER 'BUFR' - SECTION 0
368 C CONSTRUCT UNDER RULES OF EDITION 2
369 C =====================================
370  kary(3) = 0
371  nbufr = 1112884818
372  CALL sbyte (kbufr,nbufr,kary(3),32)
373  kary(3) = kary(3) + 32
374 C SAVE POINTER FOR TOTAL BYTE COUNT
375 C IN MESSAGE
376  kary(19) = kary(3)
377  kary(3) = kary(3) + 24
378 C SET EDITION NR IN PLACE
379  CALL sbyte (kbufr,2,kary(3),8)
380  kary(3) = kary(3) + 8
381  kary(20) = 8
382 C PRINT *,'SECTION 0'
383 C =====================================
384 C COMPLETE ENTRIES FOR - SECTION 1
385 C =====================================
386 C ----- 1,3 SECTION COUNT
387  kary(21) = 18
388  CALL sbyte (kbufr,kary(21),kary(3),24)
389  kary(3) = kary(3) + 24
390 C ----- 4 RESERVED
391  CALL sbyte (kbufr,0,kary(3),8)
392  kary(3) = kary(3) + 8
393 C ----- 5 ORIGINATING SUB-CENTER
394  CALL sbyte (kbufr,isect1(3),kary(3),8)
395  kary(3) = kary(3) + 8
396 C ----- 6 ORIGINATING CENTER
397  CALL sbyte (kbufr,isect1(4),kary(3),8)
398  kary(3) = kary(3) + 8
399 C ----- 7 UPDATE SEQUENCE NUMBER
400  CALL sbyte (kbufr,isect1(5),kary(3),8)
401  kary(3) = kary(3) + 8
402 C ----- 8
403 C 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
408 C ----- 9 BUFR MESSAGE TYPE
409  CALL sbyte (kbufr,isect1(7),kary(3),8)
410  kary(3) = kary(3) + 8
411 C ----- 10 BUFR MESSAGE SUB-TYPE
412  CALL sbyte (kbufr,isect1(8),kary(3),8)
413  kary(3) = kary(3) + 8
414 C ----- 11 VERSION OF MASTER TABLE
415  CALL sbyte (kbufr,isect1(9),kary(3),8)
416  kary(3) = kary(3) + 8
417 C ----- 12 VERSION OF LOCAL TABLE
418  CALL sbyte (kbufr,isect1(10),kary(3),8)
419  kary(3) = kary(3) + 8
420 C ----- 13 YEAR
421  CALL sbyte (kbufr,isect1(11),kary(3),8)
422  kary(3) = kary(3) + 8
423 C ----- 14 MONTH
424  CALL sbyte (kbufr,isect1(12),kary(3),8)
425  kary(3) = kary(3) + 8
426 C ---- 15 DAY
427  CALL sbyte (kbufr,isect1(13),kary(3),8)
428  kary(3) = kary(3) + 8
429 C ----- 16 HOUR
430  CALL sbyte (kbufr,isect1(14),kary(3),8)
431  kary(3) = kary(3) + 8
432 C ----- 17 MINUTE
433  CALL sbyte (kbufr,isect1(15),kary(3),8)
434  kary(3) = kary(3) + 8
435 C ----- 18 FILL
436  CALL sbyte (kbufr,0,kary(3),8)
437  kary(3) = kary(3) + 8
438 C PRINT *,'SECTION 1'
439 C =====================================
440 C SKIP - SECTION 2
441 C =====================================
442  IF (isect1(6).NE.0) THEN
443 C BUILD SECTION COUNT
444  kary(22) = 4 + isec2b
445  IF (mod(kary(22),2).NE.0) kary(22) = kary(22) + 1
446 C INSERT SECTION COUNT
447  CALL sbyte (kbufr,kary(22),kary(3),24)
448  kary(3) = kary(3) + 24
449 C INSERT RESERVED POSITION
450  CALL sbyte (kbufr,0,kary(3),8)
451  kary(3) = kary(3) + 8
452 C 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
462 C =====================================
463 C MAKE PREPARATIONS FOR SECTION 3 DESCRIPTORS
464 C =====================================
465  kary(23) = 7 + newnr*2 + 1
466 C SECTION 3 SIZE
467  CALL sbyte (kbufr,kary(23),kary(3),24)
468  kary(3) = kary(3) + 24
469 C RESERVED BYTE
470  CALL sbyte (kbufr,0,kary(3),8)
471  kary(3) = kary(3) + 8
472 C NUMBER OF SUBSETS
473  CALL sbyte (kbufr,isect3(1),kary(3),16)
474  kary(3) = kary(3) + 16
475 C SET OBSERVED DATA SWITCH
476  CALL sbyte (kbufr,isect3(2),kary(3),1)
477  kary(3) = kary(3) + 1
478 C 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
483 C =====================================
484 C DESCRIPTORS - SECTION 3
485 C =====================================
486  DO 37 kh = 1, newnr
487 C 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
491 C FILL TO TWO BYTE BOUNDARY
492  CALL sbyte (kbufr,0,kary(3),8)
493  kary(3) = kary(3) + 8
494 C PRINT *,'SECTION 3'
495 C =====================================
496 C INITIALIZE FOR - SECTION 4
497 C =====================================
498 C SAVE POINTER TO COUNT POSITION
499 C 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
504 C SKIP TO FIRST DATA POSITION
505 C =====================================
506 C BIT PATTERNS - SECTION 4
507 C =====================================
508  kend4 = ibfsiz * 8 - 32
509 C PACK ALL DATA INTO BUFR MESSAGE
510 C
511  IF (isect3(3).EQ.0) THEN
512 C **********************************************
513 C * *
514 C * PROCESS AS NON-COMPRESSED MESSAGE *
515 C * *
516 C **********************************************
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
526 C **********************************************
527 C * *
528 C * PROCESS AS COMPRESSED MESSAGE *
529 C * *
530 C **********************************************
531  kary(18) = 0
532 C 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
538 C DO 5000 JK = 1, NRDESC
539 C RE-ENTRY POINT FOR INSERTION OF
540 C REPLICATION OR SEQUENCES
541  4000 CONTINUE
542 C ISOLATE TABLE
543  kfunc = kdesc(1,kary(11)) / 16384
544 C 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
549 C DELAYED REPLICATION NOT ALLOWED
550 C IN COMPRESSED MESSAGE
551  IF (kseg.EQ.0) THEN
552  ierrtn = 8
553  RETURN
554  END IF
555 C REPLICATION DESCRIPTOR
556  CALL fi8501(kary,istep,kclass,kseg,idata,rdata,
557  * kdata,ll,kdesc,nrdesc,ierrtn)
558 C 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
575 C FALL THRU WITH ELEMENT DESCRIPTOR
576 C POINT TO CORRECT TABLE B ENTRY
577  l = indexb(kdesc(1,kary(11)))
578  IF (l.LT.0) THEN
579  ierrtn = 2
580 C PRINT *,'W3FI85 - IERRTN = 2'
581  RETURN
582  END IF
583 C
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)
590 C
591  IF (text) THEN
592 C 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
597 C NBINC IS NUMBER OF CHARS
598  nbinc = kary(7) / 8
599 C 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
604 C HOW MANY FULL WORDS
605  nkpass = kary(7) / 32
606 C HOW MANY BYTES IN PARTIAL WORD
607  krem = mod(kary(7),32)
608 C KSKIP = KARY(7) - 32
609  DO 4080 nss = 1, isect3(1)
610 C POINT TO TEXT FOR THIS SUBSET
611  kary(2) = kary(11) + kary(18)
612  IF (nkpass.GE.1) THEN
613 C PROCESS TEXT IN A SUBSET
614  DO 4070 npp = 1, nkpass
615 C 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
622 C POINT TO NEXT DATA WORD FOR MORE TEXT
623  kary(2) = kary(2) + 1
624  4070 CONTINUE
625  END IF
626 C 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
636 C 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
642 C -------------------------------------------------------------
643  GO TO 5000
644  ELSE
645  kary(2) = kary(11) + kary(18)
646  kary(7) = kwidth(l) + kary(26)
647 C
648 C NON TEXT/NUMERIC DATA
649 C
650 C 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
661 C 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
667 C 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)
676 C ENTER NBINC
677  CALL sbyte (kbufr,nbinc,kary(3),6)
678  kary(3) = kary(3) + 6
679  ELSE
680 C MIX OF MISSING AND VALUES
681 C 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
711 C 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
728 C 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
733 C 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
747 C 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
754 C ---------------------------------------------------
755 C STANDARD DATA
756 C ---------------------------------------------------
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
768 C 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
774 C 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)
783 C ENTER NBINC
784  CALL sbyte (kbufr,nbinc,kary(3),6)
785  kary(3) = kary(3) + 6
786  ELSE
787 C MIX OF MISSING AND VALUES
788 C 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))
801 C PRINT *,' '
802 C PRINT *,'START VALUES',LOWEST,MAXVAL,
803 C * '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))
812 C PRINT *,'NEW LOWEST=',LOWEST,J
813  ELSE IF (kdata(j,kary(2)).GT.maxval) THEN
814  maxval = kdata(j,kary(2))
815 C PRINT *,'NEW MAXVAL=',MAXVAL,J
816  END IF
817  END IF
818  4036 CONTINUE
819  mxdiff = maxval - lowest
820 C 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
831 C PRINT 4444,KARY(11),KDESC(1,KARY(11)),LOWEST,
832 C * MAXVAL,MXDIFF,KARY(7),NBINC,ISECT3(1),ISECT3(7)
833 C4444 FORMAT(9(1X,I8))
834 C ENTER LOWEST
835 C 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
850 C 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
864 C 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
871 C -------------------------------------------------------------
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
881 C THE SEGMENT OF CODE BETWEEN STATEMENTS
882 C 5500-6000 ARE ACTIVATED IF AND WHEN THE
883 C MAXIMUM MESSAGE SIZE HAS BEEN EXCEEDED
884 C
885 C ARE WE REDUCING IF OVERSIZED ???
886  IF (isect3(4).NE.0) THEN
887 C INCREMENT REDUCTION COUNT
888  isect3(6) = isect3(6) + isect3(5)
889 C 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
899 C ---------------------------------------------------------------
900 C FILL IN SECTION 4 OCTET COUNT
901  nbufr = mod((kary(3) - kary(5)),16)
902 C 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)
908 C PRINT *,'SECTION 4'
909 C =====================================
910 C ENDING KEY '7777' - SECTION 5
911 C =====================================
912  kary(25) = 4
913  nbufr = 926365495
914  CALL sbyte (kbufr,nbufr,kary(3),32)
915  kary(3) = kary(3) + 32
916 C CONSTRUCT TOTAL BYTE COUNT FOR SECTION 0
917  itotal = kary(3) / 8
918  CALL sbyte (kbufr,itotal,32,24)
919  kary(30) = itotal
920 C WRITE (6,8601) ITOTAL
921  8601 FORMAT (1x,22hthis message CONTAINS ,i10,6h bytes)
922 C =======================================
923 C KBUFR CONTAINS A COMPLETED MESSAGE
924  IF (isect3(4).NE.0.AND.isect3(5).NE.0) THEN
925 C 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
938 C =======================================
939  ierrtn = 0
940  9000 CONTINUE
941  RETURN
942  END
943 C> @brief Perform replication of descriptors
944 C> @author Bill Cavanaugh @date 1993-12-03
945 
946 C> Have encountered a replication descriptor. It may include
947 C> delayed replication or not. That decision should have been
948 C> made prior to calling this routine.
949 C>
950 C> Program history log:
951 C> - Bill Cavanaugh 1993-12-03
952 C> - J. Hoppa 1994-03-25 Added line to initialize nxtptr to correct
953 C> an error in the standard replication.
954 C> - J. Hoppa 1994-03-28 Corrected an error in the standard replication
955 C> that was adding extra zeros to the bufr message after the replicated data.
956 C> - J. Hoppa 1994-03-31 Added the subset number to the parameter list.
957 C> corrected the equation for the number of replications with delayed replication.
958 C> (istart and k don't exist)
959 C> - J. Hoppa 1994-04-19 Switched the variables next and nxtprt
960 C> - J. Hoppa 1994-04-20 Added the kdata parameter counter to the parameter
961 C> list. In the assignment of nreps when have delayed replication, changed index
962 C> in kdata from n to k.
963 C> - J. Hoppa 1994-04-29 Removed n and k from the input list changed n to
964 C> kary(11) and k to kary(2)
965 C>
966 C> @param[in] ISTEP
967 C> @param[in] KCLASS
968 C> @param[in] KSEG
969 C> @param[in] IDATA
970 C> @param[in] RDATA
971 C> @param[in] KDATA
972 C> @param[in] NSUB Current subset
973 C> @param[inout] KDESC (modified [out]) List of descriptors
974 C> @param[inout] NRDESC Number of (new [out]) descriptors in kdesc
975 C> @param[out] IERRTN Error return value
976 C> @param KARY
977 C>
978 C> @author Bill Cavanaugh @date 1993-12-03
979  SUBROUTINE fi8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
980  * KDATA,NSUB,KDESC,NRDESC,IERRTN)
981 
982 C
983  REAL RDATA(*)
984 C
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
991 C
992  SAVE
993 C
994 C TEST KFUNC FOR DESCRIPTOR TYPE
995 C DO REPLICATION
996 C ****************************************************************
997  ierrtn = 0
998 C REPLICATION DESCRIPTOR
999 C STANDARD REPLICATION WILL SIMPLY
1000 C BE PROCESSED FROM ITS DESCRIPTOR
1001 C PARTS
1002 C
1003 C DELAYED REPLICATION DESCRIPTOR
1004 C MUST BE FOLLOWED BY ONE OF THE
1005 C DESCRIPTORS FOR A DELAYED
1006 C REPLICATION FACTOR
1007 C 0 31 001 (7937 DECIMAL)
1008 C 0 31 002 (7938 DECIMAL)
1009 C 0 31 011 (7947 DECIMAL)
1010 C 0 31 012 (7948 DECIMAL)
1011  IF (kseg.NE.0) THEN
1012 C 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
1022 C PRINT *,'HAVE DELAYED REPLICATION'
1023  kary(4) = 1
1024 C MOVE REPLICATION DEFINITION
1025  kdesc(1,kary(11)) = kdesc(1,kary(11)+1)
1026 C 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
1037 C POINT TO REPLICATION DESCRIPTOR
1038  END IF
1039  ELSE
1040  ierrtn = 10
1041  RETURN
1042  END IF
1043 C EXTRACT DESCRIPTORS TO BE REPLICATED
1044 C IF NREPS = 0, THIS LIST OF DESCRIPTORS IS NOT TO
1045 C BE USED IN DEFINING THE DATA,
1046 C OTHERWISE
1047 C 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
1053 C SKIP THE NUMBER OF DESCRIPTORS DEFINED BY KCLASS
1054  END IF
1055 C SAVE OFF TAIL OF DESC STREAM
1056 C 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
1062 C 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
1071 C RESTORE TAIL
1072  DO 1400 itl = 1, igot
1073  kdesc(1,iput) = itail(itl)
1074  iput = iput + 1
1075  1400 CONTINUE
1076 C
1077 C RESET NUMBER OF DESCRIPTORS IN KDESC
1078  nrdesc = iput - 1
1079 C ****************************************************************
1080  RETURN
1081  END
1082 C> @brief Process an operator descriptor.
1083 C> @author Bill Cavanaugh @date 193-12-03
1084 
1085 C> Have encountered an operator descriptor.
1086 C>
1087 C> Program history log:
1088 C> - Bill Cavanaugh 1993-12-03
1089 C> - J. Hoppa 1994-04-15 Added kbufr to input parameter list.
1090 C> added block of data to correctly use sbyte when writing a 205yyy descriptor to the
1091 C> bufr message. The previous way didn't work because kdata was getting incremeted
1092 C> by the ksub value, not the param value.
1093 C> - J. Hoppa 1994-04-29 Changed k to kary(2) removed a line that became obsolete with
1094 C> above change
1095 C> - J. Hoppa 1994-05-18 Added a kary(2) increment
1096 C>
1097 C> @param[in] KCLASS
1098 C> @param[in] KSEG
1099 C> @param[inout] KDESC
1100 C> @param[inout] NRDESC
1101 C> @param[in] I
1102 C> @param[in] ISTEP
1103 C> @param[inout] KARY
1104 C> @param[out] IERRTN Error return value
1105 C> @param KBUFR
1106 C> @param KDATA
1107 C> @param ISECT3
1108 C> @param KRFVSW
1109 C> @param NEWRFV
1110 C> @param LDESC
1111 C> @param INDEXB
1112 C>
1113 C> @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 
1117 C
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
1125 C
1126  SAVE
1127 C
1128  DATA zeroes/255*0/
1129 C
1130 C ****************************************************************
1131  ierrtn = 0
1132 C OPERATOR DESCRIPTOR
1133  IF (kclass.EQ.1) THEN
1134 C 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
1143 C 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
1152 C CHANGE REFERENCE VALUE
1153 C MUST ACCEPT INTO OUTPUT THE
1154 C REFERENCE VALUE CHANGE AND ACTIVATE
1155 C THE CHANGE WHILE PROCESSING
1156  IF (istep.EQ.3) THEN
1157 C HAVE OPERATOR DESCRIPTOR FOR REFERENCE VALUES
1158  IF (kseg.EQ.0) THEN
1159  DO 100 iq = 1, isect3(8)
1160 C RESET ALL NEW REFERENCE VALUES
1161  krfvsw(iq) = 0
1162  100 CONTINUE
1163  END IF
1164  200 CONTINUE
1165 C GET NEXT DESCRIPTOR
1166  kary(11) = kary(11) + 1
1167  IF (kdesc(1,kary(11)).GT.16383) THEN
1168 C 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
1189 C ELEMENT DESCRIPTOR W/NEW REFERENCE VALUE
1190 C 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
1201 C 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
1206 C SET TO PROCESS TEXT/ASCII DATA
1207 C SET TO TEXT
1208 C PROCESS TEXT
1209 
1210  kary(2) = kary(11) + kary(18)
1211  IF (istep.EQ.3) THEN
1212 C 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
1218 C POINT AT CORRECT KDATA WORD
1219  IF (isect3(3).NE.0) THEN
1220 C COMPRESSED
1221 C ---------------------------------------------------
1222  CALL sbytes(kbufr,zeroes,kary(3),32,0,iter)
1223  kary(3) = kary(3) + kseg * 8
1224 C
1225  CALL sbyte (kbufr,kseg*8,kary(3),6)
1226  kary(3) = kary(3) + 6
1227 C TEXT ENTRY BY SUBSET
1228  DO 2000 m = 1, isect3(1)
1229  jay = kary(3)
1230 C NUMBER OF SUBSETS
1231  DO 1950 kl = 1, iter
1232 C 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
1242 C ---------------------------------------------------
1243  ELSE
1244 C NOT COMPRESSED
1245 
1246 C CALL SBYTE FOR EACH KDATA VALUE (4 CHARACTERS PER VALUE).
1247 C AN ADDITIONAL CALL IS DONE IF HAVE A VALUE WITH LESS THAN
1248 C 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 
1262 C 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
1268 C SET TO SKIP PROCESSING OF NEXT DESCRIPTOR
1269 C IF IT IS NOT IN BUFR TABLE B
1270 C DURING THE ENCODING PROCESS, THIS HAS NO MEANING
1271 C ELIMINATE IN PROCESSING
1272 C MOVE DESCRIPTOR LIST UP ONE POSITION AND RESTART
1273 C 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
1282 C ****************************************************************
1283  RETURN
1284  END
1285 C> @brief Expand sequence descriptor.
1286 C> @author Bill Cavanaugh @date 1993-12-03
1287 
1288 C> Have encountered a sequence descriptor. must perform proper replacment of
1289 C> descriptors in line.
1290 C>
1291 C> Program history log:
1292 C> - Bill Cavanaugh 1993-12-03
1293 C>
1294 C> @param[inout] I Current position in descriptor list
1295 C> @param[inout] KDESC List (modified [out]) of descriptors
1296 C> @param[inout] NRDESC Number (new [out]) of descriptors in kdesc
1297 C> @param[in] IUNITD
1298 C> @param[in] KSEQ
1299 C> @param[in] KNUM
1300 C> @param[in] KLIST
1301 C> @param[out] IERRTN Error return value
1302 C> @param ISECT3
1303 C>
1304 C> @author Bill Cavanaugh @date 1993-12-03
1305  SUBROUTINE fi8503(I,KDESC,NRDESC,
1306  * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
1307 
1308 C
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)
1319 C INTEGER IHOLD(200)
1320 C
1321  SAVE
1322 C
1323 C ****************************************************************
1324  ierrtn = 0
1325 C 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
1330 C PRINT *,'EXIT FI8503A'
1331  RETURN
1332  END IF
1333  END IF
1334 C HAVE TABLE D
1335 C
1336 C FIND MATCHING SEQUENCE DESCRIPTOR
1337  DO 100 l = 1, isect3(9)
1338  IF (kdesc(1,i).EQ.kseq(l)) THEN
1339 C JEN - DELETE NEXT PRINT LINE
1340 C PRINT *,'FOUND ',KDESC(1,I)
1341 C HAVE A MATCH
1342  GO TO 200
1343  END IF
1344  100 CONTINUE
1345  ierrtn = 12
1346  RETURN
1347  200 CONTINUE
1348 C REPLACE SEQUENCE DESCRIPTOR WITH IN LINE SEQUENCE
1349  iput = i
1350 C 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
1357 C INSERT SEQUENCE OF DESCRIPTORS AT
1358 C 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 
1365 C RESTORE TAIL
1366  DO 800 kl = 1, kk
1367  kdesc(1,iput) = itail(kl)
1368  iput = iput + 1
1369  800 CONTINUE
1370 C RESET NUMBER OF DESCRIPTORS IN KDESC
1371  nrdesc = iput - 1
1372 C JEN - DELETE NEXT PRINT LINE
1373 C PRINT *,' NRDESC IS ',NRDESC
1374 
1375 C RESET CURRENT POSITION & RETURN
1376  RETURN
1377  END
1378 C> @brief Convert descriptors fxy to decimal
1379 C> @author Bill Cavanaugh @date 1993-12-03
1380 
1381 C> Construct decimal descriptor values from f x and y segments
1382 C>
1383 C> Program history log:
1384 C> - Bill Cavanaugh 1993-12-03
1385 C>
1386 C> @param[in] MIF input flag
1387 C> @param[inout] MDESC list of descriptors in f x y (decimal [out]) form
1388 C> @param[in] NR number of descriptors in mdesc
1389 C> @param[out] IERRTN error return value
1390 C>
1391 C> @author Bill Cavanaugh @date 1993-12-03
1392  SUBROUTINE fi8505(MIF,MDESC,NR,IERRTN)
1393 
1394 C
1395  INTEGER MDESC(3,*), NR
1396 C
1397  SAVE
1398 C
1399  IF (nr.EQ.0) THEN
1400  ierrtn = 14
1401  RETURN
1402  END IF
1403 C
1404  DO 100 i = 1, nr
1405  mdesc(1,i) = mdesc(1,i) * 16384 + mdesc(2,i) * 256
1406  * + mdesc(3,i)
1407 C JEN - DELETE NEXT PRINT LINE
1408 C PRINT *,MDESC(2,I),MDESC(3,I),' BECOMES ',MDESC(1,I)
1409  100 CONTINUE
1410  mif = 1
1411  RETURN
1412  END
1413 C> @brief Process data in non-compressed format
1414 C> @author Bill Cavanaugh @date 1993-12-03
1415 
1416 C> Process data into non-compressed format for inclusion into
1417 C> section 4 of the bufr message
1418 C>
1419 C> Program history log:
1420 C> - Bill Cavanaugh 1993-12-03
1421 C> - J. Hoppa 1994-03-24 Changed the inner loop from a do loop to a
1422 C> goto loop so nrdesc isn't a set value.
1423 C> corrected a value in the call to fi8503().
1424 C> - J. Hoppa 1994-03-31 Corrected an error in sending the subset
1425 C> number rather than the descriptor number
1426 C> to subroutine fi8501(). Added the subset number to the fi8501() parameter list.
1427 C> - J. Hoppa 1994-04015 Added line to keep the parameter pointer
1428 C> kary(2) up to date. this variable is used
1429 C> in subroutine fi8502().
1430 C> added kbufr to the parameter list in the call
1431 C> to subroutine fi8502().
1432 C> corrected an infinite loop when have an
1433 C> operator descriptor that was caused by
1434 C> a correction made 94-03-24
1435 C> - J. Hoppa 1994-04-20 Added k to call to subroutine w3fi01
1436 C> - J. Hoppa 1994-04-29 Changed n to kary(11) and k to kary(2)
1437 C> removed k and n from the call to fi8501()
1438 C> - J. Hoppa 1994-05-03 Added an increment to kary(11) to prevent
1439 C> and infinite loop when have a missing value
1440 C> - J. Hoppa 1994-05-18 Changed so increments kary(2) after each
1441 C> call to sbyte and deleted
1442 C> kary(2) = kary(11) + kary(18)
1443 C>
1444 C> @param[in] ISTEP
1445 C> @param[in] ISECT3
1446 C> @param[in] KARY
1447 C> @param[in] JDESC
1448 C> @param[in] NEWNR
1449 C> @param[in] KDESC
1450 C> @param[in] NRDESC
1451 C> @param[in] LDESC
1452 C> @param[in] ANAME
1453 C> @param[in] AUNITS
1454 C> @param[in] KSCALE
1455 C> @param[in] KRFVAL
1456 C> @param[in] KWIDTH
1457 C> @param[in] KRFVSW
1458 C> @param[in] NEWRFV
1459 C> @param[in] KSEQ
1460 C> @param[in] KNUM
1461 C> @param[in] KLIST
1462 C> @param[out] KDATA
1463 C> @param[out] KBUFR
1464 C> @param[out] IERRTN
1465 C> @param IBFSIZ
1466 C> @param INDEXB
1467 C>
1468 C> @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 
1474 C
1475 C -------------------------------------------------------------
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
1492 C
1493  SAVE
1494 C -------------------------------------------------------------
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/
1505 C -------------------------------------------------------------
1506  kend = ibfsiz * 8 - 32
1507 C **********************************************
1508 C * *
1509 C * PROCESS AS NON-COMPRESSED MESSAGE *
1510 C * *
1511 C * I POINTS TO SUBSET *
1512 C * N POINTS TO DESCRIPTOR *
1513 C * K ADJUSTS N TO CORRECT DATA ENTRY *
1514 C * *
1515 C **********************************************
1516  DO 4500 i = 1, isect3(1)
1517 C OUTER LOOP FOR EACH SUBSET
1518 C DO UNTIL ALL DESCRIPTORS HAVE
1519 C BEEN PROCESSED
1520 C SET ADDED BIT FOR WIDTH TO 0
1521  kary(26) = 0
1522 C SET ASSOCIATED FIELD WIDTH TO 0
1523  kary(27) = 0
1524  kary(18) = 0
1525 C IF MESSAGE CONTAINS DELAYED REPLICATION
1526 C WE NEED TO EXPAND THE ORIGINAL DESCRIPTOR LIST
1527 C TO MATCH THE INPUT DATA.
1528 C 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
1539 C INNER LOOP FOR PARAMETER
1540  4200 CONTINUE
1541 C KARY(2) = KARY(11) + KARY(18)
1542 C PRINT *,'LOOKING AT DESCRIPTOR',KARY(11),
1543 C * KDESC(1,KARY(11)),
1544 C * KARY(2),KDATA(I,KARY(2))
1545 C
1546 C PROCESS ONE DESCRIPTOR AT A TIME
1547 C
1548 C ISOLATE TABLE
1549 C
1550  kfunc = kdesc(1,kary(11)) / 16384
1551 C 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
1555 C 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
1563 C 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
1573 C 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
1581 C FALL THRU WITH ELEMENT DESCRIPTOR
1582 C FIND MATCHING TABLE B ENTRY
1583  lk = indexb(kdesc(1,kary(11)))
1584  IF (lk.LT.1) THEN
1585 C 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
1591 C
1592  IF (aunits(lk).EQ.ccitt) THEN
1593  text = .true.
1594  ELSE
1595  text = .false.
1596  END IF
1597 C
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
1611 C ADD A WORD HERE ONLY
1612  kary(18) = kary(18) + 1
1613 C 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
1642 C NOT TEXT
1643  IF (kary(27).NE.0.AND.kdesc(1,kary(11)).NE.7957) THEN
1644 C 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
1653 C KARY(2) = KARY(11) + KARY(18)
1654  kary(2) = kary(2) + 1
1655  END IF
1656 C
1657  jwide = kwidth(lk) + kary(26)
1658  IF (kdata(i,kary(2)).EQ.misg) THEN
1659 C 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
1670 C CAN DATA BE CONTAINED IN SPECIFIED
1671 C BIT WIDTH, IF NOT - ERROR
1672  IF (kdata(i,kary(2)).GT.ibits(jwide)) THEN
1673  ierrtn = 1
1674  RETURN
1675  END IF
1676 C ADJUST WITH REFERENCE VALUE
1677  IF (krfvsw(lk).EQ.0) THEN
1678  jrv = krfval(lk)
1679  ELSE
1680  jrv = newrfv(lk)
1681  END IF
1682 C
1683  kdata(i,kary(2)) = kdata(i,kary(2)) - jrv
1684 C IF NEW VALUE IS NEGATIVE - ERROR
1685  IF (kdata(i,kary(2)).LT.0) THEN
1686  ierrtn = 11
1687  RETURN
1688  END IF
1689 C 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
1701 C 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
1708 C> @brief Combine integer/text data
1709 C> @author Bill Cavanaugh @date 1993-12-03
1710 
1711 C> Construct integer subset from real and text data
1712 C>
1713 C> Program history log:
1714 C> - Bill Cavanaugh 1993-12-03
1715 C> - J. Hoppa 1994-03-31 added ksub to fi8501() parameter list.
1716 C> - J. Hoppa 1994-04-18 added dummy variable idum to fi8502() parameter list.
1717 C> - J. Hoppa 1994-04-20 added dummy variable ll to fi8501() parameter list.
1718 C> - J. Hoppa 1994-04-29 changed i to kary(11) added a kary(2) assignment so have something
1719 C> to pass to subroutines ** test this ** removed i and ll from call to fi8501()
1720 C> - J. Hoppa 1994-05-13 added code to calculate kwords when kfunc=2
1721 C> - J. Hoppa 1994-05-18 deleted kary(2) assignment
1722 C>
1723 C> @param[in] ISTEP
1724 C> @param[in] IUNITB Unit number of device containing table b
1725 C> @param[in] IDATA Integer working array
1726 C> @param[in] KDESC Expanded descriptor set
1727 C> @param[in] NRDESC Number of descriptors in kdesc
1728 C> @param[in] ATEXT Text data for ccitt ia5 and text operator fields
1729 C> @param[in] KSUB Subset number
1730 C> @param[in] KARY Working array
1731 C> @param[in] ISECT3
1732 C> @param[out] KDATA Array containing integer subsets
1733 C> @param[out] LDESC List of table b descriptors (decimal)
1734 C> @param[out] ANAME List of descriptor names
1735 C> @param[out] AUNITS Units for each descriptor
1736 C> @param[out] KSCALE Base 10 scale factor for each descriptor
1737 C> @param[out] KRFVAL Reference value for each descriptor
1738 C> @param[out] KRFVSW
1739 C> @param[out] KWIDTH Standard bit width to contain each value for specific descriptor
1740 C> @param[out] KASSOC
1741 C> @param[out] IERRTN Error return flag
1742 C> @param IUNITD
1743 C> @param KSEQ
1744 C> @param KNUM
1745 C> @param KLIST
1746 C> @param INDEXB
1747 C>
1748 C> @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 
1753 C TAKE EACH NON-TEXT ENTRY OF SECTION 2
1754 C ACCEPT IT
1755 C
1756 C TAKE EACH TEXT ENTRY
1757 C INSERT INTO INTEGER ARRAY,
1758 C ADDING FULL WORDS AS NECESSARY
1759 C MAKE SURE ANY LAST WORD HAS TEXT DATA
1760 C RIGHT JUSTIFIED
1761 C ---------------------------------------------------------------------
1762 C PASS BACK CONVERTED ENTRY TO LOCATION
1763 C SPECIFIED BY USER
1764 C
1765 C REFERENCE VALUE WILL BE APPLIED DURING
1766 C ENCODING OF MESSAGE
1767 C ---------------------------------------------------------------------
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(*)
1788 C
1789  SAVE
1790 C
1791  equivalence(ahold1,ihold4)
1792 C
1793 C =====================================
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/
1804 C
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
1813 C HAVE TABLE B AVAILABLE NOW
1814 C
1815 C LOOK AT EACH DATA ENTRY
1816 C CONVERT NON TEXT
1817 C MOVE TEXT
1818 C
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
1825 C
1826 C RE-ENTRY POINT FOR REPLICATION AND SEQUENCE DESCR'S
1827 C
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)
1833 C KARY(2) = KARY(11) + KARY(18)
1834  IF (kfunc.EQ.1) THEN
1835 C 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
1844 C HANDLE TEXT OPERATORS
1845 CC
1846  kavail = idata(kary(11))
1847 C 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
1854 CC
1855  jwide = kseg * 8
1856  GO TO 1200
1857  END IF
1858  ELSE IF (kfunc.EQ.3) THEN
1859 C 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
1867 C
1868 C FIND MATCHING DESCRIPTOR
1869 C
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
1877 C 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
1883 C 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
1892 C IF NOT MISSING DATA
1893  IF (idata(kary(11)).EQ.99999) THEN
1894  kpos = kpos + 1
1895  kdata(ksub,kpos) = misg
1896  ELSE
1897 C PROCESS INTEGER VALUES
1898  kpos = kpos + 1
1899  kdata(ksub,kpos) = idata(kary(11))
1900  END IF
1901  ELSE
1902 C PROCESS TEXT
1903 C NUMBER OF BYTES REQUIRED BY TABLE B
1904  kreq = kwidth(k) / 8
1905 C NUMBER BYTES AVAILABLE IN ATEXT
1906  kavail = idata(kary(11))
1907 C 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
1914 C 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
1933 C> @brief Convert real/text input to integer
1934 C> @author Bill Cavanaugh @date 1993-12-03
1935 
1936 C> Construct integer subset from real and text data.
1937 C>
1938 C> Program history log:
1939 C> - Bill Cavanaugh 1993-12-03
1940 C> - J. Hoppa 1994-03-31 Added ksub to the fi8501 parameter list.
1941 C> - J. Hoppa 1994-04-18 Added dummy variable idum to fi8502 parameter list.
1942 C> - J. Hoppa 1994-04-20 Added dummy variable ll to fi8501 parameter list.
1943 C> - J. Hoppa 1994-04-29 Changed i to kary(11) added a kary(2) assignment so have something
1944 C> to pass to subroutines ** test this ** removed i and ll from call to fi8501
1945 C> - J. Hoppa 1994-05-18 Deleted kary(2) assignment
1946 C>
1947 C> @param[in] IUNITB unit number of device containing table b
1948 C> @param[in] RDATA real working array
1949 C> @param[in] KDESC expanded descriptor set
1950 C> @param[in] NRDESC number of descriptors in kdesc
1951 C> @param[in] ATEXT text data for ccitt ia5 and text operator fields
1952 C> @param[in] KSUB subset number
1953 C> @param[in] KARY working array
1954 C> @param[in] ISECT3
1955 C> @param[in] IUNITD
1956 C> @param[out] KDATA Array containing integer subsets
1957 C> @param[out] LDESC List of table b descriptors (decimal)
1958 C> @param[out] ANAME List of descriptor names
1959 C> @param[out] AUNITS Units for each descriptor
1960 C> @param[out] KSCALE Base 10 scale factor for each descriptor
1961 C> @param[out] KRFVAL Reference value for each descriptor
1962 C> @param[out] KRFVSW
1963 C> @param[out] KASSOC
1964 C> @param[out] KWIDTH Standard bit width to contain each value for specific descriptor
1965 C> @param[out] IERRTN Error return flag
1966 C> @param[out] KNUM
1967 C> @param[out] KLIST
1968 C> @param ISTEP
1969 C> @param KSEQ
1970 C> @param INDEXB
1971 C>
1972 C> @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 
1977 C TAKE EACH NON-TEXT ENTRY OF SECTION 2
1978 C SCALE IT
1979 C ROUND IT
1980 C CONVERT TO INTEGER
1981 C
1982 C TAKE EACH TEXT ENTRY
1983 C INSERT INTO INTEGER ARRAY,
1984 C ADDING FULL WORDS AS NECESSARY
1985 C MAKE SURE ANY LAST WORD HAS TEXT DATA
1986 C RIGHT JUSTIFIED
1987 C PASS BACK CONVERTED ENTRY TO LOCATION
1988 C SPECIFIED BY USER
1989 C
1990 C REFERENCE VALUE WILL BE APPLIED DURING
1991 C ENCODING OF MESSAGE
1992 C ---------------------------------------------------------------------
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(*)
2016 C
2017  SAVE
2018 C =====================================
2019  equivalence(ahold1,ihold4)
2020 C
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'/
2029 C
2030  DATA ccitt /'CCITT IA5 '/
2031  DATA misg /99999/
2032 C =====================================
2033 C
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
2042 C HAVE TABLE B AVAILABLE NOW
2043 C
2044 C LOOK AT EACH DATA ENTRY
2045 C CONVERT NON TEXT
2046 C MOVE TEXT
2047 C
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
2054 C RE-ENRY POINT FOR REPLICATION AND
2055 C 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)
2061 C KARY(2) = KARY(11) + KARY(18)
2062  IF (kfunc.EQ.1) THEN
2063 C 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
2071 C HANDLE OPERATORS
2072  IF (kclass.EQ.5) THEN
2073 C NUMBER BYTES AVAILABLE IN ATEXT
2074  kavail = rdata(kary(11))
2075 C 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
2093 C 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
2101 C
2102 C FIND MATCHING DESCRIPTOR
2103 C
2104  k = indexb(kdesc(1,kary(11)))
2105  IF (k.LT.1) THEN
2106  ierrtn = 2
2107 C PRINT *,'FI8509 - IERRTN = 2'
2108  RETURN
2109  END IF
2110 C 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
2116 C 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
2125 C IF NOT MISSING DATA
2126  IF (rdata(kary(11)).EQ.99999.) THEN
2127  kpos = kpos + 1
2128  kdata(ksub,kpos) = misg
2129  ELSE
2130 C PROCESS REAL VALUES
2131  IF (kscale(k).NE.0) THEN
2132 C 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
2140 C PERFORM ROUNDING
2141  rdata(kary(11)) = rdata(kary(11)) +
2142  * sign(0.5,rdata(kary(11)))
2143 C CONVERT TO INTEGER
2144  kpos = kpos + 1
2145  kdata(ksub,kpos) = rdata(kary(11))
2146 C
2147  END IF
2148  ELSE
2149 C PROCESS TEXT
2150 C NUMBER OF BYTES REQUIRED BY TABLE B
2151  kreq = kwidth(k) / 8
2152 C NUMBER BYTES AVAILABLE IN ATEXT
2153  kavail = rdata(kary(11))
2154 C 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
2161 C 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
2178 C DO 2000 I = 1, KPOS
2179 C2000 CONTINUE
2180  RETURN
2181  END
2182 C> @brief Rebuild kdesc from jdesc
2183 C> @author Bill Cavanaugh @date 1993-12-03
2184 
2185 C> Construct working descriptor list from list of descriptors in section 3.
2186 C>
2187 C> Program history log:
2188 C> - Bill Cavanaugh 1993-12-03
2189 C>
2190 C> @param[in] ISECT3
2191 C> @param[in] KARY Utility - array see main routine
2192 C> @param[in] JIF Descriptor input form flag
2193 C> @param[in] JDESC List of descriptors for section 3
2194 C> @param[in] NEWNR Number of descriptors in jdesc
2195 C> @param[out] KIF Descriptor form
2196 C> @param[out] KDESC Working list of descriptors
2197 C> @param[out] NRDESC Number of descriptors in kdesc
2198 C> @param[out] IERRTN Error return
2199 C> - IERRTN = 0 Normal return
2200 C> - IERRTN = 5 Found delayed replication during expansion
2201 C>
2202 C> @author Bill Cavanaugh @date 1993-12-03
2203  SUBROUTINE fi8511(ISECT3,KARY,JIF,JDESC,NEWNR,
2204  * KIF,KDESC,NRDESC,IERRTN)
2205 
2206 C
2207  INTEGER JDESC(3,*), NEWNR, KDESC(3,*), NRDESC
2208  INTEGER KARY(*),IERRTN,KIF,JIF
2209  INTEGER ISECT3(*)
2210 C
2211  SAVE
2212 C
2213  IF (NEWNR.EQ.0) THEN
2214  IERRTN = 3
2215  return
2216  END IF
2217 C
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
2235 C> @brief Read in table B
2236 C> @author Bill Cavanaugh @date 1993-12-03
2237 
2238 C> Read in tailored set of table B descriptors.
2239 C>
2240 C> Program history log:
2241 C> - Bill Cavanaugh 1993-12-03
2242 C> - J. Hoppa 1994-04-18 An error has been corrected to prevent later
2243 C> searching table b if there are only operator
2244 C> descriptors in the descriptor list.
2245 C> - J. Hoppa 1994-05-17 Changed the loop for expanding sequence
2246 C> descriptors from a do loop to a goto loop
2247 C>
2248 C> @param[in] IUNITB Unit where table b entries reside
2249 C> @param[in] KDESC Working descriptor list
2250 C> @param[in] NRDESC Number of descriptors in kdesc
2251 C> @param[in] IUNITD Unit where table d entries reside
2252 C> @param[out] KARY
2253 C> @param[out] IERRTN
2254 C> @param[out] LDESC Descriptors in table b (decimal values)
2255 C> @param[out] ANAME Array containing names of descriptors
2256 C> @param[out] AUNITS Array containing units of descriptors
2257 C> @param[out] KSCALE Scale values for each descriptor
2258 C> @param[out] KRFVAL Reference values for each descriptor
2259 C> @param[out] KWIDTH Bit width of each descriptor
2260 C> @param[out] KRFVSW New reference value switch
2261 C> @param[out] KSEQ Sequence descriptor
2262 C> @param[out] KNUM Number of descriptors in sequence
2263 C> @param[out] KLIST Sequence of descriptors
2264 C> @param ISECT3
2265 C> @param INDEXB
2266 C>
2267 C> @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 
2272 C
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(*)
2279 C
2280  INTEGER MDESC(800),MR,I,J
2281 C
2282  SAVE
2283 C
2284 C ===================================================================
2285  ierrtn = 0
2286  DO 100 i = 1, 30
2287  kary(i) = 0
2288  100 CONTINUE
2289 C INITIALIZE DESCRIPTOR POINTERS TO MISSING
2290  DO 105 i = 1, 16383
2291  indexb(i) = -1
2292  105 CONTINUE
2293 C
2294 C ===================================================================
2295 C MAKE A COPY OF THE DESCRIPTOR LIST
2296 C 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
2305 C ===================================================================
2306 C REPLACE ALL SEQUENCE DESCRIPTORS
2307 C JEN - FIXED NEXT BLOCK
2308 C 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
2323 C 300 CONTINUE
2324 C ===================================================================
2325 C ISOLATE SINGLE COPIES OF DESCRIPTORS
2326  mr = 1
2327 C THE FOLLOWING LINE IS TO PREVENT LATER SEARCHING TABLE B WHEN
2328 C 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
2340 C ===================================================================
2341 C SORT INTO ASCENDING ORDER
2342 C 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
2355 C ===================================================================
2356  rewind iunitb
2357 C
2358 C READ IN A MODIFIED TABLE B -
2359 C MODIFIED TABLE B CONTAINS ONLY
2360 C THOSE DESCRIPTORS ASSOCIATED WITH
2361 C CURRENT DATA.
2362 C
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
2371 C
2372  IF (ldesc(nrtblb).EQ.mdesc(nrtblb)) THEN
2373 C PRINT *,'1001',NRTBLB,LDESC(NRTBLB)
2374 C PRINT *,LDESC(NRTBLB),ANAME(NRTBLB),KSCALE(NRTBLB),
2375 C * KRFVAL(NRTBLB),KWIDTH(NRTBLB)
2376  ktry = ktry + 1
2377  indexb(ldesc(nrtblb)) = ktry
2378 C PRINT *,'INDEX(',LDESC(NRTBLB),' = ',KTRY
2379  ELSE IF (ldesc(nrtblb).GT.mdesc(nrtblb)) THEN
2380 C 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
2392 C DO 1998 I = 1, 16383, 30
2393 C WRITE (6,1999) (INDEXB(I+J),J=0,23)
2394 C1998 CONTINUE
2395 C1999 FORMAT(30(1X,I3))
2396 C
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
2406 C> @brief Read in table D
2407 C> @author Bill Cavanaugh @date 1993-12-03
2408 
2409 C> Read in table D
2410 C>
2411 C> Program history log:
2412 C> - Bill Cavanaugh 1993-12-03
2413 C>
2414 C> @param[in] IUNITD Unit number of input device
2415 C> @param[out] KSEQ Key for sequence descriptors
2416 C> @param[out] KNUM Number if descriptors in list
2417 C> @param[out] KLIST Descriptors list
2418 C> @param[out] IERRTN Error return flag
2419 C> @param ISECT3
2420 C>
2421 C> @author Bill Cavanaugh @date 1993-12-03
2422  SUBROUTINE fi8513 (IUNITD,ISECT3,KSEQ,KNUM,KLIST,IERRTN)
2423 
2424 C
2425  INTEGER IUNITD, ISECT3(*)
2426  INTEGER KSEQ(*),KNUM(*),KLIST(300,*)
2427  INTEGER KKF(10),KKX(10),KKY(10),KF,KX,KY
2428 C
2429  SAVE
2430 C
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
2448 C BUILD SEQUENCE KEY
2449  kseq(j) = 16384*kf + 256*kx + ky
2450  DO 2000 lm = 1, 10
2451 C 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
fi8513
subroutine fi8513(IUNITD, ISECT3, KSEQ, KNUM, KLIST, IERRTN)
Read in table D.
Definition: w3fi85.f:2423
fi8501
subroutine fi8501(KARY, ISTEP, KCLASS, KSEG, IDATA, RDATA, KDATA, NSUB, KDESC, NRDESC, IERRTN)
Perform replication of descriptors.
Definition: w3fi85.f:981
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
fi8503
subroutine fi8503(I, KDESC, NRDESC, ISECT3, IUNITD, KSEQ, KNUM, KLIST, IERRTN)
Expand sequence descriptor.
Definition: w3fi85.f:1307
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
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
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
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
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
fi8511
subroutine fi8511(ISECT3, KARY, JIF, JDESC, NEWNR, KIF, KDESC, NRDESC, IERRTN)
Rebuild kdesc from jdesc.
Definition: w3fi85.f:2205