| blob | 3e9ea2cbaa09285a1730115d116b1a9b2ac70887 |
1 SUBROUTINE PACK_GP(KFILDO,IC,NXY,IS523,MINPK,INC,MISSP,MISSS,
2 1 JMIN,JMAX,LBIT,NOV,NDG,LX,IBIT,JBIT,KBIT,
3 2 NOVREF,LBITREF,IER)
4 C
5 C FEBRUARY 1994 GLAHN TDL MOS-2000
6 C JUNE 1995 GLAHN MODIFIED FOR LMISS ERROR.
7 C JULY 1996 GLAHN ADDED MISSS
8 C FEBRUARY 1997 GLAHN REMOVED 4 REDUNDANT TESTS FOR
9 C MISSP.EQ.0; INSERTED A TEST TO BETTER
10 C HANDLE A STRING OF 9999'S
11 C FEBRUARY 1997 GLAHN ADDED LOOPS TO ELIMINATE TEST FOR
12 C MISSS WHEN MISSS = 0
13 C MARCH 1997 GLAHN CORRECTED FOR SECONDARY MISSING VALUE
14 C MARCH 1997 GLAHN CORRECTED FOR USE OF LOCAL VALUE
15 C OF MINPK
16 C MARCH 1997 GLAHN CORRECTED FOR SECONDARY MISSING VALUE
17 C MARCH 1997 GLAHN CHANGED CALCULATING NUMBER OF BITS
18 C THROUGH EXPONENTS TO AN ARRAY (IMPROVED
19 C OVERALL PACKING PERFORMANCE BY ABOUT
20 C 35 PERCENT!). ALLOWED 0 BITS FOR
21 C PACKING JMIN( ), LBIT( ), AND NOV( ).
22 C MAY 1997 GLAHN A NUMBER OF CHANGES FOR EFFICIENCY.
23 C MOD FUNCTIONS ELIMINATED AND ONE
24 C IFTHEN ADDED. JOUNT REMOVED.
25 C RECOMPUTATION OF BITS NOT MADE UNLESS
26 C NECESSARY AFTER MOVING POINTS FROM
27 C ONE GROUP TO ANOTHER. NENDB ADJUSTED
28 C TO ELIMINATE POSSIBILITY OF VERY
29 C SMALL GROUP AT THE END.
30 C ABOUT 8 PERCENT IMPROVEMENT IN
31 C OVERALL PACKING. ISKIPA REMOVED;
32 C THERE IS ALWAYS A GROUP B THAT CAN
33 C BECOME GROUP A. CONTROL ON SIZE
34 C OF GROUP B (STATEMENT BELOW 150)
35 C ADDED. ADDED ADDA, AND USE
36 C OF GE AND LE INSTEAD OF GT AND LT
37 C IN LOOPS BETWEEN 150 AND 160.
38 C IBITBS ADDED TO SHORTEN TRIPS
39 C THROUGH LOOP.
40 C MARCH 2000 GLAHN MODIFIED FOR GRIB2; CHANGED NAME FROM
41 C PACKGP
42 C JANUARY 2001 GLAHN COMMENTS; IER = 706 SUBSTITUTED FOR
43 C STOPS; ADDED RETURN1; REMOVED STATEMENT
44 C NUMBER 110; ADDED IER AND * RETURN
45 C NOVEMBER 2001 GLAHN CHANGED SOME DIAGNOSTIC FORMATS TO
46 C ALLOW PRINTING LARGER NUMBERS
47 C NOVEMBER 2001 GLAHN ADDED MISSLX( ) TO PUT MAXIMUM VALUE
48 C INTO JMIN( ) WHEN ALL VALUES MISSING
49 C TO AGREE WITH GRIB STANDARD.
50 C NOVEMBER 2001 GLAHN CHANGED TWO TESTS ON MISSP AND MISSS
51 C EQ 0 TO TESTS ON IS523. HOWEVER,
52 C MISSP AND MISSS CANNOT IN GENERAL BE
53 C = 0.
54 C NOVEMBER 2001 GLAHN ADDED CALL TO REDUCE; DEFINED ITEST
55 C BEFORE LOOPS TO REDUCE COMPUTATION;
56 C STARTED LARGE GROUP WHEN ALL SAME
57 C VALUE
58 C DECEMBER 2001 GLAHN MODIFIED AND ADDED A FEW COMMENTS
59 C JANUARY 2002 GLAHN REMOVED LOOP BEFORE 150 TO DETERMINE
60 C A GROUP OF ALL SAME VALUE
61 C JANUARY 2002 GLAHN CHANGED MALLOW FROM 9999999 TO 2**30+1,
62 C AND MADE IT A PARAMETER
63 C MARCH 2002 GLAHN ADDED NON FATAL IER = 716, 717;
64 C REMOVED NENDB=NXY ABOVE 150;
65 C ADDED IERSAV=0; COMMENTS
66 C
67 C PURPOSE
68 C DETERMINES GROUPS OF VARIABLE SIZE, BUT AT LEAST OF
69 C SIZE MINPK, THE ASSOCIATED MAX (JMAX( )) AND MIN (JMIN( )),
70 C THE NUMBER OF BITS NECESSARY TO HOLD THE VALUES IN EACH
71 C GROUP (LBIT( )), THE NUMBER OF VALUES IN EACH GROUP
72 C (NOV( )), THE NUMBER OF BITS NECESSARY TO PACK THE JMIN( )
73 C VALUES (IBIT), THE NUMBER OF BITS NECESSARY TO PACK THE
74 C LBIT( ) VALUES (JBIT), AND THE NUMBER OF BITS NECESSARY
75 C TO PACK THE NOV( ) VALUES (KBIT). THE ROUTINE IS DESIGNED
76 C TO DETERMINE THE GROUPS SUCH THAT A SMALL NUMBER OF BITS
77 C IS NECESSARY TO PACK THE DATA WITHOUT EXCESSIVE
78 C COMPUTATIONS. IF ALL VALUES IN THE GROUP ARE ZERO, THE
79 C NUMBER OF BITS TO USE IN PACKING IS DEFINED AS ZERO WHEN
80 C THERE CAN BE NO MISSING VALUES; WHEN THERE CAN BE MISSING
81 C VALUES, THE NUMBER OF BITS MUST BE AT LEAST 1 TO HAVE
82 C THE CAPABILITY TO RECOGNIZE THE MISSING VALUE. HOWEVER,
83 C IF ALL VALUES IN A GROUP ARE MISSING, THE NUMBER OF BITS
84 C NEEDED IS 0, AND THE UNPACKER RECOGNIZES THIS.
85 C ALL VARIABLES ARE INTEGER. EVEN THOUGH THE GROUPS ARE
86 C INITIALLY OF SIZE MINPK OR LARGER, AN ADJUSTMENT BETWEEN
87 C TWO GROUPS (THE LOOKBACK PROCEDURE) MAY MAKE A GROUP
88 C SMALLER THAN MINPK. THE CONTROL ON GROUP SIZE IS THAT
89 C THE SUM OF THE SIZES OF THE TWO CONSECUTIVE GROUPS, EACH OF
90 C SIZE MINPK OR LARGER, IS NOT DECREASED. WHEN DETERMINING
91 C THE NUMBER OF BITS NECESSARY FOR PACKING, THE LARGEST
92 C VALUE THAT CAN BE ACCOMMODATED IN, SAY, MBITS, IS
93 C 2**MBITS-1; THIS LARGEST VALUE (AND THE NEXT SMALLEST
94 C VALUE) IS RESERVED FOR THE MISSING VALUE INDICATOR (ONLY)
95 C WHEN IS523 NE 0. IF THE DIMENSION NDG
96 C IS NOT LARGE ENOUGH TO HOLD ALL THE GROUPS, THE LOCAL VALUE
97 C OF MINPK IS INCREASED BY 50 PERCENT. THIS IS REPEATED
98 C UNTIL NDG WILL SUFFICE. A DIAGNOSTIC IS PRINTED WHENEVER
99 C THIS HAPPENS, WHICH SHOULD BE VERY RARELY. IF IT HAPPENS
100 C OFTEN, NDG IN SUBROUTINE PACK SHOULD BE INCREASED AND
101 C A CORRESPONDING INCREASE IN SUBROUTINE UNPACK MADE.
102 C CONSIDERABLE CODE IS PROVIDED SO THAT NO MORE CHECKING
103 C FOR MISSING VALUES WITHIN LOOPS IS DONE THAN NECESSARY;
104 C THE ADDED EFFICIENCY OF THIS IS RELATIVELY MINOR,
105 C BUT DOES NO HARM. FOR GRIB2, THE REFERENCE VALUE FOR
106 C THE LENGTH OF GROUPS IN NOV( ) AND FOR THE NUMBER OF
107 C BITS NECESSARY TO PACK GROUP VALUES ARE DETERMINED,
108 C AND SUBTRACTED BEFORE JBIT AND KBIT ARE DETERMINED.
109 C
110 C WHEN 1 OR MORE GROUPS ARE LARGE COMPARED TO THE OTHERS,
111 C THE WIDTH OF ALL GROUPS MUST BE AS LARGE AS THE LARGEST.
112 C A SUBROUTINE REDUCE BREAKS UP LARGE GROUPS INTO 2 OR
113 C MORE TO REDUCE TOTAL BITS REQUIRED. IF REDUCE SHOULD
114 C ABORT, PACK_GP WILL BE EXECUTED AGAIN WITHOUT THE CALL
115 C TO REDUCE.
116 C
117 C DATA SET USE
118 C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT)
119 C
120 C VARIABLES IN CALL SEQUENCE
121 C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT)
122 C IC( ) = ARRAY TO HOLD DATA FOR PACKING. THE VALUES
123 C DO NOT HAVE TO BE POSITIVE AT THIS POINT, BUT
124 C MUST BE IN THE RANGE -2**30 TO +2**30 (THE
125 C THE VALUE OF MALLOW). THESE INTEGER VALUES
126 C WILL BE RETAINED EXACTLY THROUGH PACKING AND
127 C UNPACKING. (INPUT)
128 C NXY = NUMBER OF VALUES IN IC( ). ALSO TREATED
129 C AS ITS DIMENSION. (INPUT)
130 C IS523 = missing value management
131 C 0=data contains no missing values
132 C 1=data contains Primary missing values
133 C 2=data contains Primary and secondary missing values
134 C (INPUT)
135 C MINPK = THE MINIMUM SIZE OF EACH GROUP, EXCEPT POSSIBLY
136 C THE LAST ONE. (INPUT)
137 C INC = THE NUMBER OF VALUES TO ADD TO AN ALREADY
138 C EXISTING GROUP IN DETERMINING WHETHER OR NOT
139 C TO START A NEW GROUP. IDEALLY, THIS WOULD BE
140 C 1, BUT EACH TIME INC VALUES ARE ATTEMPTED, THE
141 C MAX AND MIN OF THE NEXT MINPK VALUES MUST BE
142 C FOUND. THIS IS "A LOOP WITHIN A LOOP," AND
143 C A SLIGHTLY LARGER VALUE MAY GIVE ABOUT AS GOOD
144 C RESULTS WITH SLIGHTLY LESS COMPUTATIONAL TIME.
145 C IF INC IS LE 0, 1 IS USED, AND A DIAGNOSTIC IS
146 C OUTPUT. NOTE: IT IS EXPECTED THAT INC WILL
147 C EQUAL 1. THE CODE USES INC PRIMARILY IN THE
148 C LOOPS STARTING AT STATEMENT 180. IF INC
149 C WERE 1, THERE WOULD NOT NEED TO BE LOOPS
150 C AS SUCH. HOWEVER, KINC (THE LOCAL VALUE OF
151 C INC) IS SET GE 1 WHEN NEAR THE END OF THE DATA
152 C TO FORESTALL A VERY SMALL GROUP AT THE END.
153 C (INPUT)
154 C MISSP = WHEN MISSING POINTS CAN BE PRESENT IN THE DATA,
155 C THEY WILL HAVE THE VALUE MISSP OR MISSS.
156 C MISSP IS THE PRIMARY MISSING VALUE AND MISSS
157 C IS THE SECONDARY MISSING VALUE . THESE MUST
158 C NOT BE VALUES THAT WOULD OCCUR WITH SUBTRACTING
159 C THE MINIMUM (REFERENCE) VALUE OR SCALING.
160 C FOR EXAMPLE, MISSP = 0 WOULD NOT BE ADVISABLE.
161 C (INPUT)
162 C MISSS = SECONDARY MISSING VALUE INDICATOR (SEE MISSP).
163 C (INPUT)
164 C JMIN(J) = THE MINIMUM OF EACH GROUP (J=1,LX). (OUTPUT)
165 C JMAX(J) = THE MAXIMUM OF EACH GROUP (J=1,LX). THIS IS
166 C NOT REALLY NEEDED, BUT SINCE THE MAX OF EACH
167 C GROUP MUST BE FOUND, SAVING IT HERE IS CHEAP
168 C IN CASE THE USER WANTS IT. (OUTPUT)
169 C LBIT(J) = THE NUMBER OF BITS NECESSARY TO PACK EACH GROUP
170 C (J=1,LX). IT IS ASSUMED THE MINIMUM OF EACH
171 C GROUP WILL BE REMOVED BEFORE PACKING, AND THE
172 C VALUES TO PACK WILL, THEREFORE, ALL BE POSITIVE.
173 C HOWEVER, IC( ) DOES NOT NECESSARILY CONTAIN
174 C ALL POSITIVE VALUES. IF THE OVERALL MINIMUM
175 C HAS BEEN REMOVED (THE USUAL CASE), THEN IC( )
176 C WILL CONTAIN ONLY POSITIVE VALUES. (OUTPUT)
177 C NOV(J) = THE NUMBER OF VALUES IN EACH GROUP (J=1,LX).
178 C (OUTPUT)
179 C NDG = THE DIMENSION OF JMIN( ), JMAX( ), LBIT( ), AND
180 C NOV( ). (INPUT)
181 C LX = THE NUMBER OF GROUPS DETERMINED. (OUTPUT)
182 C IBIT = THE NUMBER OF BITS NECESSARY TO PACK THE JMIN(J)
183 C VALUES, J=1,LX. (OUTPUT)
184 C JBIT = THE NUMBER OF BITS NECESSARY TO PACK THE LBIT(J)
185 C VALUES, J=1,LX. (OUTPUT)
186 C KBIT = THE NUMBER OF BITS NECESSARY TO PACK THE NOV(J)
187 C VALUES, J=1,LX. (OUTPUT)
188 C NOVREF = REFERENCE VALUE FOR NOV( ). (OUTPUT)
189 C LBITREF = REFERENCE VALUE FOR LBIT( ). (OUTPUT)
190 C IER = ERROR RETURN.
191 C 706 = VALUE WILL NOT PACK IN 30 BITS--FATAL
192 C 714 = ERROR IN REDUCE--NON-FATAL
193 C 715 = NGP NOT LARGE ENOUGH IN REDUCE--NON-FATAL
194 C 716 = MINPK INCEASED--NON-FATAL
195 C 717 = INC SET = 1--NON-FATAL
196 C (OUTPUT)
197 C * = ALTERNATE RETURN WHEN IER NE 0 AND FATAL ERROR.
198 C
199 C INTERNAL VARIABLES
200 C CFEED = CONTAINS THE CHARACTER REPRESENTATION
201 C OF A PRINTER FORM FEED.
202 C IFEED = CONTAINS THE INTEGER VALUE OF A PRINTER
203 C FORM FEED.
204 C KINC = WORKING COPY OF INC. MAY BE MODIFIED.
205 C MINA = MINIMUM VALUE IN GROUP A.
206 C MAXA = MAXIMUM VALUE IN GROUP A.
207 C NENDA = THE PLACE IN IC( ) WHERE GROUP A ENDS.
208 C KSTART = THE PLACE IN IC( ) WHERE GROUP A STARTS.
209 C IBITA = NUMBER OF BITS NEEDED TO HOLD VALUES IN GROUP A.
210 C MINB = MINIMUM VALUE IN GROUP B.
211 C MAXB = MAXIMUM VALUE IN GROUP B.
212 C NENDB = THE PLACE IN IC( ) WHERE GROUP B ENDS.
213 C IBITB = NUMBER OF BITS NEEDED TO HOLD VALUES IN GROUP B.
214 C MINC = MINIMUM VALUE IN GROUP C.
215 C MAXC = MAXIMUM VALUE IN GROUP C.
216 C KTOTAL = COUNT OF NUMBER OF VALUES IN IC( ) PROCESSED.
217 C NOUNT = NUMBER OF VALUES ADDED TO GROUP A.
218 C LMISS = 0 WHEN IS523 = 0. WHEN PACKING INTO A
219 C SPECIFIC NUMBER OF BITS, SAY MBITS,
220 C THE MAXIMUM VALUE THAT CAN BE HANDLED IS
221 C 2**MBITS-1. WHEN IS523 = 1, INDICATING
222 C PRIMARY MISSING VALUES, THIS MAXIMUM VALUE
223 C IS RESERVED TO HOLD THE PRIMARY MISSING VALUE
224 C INDICATOR AND LMISS = 1. WHEN IS523 = 2,
225 C THE VALUE JUST BELOW THE MAXIMUM (I.E.,
226 C 2**MBITS-2) IS RESERVED TO HOLD THE SECONDARY
227 C MISSING VALUE INDICATOR AND LMISS = 2.
228 C LMINPK = LOCAL VALUE OF MINPK. THIS WILL BE ADJUSTED
229 C UPWARD WHENEVER NDG IS NOT LARGE ENOUGH TO HOLD
230 C ALL THE GROUPS.
231 C MALLOW = THE LARGEST ALLOWABLE VALUE FOR PACKING.
232 C MISLLA = SET TO 1 WHEN ALL VALUES IN GROUP A ARE MISSING.
233 C THIS IS USED TO DISTINGUISH BETWEEN A REAL
234 C MINIMUM WHEN ALL VALUES ARE NOT MISSING
235 C AND A MINIMUM THAT HAS BEEN SET TO ZERO WHEN
236 C ALL VALUES ARE MISSING. 0 OTHERWISE.
237 C NOTE THAT THIS DOES NOT DISTINGUISH BETWEEN
238 C PRIMARY AND SECONDARY MISSINGS WHEN SECONDARY
239 C MISSINGS ARE PRESENT. THIS MEANS THAT
240 C LBIT( ) WILL NOT BE ZERO WITH THE RESULTING
241 C COMPRESSION EFFICIENCY WHEN SECONDARY MISSINGS
242 C ARE PRESENT. ALSO NOTE THAT A CHECK HAS BEEN
243 C MADE EARLIER TO DETERMINE THAT SECONDARY
244 C MISSINGS ARE REALLY THERE.
245 C MISLLB = SET TO 1 WHEN ALL VALUES IN GROUP B ARE MISSING.
246 C THIS IS USED TO DISTINGUISH BETWEEN A REAL
247 C MINIMUM WHEN ALL VALUES ARE NOT MISSING
248 C AND A MINIMUM THAT HAS BEEN SET TO ZERO WHEN
249 C ALL VALUES ARE MISSING. 0 OTHERWISE.
250 C MISLLC = PERFORMS THE SAME FUNCTION FOR GROUP C THAT
251 C MISLLA AND MISLLB DO FOR GROUPS B AND C,
252 C RESPECTIVELY.
253 C IBXX2(J) = AN ARRAY THAT WHEN THIS ROUTINE IS FIRST ENTERED
254 C IS SET TO 2**J, J=0,30. IBXX2(30) = 2**30, WHICH
255 C IS THE LARGEST VALUE PACKABLE, BECAUSE 2**31
256 C IS LARGER THAN THE INTEGER WORD SIZE.
257 C IFIRST = SET BY DATA STATEMENT TO 0. CHANGED TO 1 ON
258 C FIRST
259 C ENTRY WHEN IBXX2( ) IS FILLED.
260 C MINAK = KEEPS TRACK OF THE LOCATION IN IC( ) WHERE THE
261 C MINIMUM VALUE IN GROUP A IS LOCATED.
262 C MAXAK = DOES THE SAME AS MINAK, EXCEPT FOR THE MAXIMUM.
263 C MINBK = THE SAME AS MINAK FOR GROUP B.
264 C MAXBK = THE SAME AS MAXAK FOR GROUP B.
265 C MINCK = THE SAME AS MINAK FOR GROUP C.
266 C MAXCK = THE SAME AS MAXAK FOR GROUP C.
267 C ADDA = KEEPS TRACK WHETHER OR NOT AN ATTEMPT TO ADD
268 C POINTS TO GROUP A WAS MADE. IF SO, THEN ADDA
269 C KEEPS FROM TRYING TO PUT ONE BACK INTO B.
270 C (LOGICAL)
271 C IBITBS = KEEPS CURRENT VALUE IF IBITB SO THAT LOOP
272 C ENDING AT 166 DOESN'T HAVE TO START AT
273 C IBITB = 0 EVERY TIME.
274 C MISSLX(J) = MALLOW EXCEPT WHEN A GROUP IS ALL ONE VALUE (AND
275 C LBIT(J) = 0) AND THAT VALUE IS MISSING. IN
276 C THAT CASE, MISSLX(J) IS MISSP OR MISSS. THIS
277 C GETS INSERTED INTO JMIN(J) LATER AS THE
278 C MISSING INDICATOR; IT CAN'T BE PUT IN UNTIL
279 C THE END, BECAUSE JMIN( ) IS USED TO CALCULATE
280 C THE MAXIMUM NUMBER OF BITS (IBITS) NEEDED TO
281 C PACK JMIN( ).
282 C 1 2 3 4 5 6 7 X
283 C
284 C NON SYSTEM SUBROUTINES CALLED
285 C NONE
286 C
287 PARAMETER (MALLOW=2**30+1)
288 C
289 CHARACTER*1 CFEED
290 LOGICAL ADDA
291 C
292 DIMENSION IC(NXY)
293 DIMENSION JMIN(NDG),JMAX(NDG),LBIT(NDG),NOV(NDG)
294 DIMENSION MISSLX(NDG)
295 C MISSLX( ) IS AN AUTOMATIC ARRAY.
296 DIMENSION IBXX2(0:30)
297 C
298 SAVE IBXX2
299 C
300 DATA IFEED/12/
301 DATA IFIRST/0/
302 C
303 IER=0
304 IERSAV=0
305 C CALL TIMPR(KFILDO,KFILDO,'START PACK_GP ')
306 CFEED=CHAR(IFEED)
307 C
308 IRED=0
309 C IRED IS A FLAG. WHEN ZERO, REDUCE WILL BE CALLED.
310 C IF REDUCE ABORTS, IRED = 1 AND IS NOT CALLED. IN
311 C THIS CASE PACK_GP EXECUTES AGAIN EXCEPT FOR REDUCE.
312 C
313 IF(INC.LE.0)THEN
314 IERSAV=717
315 C WRITE(KFILDO,101)INC
316 C101 FORMAT(/' ****INC ='I8,' NOT CORRECT IN PACK_GP. 1 IS USED.')
317 ENDIF
318 C
319 C THERE WILL BE A RESTART OF PACK_GP IF SUBROUTINE REDUCE
320 C ABORTS. THIS SHOULD NOT HAPPEN, BUT IF IT DOES, PACK_GP
321 C WILL COMPLETE WITHOUT SUBROUTINE REDUCE. A NON FATAL
322 C DIAGNOSTIC RETURN IS PROVIDED.
323 C
324 102 KINC=MAX(INC,1)
325 LMINPK=MINPK
326 C
327 C CALCULATE THE POWERS OF 2 THE FIRST TIME ENTERED.
328 C
329 IF(IFIRST.EQ.0)THEN
330 IFIRST=1
331 IBXX2(0)=1
332 C
333 DO 104 J=1,30
334 IBXX2(J)=IBXX2(J-1)*2
335 104 CONTINUE
336 C
337 ENDIF
338 C
339 C THERE WILL BE A RESTART AT 105 IS NDG IS NOT LARGE ENOUGH.
340 C A NON FATAL DIAGNOSTIC RETURN IS PROVIDED.
341 C
342 105 KSTART=1
343 KTOTAL=0
344 LX=0
345 ADDA=.FALSE.
346 LMISS=0
347 IF(IS523.EQ.1)LMISS=1
348 IF(IS523.EQ.2)LMISS=2
349 C
350 C *************************************
351 C
352 C THIS SECTION COMPUTES STATISTICS FOR GROUP A. GROUP A IS
353 C A GROUP OF SIZE LMINPK.
354 C
355 C *************************************
356 C
357 IBITA=0
358 MINA=MALLOW
359 MAXA=-MALLOW
360 MINAK=MALLOW
361 MAXAK=-MALLOW
362 C
363 C FIND THE MIN AND MAX OF GROUP A. THIS WILL INITIALLY BE OF
364 C SIZE LMINPK (IF THERE ARE STILL LMINPK VALUES IN IC( )), BUT
365 C WILL INCREASE IN SIZE IN INCREMENTS OF INC UNTIL A NEW
366 C GROUP IS STARTED. THE DEFINITION OF GROUP A IS DONE HERE
367 C ONLY ONCE (UPON INITIAL ENTRY), BECAUSE A GROUP B CAN ALWAYS
368 C BECOME A NEW GROUP A AFTER A IS PACKED, EXCEPT IF LMINPK
369 C HAS TO BE INCREASED BECAUSE NDG IS TOO SMALL. THEREFORE,
370 C THE SEPARATE LOOPS FOR MISSING AND NON-MISSING HERE BUYS
371 C ALMOST NOTHING.
372 C
373 NENDA=MIN(KSTART+LMINPK-1,NXY)
374 IF(NXY-NENDA.LE.LMINPK/2)NENDA=NXY
375 C ABOVE STATEMENT GUARANTEES THE LAST GROUP IS GT LMINPK/2 BY
376 C MAKING THE ACTUAL GROUP LARGER. IF A PROVISION LIKE THIS IS
377 C NOT INCLUDED, THERE WILL MANY TIMES BE A VERY SMALL GROUP
378 C AT THE END. USE SEPARATE LOOPS FOR MISSING AND NO MISSING
379 C VALUES FOR EFFICIENCY.
380 C
381 C DETERMINE WHETHER THERE IS A LONG STRING OF THE SAME VALUE
382 C UNLESS NENDA = NXY. THIS MAY ALLOW A LARGE GROUP A TO
383 C START WITH, AS WITH MISSING VALUES. SEPARATE LOOPS FOR
384 C MISSING OPTIONS. THIS SECTION IS ONLY EXECUTED ONCE,
385 C IN DETERMINING THE FIRST GROUP. IT HELPS FOR AN ARRAY
386 C OF MOSTLY MISSING VALUES OR OF ONE VALUE, SUCH AS
387 C RADAR OR PRECIP DATA.
388 C
389 IF(NENDA.NE.NXY.AND.IC(KSTART).EQ.IC(KSTART+1))THEN
390 C NO NEED TO EXECUTE IF FIRST TWO VALUES ARE NOT EQUAL.
391 C
392 IF(IS523.EQ.0)THEN
393 C THIS LOOP IS FOR NO MISSING VALUES.
394 C
395 DO 111 K=KSTART+1,NXY
396 C
397 IF(IC(K).NE.IC(KSTART))THEN
398 NENDA=MAX(NENDA,K-1)
399 GO TO 114
400 ENDIF
401 C
402 111 CONTINUE
403 C
404 NENDA=NXY
405 C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME.
406 C
407 ELSEIF(IS523.EQ.1)THEN
408 C THIS LOOP IS FOR PRIMARY MISSING VALUES ONLY.
409 C
410 DO 112 K=KSTART+1,NXY
411 C
412 IF(IC(K).NE.MISSP)THEN
413 C
414 IF(IC(K).NE.IC(KSTART))THEN
415 NENDA=MAX(NENDA,K-1)
416 GO TO 114
417 ENDIF
418 C
419 ENDIF
420 C
421 112 CONTINUE
422 C
423 NENDA=NXY
424 C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME.
425 C
426 ELSE
427 C THIS LOOP IS FOR PRIMARY AND SECONDARY MISSING VALUES.
428 C
429 DO 113 K=KSTART+1,NXY
430 C
431 IF(IC(K).NE.MISSP.AND.IC(K).NE.MISSS)THEN
432 C
433 IF(IC(K).NE.IC(KSTART))THEN
434 NENDA=MAX(NENDA,K-1)
435 GO TO 114
436 ENDIF
437 C
438 ENDIF
439 C
440 113 CONTINUE
441 C
442 NENDA=NXY
443 C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME.
444 ENDIF
445 C
446 ENDIF
447 C
448 114 IF(IS523.EQ.0)THEN
449 C
450 DO 115 K=KSTART,NENDA
451 IF(IC(K).LT.MINA)THEN
452 MINA=IC(K)
453 MINAK=K
454 ENDIF
455 IF(IC(K).GT.MAXA)THEN
456 MAXA=IC(K)
457 MAXAK=K
458 ENDIF
459 115 CONTINUE
460 C
461 ELSEIF(IS523.EQ.1)THEN
462 C
463 DO 117 K=KSTART,NENDA
464 IF(IC(K).EQ.MISSP)GO TO 117
465 IF(IC(K).LT.MINA)THEN
466 MINA=IC(K)
467 MINAK=K
468 ENDIF
469 IF(IC(K).GT.MAXA)THEN
470 MAXA=IC(K)
471 MAXAK=K
472 ENDIF
473 117 CONTINUE
474 C
475 ELSE
476 C
477 DO 120 K=KSTART,NENDA
478 IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 120
479 IF(IC(K).LT.MINA)THEN
480 MINA=IC(K)
481 MINAK=K
482 ENDIF
483 IF(IC(K).GT.MAXA)THEN
484 MAXA=IC(K)
485 MAXAK=K
486 ENDIF
487 120 CONTINUE
488 C
489 ENDIF
490 C
491 KOUNTA=NENDA-KSTART+1
492 C
493 C INCREMENT KTOTAL AND FIND THE BITS NEEDED TO PACK THE A GROUP.
494 C
495 KTOTAL=KTOTAL+KOUNTA
496 MISLLA=0
497 IF(MINA.NE.MALLOW)GO TO 125
498 C ALL MISSING VALUES MUST BE ACCOMMODATED.
499 MINA=0
500 MAXA=0
501 MISLLA=1
502 IBITB=0
503 IF(IS523.NE.2)GO TO 130
504 C WHEN ALL VALUES ARE MISSING AND THERE ARE NO
505 C SECONDARY MISSING VALUES, IBITA = 0.
506 C OTHERWISE, IBITA MUST BE CALCULATED.
507 C
508 125 ITEST=MAXA-MINA+LMISS
509 C
510 DO 126 IBITA=0,30
511 IF(ITEST.LT.IBXX2(IBITA))GO TO 130
512 C*** THIS TEST IS THE SAME AS:
513 C*** IF(MAXA-MINA.LT.IBXX2(IBITA)-LMISS)GO TO 130
514 126 CONTINUE
515 C
516 C WRITE(KFILDO,127)MAXA,MINA
517 C127 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.',
518 C 1 ' MAXA ='I13,' MINA ='I13,'. ERROR AT 127.')
519 IER=706
520 GO TO 900
521 C
522 130 CONTINUE
523 C
524 C***D WRITE(KFILDO,131)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA
525 C***D131 FORMAT(' AT 130, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8,
526 C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3)
527 C
528 133 IF(KTOTAL.GE.NXY)GO TO 200
529 C
530 C *************************************
531 C
532 C THIS SECTION COMPUTES STATISTICS FOR GROUP B. GROUP B IS A
533 C GROUP OF SIZE LMINPK IMMEDIATELY FOLLOWING GROUP A.
534 C
535 C *************************************
536 C
537 140 MINB=MALLOW
538 MAXB=-MALLOW
539 MINBK=MALLOW
540 MAXBK=-MALLOW
541 IBITBS=0
542 MSTART=KTOTAL+1
543 C
544 C DETERMINE WHETHER THERE IS A LONG STRING OF THE SAME VALUE.
545 C THIS WORKS WHEN THERE ARE NO MISSING VALUES.
546 C
547 NENDB=1
548 C
549 IF(MSTART.LT.NXY)THEN
550 C
551 IF(IS523.EQ.0)THEN
552 C THIS LOOP IS FOR NO MISSING VALUES.
553 C
554 DO 145 K=MSTART+1,NXY
555 C
556 IF(IC(K).NE.IC(MSTART))THEN
557 NENDB=K-1
558 GO TO 150
559 ENDIF
560 C
561 145 CONTINUE
562 C
563 NENDB=NXY
564 C FALL THROUGH THE LOOP MEANS ALL REMAINING VALUES
565 C ARE THE SAME.
566 ENDIF
567 C
568 ENDIF
569 C
570 150 NENDB=MAX(NENDB,MIN(KTOTAL+LMINPK,NXY))
571 C**** 150 NENDB=MIN(KTOTAL+LMINPK,NXY)
572 C
573 IF(NXY-NENDB.LE.LMINPK/2)NENDB=NXY
574 C ABOVE STATEMENT GUARANTEES THE LAST GROUP IS GT LMINPK/2 BY
575 C MAKING THE ACTUAL GROUP LARGER. IF A PROVISION LIKE THIS IS
576 C NOT INCLUDED, THERE WILL MANY TIMES BE A VERY SMALL GROUP
577 C AT THE END. USE SEPARATE LOOPS FOR MISSING AND NO MISSING
578 C
579 C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
580 C FOR EFFICIENCY.
581 C
582 IF(IS523.EQ.0)THEN
583 C
584 DO 155 K=MSTART,NENDB
585 IF(IC(K).LE.MINB)THEN
586 MINB=IC(K)
587 C NOTE LE, NOT LT. LT COULD BE USED BUT THEN A
588 C RECOMPUTE OVER THE WHOLE GROUP WOULD BE NEEDED
589 C MORE OFTEN. SAME REASONING FOR GE AND OTHER
590 C LOOPS BELOW.
591 MINBK=K
592 ENDIF
593 IF(IC(K).GE.MAXB)THEN
594 MAXB=IC(K)
595 MAXBK=K
596 ENDIF
597 155 CONTINUE
598 C
599 ELSEIF(IS523.EQ.1)THEN
600 C
601 DO 157 K=MSTART,NENDB
602 IF(IC(K).EQ.MISSP)GO TO 157
603 IF(IC(K).LE.MINB)THEN
604 MINB=IC(K)
605 MINBK=K
606 ENDIF
607 IF(IC(K).GE.MAXB)THEN
608 MAXB=IC(K)
609 MAXBK=K
610 ENDIF
611 157 CONTINUE
612 C
613 ELSE
614 C
615 DO 160 K=MSTART,NENDB
616 IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 160
617 IF(IC(K).LE.MINB)THEN
618 MINB=IC(K)
619 MINBK=K
620 ENDIF
621 IF(IC(K).GE.MAXB)THEN
622 MAXB=IC(K)
623 MAXBK=K
624 ENDIF
625 160 CONTINUE
626 C
627 ENDIF
628 C
629 KOUNTB=NENDB-KTOTAL
630 MISLLB=0
631 IF(MINB.NE.MALLOW)GO TO 165
632 C ALL MISSING VALUES MUST BE ACCOMMODATED.
633 MINB=0
634 MAXB=0
635 MISLLB=1
636 IBITB=0
637 C
638 IF(IS523.NE.2)GO TO 170
639 C WHEN ALL VALUES ARE MISSING AND THERE ARE NO SECONDARY
640 C MISSING VALUES, IBITB = 0. OTHERWISE, IBITB MUST BE
641 C CALCULATED.
642 C
643 165 DO 166 IBITB=IBITBS,30
644 IF(MAXB-MINB.LT.IBXX2(IBITB)-LMISS)GO TO 170
645 166 CONTINUE
646 C
647 C WRITE(KFILDO,167)MAXB,MINB
648 C167 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.',
649 C 1 ' MAXB ='I13,' MINB ='I13,'. ERROR AT 167.')
650 IER=706
651 GO TO 900
652 C
653 C COMPARE THE BITS NEEDED TO PACK GROUP B WITH THOSE NEEDED
654 C TO PACK GROUP A. IF IBITB GE IBITA, TRY TO ADD TO GROUP A.
655 C IF NOT, TRY TO ADD A'S POINTS TO B, UNLESS ADDITION TO A
656 C HAS BEEN DONE. THIS LATTER IS CONTROLLED WITH ADDA.
657 C
658 170 CONTINUE
659 C
660 C***D WRITE(KFILDO,171)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA,
661 C***D 1 MINB,MAXB,IBITB,MISLLB
662 C***D171 FORMAT(' AT 171, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8,
663 C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3,
664 C***D 2 ' MINB ='I8,' MAXB ='I8,' IBITB ='I3,' MISLLB ='I3)
665 C
666 IF(IBITB.GE.IBITA)GO TO 180
667 IF(ADDA)GO TO 200
668 C
669 C *************************************
670 C
671 C GROUP B REQUIRES LESS BITS THAN GROUP A. PUT AS MANY OF A'S
672 C POINTS INTO B AS POSSIBLE WITHOUT EXCEEDING THE NUMBER OF
673 C BITS NECESSARY TO PACK GROUP B.
674 C
675 C *************************************
676 C
677 KOUNTS=KOUNTA
678 C KOUNTA REFERS TO THE PRESENT GROUP A.
679 MINTST=MINB
680 MAXTST=MAXB
681 MINTSTK=MINBK
682 MAXTSTK=MAXBK
683 C
684 C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
685 C FOR EFFICIENCY.
686 C
687 IF(IS523.EQ.0)THEN
688 C
689 DO 1715 K=KTOTAL,KSTART,-1
690 C START WITH THE END OF THE GROUP AND WORK BACKWARDS.
691 IF(IC(K).LT.MINB)THEN
692 MINTST=IC(K)
693 MINTSTK=K
694 ELSEIF(IC(K).GT.MAXB)THEN
695 MAXTST=IC(K)
696 MAXTSTK=K
697 ENDIF
698 IF(MAXTST-MINTST.GE.IBXX2(IBITB))GO TO 174
699 C NOTE THAT FOR THIS LOOP, LMISS = 0.
700 MINB=MINTST
701 MAXB=MAXTST
702 MINBK=MINTSTK
703 MAXBK=MAXTSTK
704 KOUNTA=KOUNTA-1
705 C THERE IS ONE LESS POINT NOW IN A.
706 1715 CONTINUE
707 C
708 ELSEIF(IS523.EQ.1)THEN
709 C
710 DO 1719 K=KTOTAL,KSTART,-1
711 C START WITH THE END OF THE GROUP AND WORK BACKWARDS.
712 IF(IC(K).EQ.MISSP)GO TO 1718
713 IF(IC(K).LT.MINB)THEN
714 MINTST=IC(K)
715 MINTSTK=K
716 ELSEIF(IC(K).GT.MAXB)THEN
717 MAXTST=IC(K)
718 MAXTSTK=K
719 ENDIF
720 IF(MAXTST-MINTST.GE.IBXX2(IBITB)-LMISS)GO TO 174
721 C FOR THIS LOOP, LMISS = 1.
722 MINB=MINTST
723 MAXB=MAXTST
724 MINBK=MINTSTK
725 MAXBK=MAXTSTK
726 MISLLB=0
727 C WHEN THE POINT IS NON MISSING, MISLLB SET = 0.
728 1718 KOUNTA=KOUNTA-1
729 C THERE IS ONE LESS POINT NOW IN A.
730 1719 CONTINUE
731 C
732 ELSE
733 C
734 DO 173 K=KTOTAL,KSTART,-1
735 C START WITH THE END OF THE GROUP AND WORK BACKWARDS.
736 IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 1729
737 IF(IC(K).LT.MINB)THEN
738 MINTST=IC(K)
739 MINTSTK=K
740 ELSEIF(IC(K).GT.MAXB)THEN
741 MAXTST=IC(K)
742 MAXTSTK=K
743 ENDIF
744 IF(MAXTST-MINTST.GE.IBXX2(IBITB)-LMISS)GO TO 174
745 C FOR THIS LOOP, LMISS = 2.
746 MINB=MINTST
747 MAXB=MAXTST
748 MINBK=MINTSTK
749 MAXBK=MAXTSTK
750 MISLLB=0
751 C WHEN THE POINT IS NON MISSING, MISLLB SET = 0.
752 1729 KOUNTA=KOUNTA-1
753 C THERE IS ONE LESS POINT NOW IN A.
754 173 CONTINUE
755 C
756 ENDIF
757 C
758 C AT THIS POINT, KOUNTA CONTAINS THE NUMBER OF POINTS TO CLOSE
759 C OUT GROUP A WITH. GROUP B NOW STARTS WITH KSTART+KOUNTA AND
760 C ENDS WITH NENDB. MINB AND MAXB HAVE BEEN ADJUSTED AS
761 C NECESSARY TO REFLECT GROUP B (EVEN THOUGH THE NUMBER OF BITS
762 C NEEDED TO PACK GROUP B HAVE NOT INCREASED, THE END POINTS
763 C OF THE RANGE MAY HAVE).
764 C
765 174 IF(KOUNTA.EQ.KOUNTS)GO TO 200
766 C ON TRANSFER, GROUP A WAS NOT CHANGED. CLOSE IT OUT.
767 C
768 C ONE OR MORE POINTS WERE TAKEN OUT OF A. RANGE AND IBITA
769 C MAY HAVE TO BE RECOMPUTED; IBITA COULD BE LESS THAN
770 C ORIGINALLY COMPUTED. IN FACT, GROUP A CAN NOW CONTAIN
771 C ONLY ONE POINT AND BE PACKED WITH ZERO BITS
772 C (UNLESS MISSS NE 0).
773 C
774 NOUTA=KOUNTS-KOUNTA
775 KTOTAL=KTOTAL-NOUTA
776 KOUNTB=KOUNTB+NOUTA
777 IF(NENDA-NOUTA.GT.MINAK.AND.NENDA-NOUTA.GT.MAXAK)GO TO 200
778 C WHEN THE ABOVE TEST IS MET, THE MIN AND MAX OF THE
779 C CURRENT GROUP A WERE WITHIN THE OLD GROUP A, SO THE
780 C RANGE AND IBITA DO NOT NEED TO BE RECOMPUTED.
781 C NOTE THAT MINAK AND MAXAK ARE NO LONGER NEEDED.
782 IBITA=0
783 MINA=MALLOW
784 MAXA=-MALLOW
785 C
786 C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
787 C FOR EFFICIENCY.
788 C
789 IF(IS523.EQ.0)THEN
790 C
791 DO 1742 K=KSTART,NENDA-NOUTA
792 IF(IC(K).LT.MINA)THEN
793 MINA=IC(K)
794 ENDIF
795 IF(IC(K).GT.MAXA)THEN
796 MAXA=IC(K)
797 ENDIF
798 1742 CONTINUE
799 C
800 ELSEIF(IS523.EQ.1)THEN
801 C
802 DO 1744 K=KSTART,NENDA-NOUTA
803 IF(IC(K).EQ.MISSP)GO TO 1744
804 IF(IC(K).LT.MINA)THEN
805 MINA=IC(K)
806 ENDIF
807 IF(IC(K).GT.MAXA)THEN
808 MAXA=IC(K)
809 ENDIF
810 1744 CONTINUE
811 C
812 ELSE
813 C
814 DO 175 K=KSTART,NENDA-NOUTA
815 IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 175
816 IF(IC(K).LT.MINA)THEN
817 MINA=IC(K)
818 ENDIF
819 IF(IC(K).GT.MAXA)THEN
820 MAXA=IC(K)
821 ENDIF
822 175 CONTINUE
823 C
824 ENDIF
825 C
826 MISLLA=0
827 IF(MINA.NE.MALLOW)GO TO 1750
828 C ALL MISSING VALUES MUST BE ACCOMMODATED.
829 MINA=0
830 MAXA=0
831 MISLLA=1
832 IF(IS523.NE.2)GO TO 177
833 C WHEN ALL VALUES ARE MISSING AND THERE ARE NO SECONDARY
834 C MISSING VALUES IBITA = 0 AS ORIGINALLY SET. OTHERWISE,
835 C IBITA MUST BE CALCULATED.
836 C
837 1750 ITEST=MAXA-MINA+LMISS
838 C
839 DO 176 IBITA=0,30
840 IF(ITEST.LT.IBXX2(IBITA))GO TO 177
841 C*** THIS TEST IS THE SAME AS:
842 C*** IF(MAXA-MINA.LT.IBXX2(IBITA)-LMISS)GO TO 177
843 176 CONTINUE
844 C
845 C WRITE(KFILDO,1760)MAXA,MINA
846 C1760 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.',
847 C 1 ' MAXA ='I13,' MINA ='I13,'. ERROR AT 1760.')
848 IER=706
849 GO TO 900
850 C
851 177 CONTINUE
852 GO TO 200
853 C
854 C *************************************
855 C
856 C AT THIS POINT, GROUP B REQUIRES AS MANY BITS TO PACK AS GROUPA.
857 C THEREFORE, TRY TO ADD INC POINTS TO GROUP A WITHOUT INCREASING
858 C IBITA. THIS AUGMENTED GROUP IS CALLED GROUP C.
859 C
860 C *************************************
861 C
862 180 IF(MISLLA.EQ.1)THEN
863 MINC=MALLOW
864 MINCK=MALLOW
865 MAXC=-MALLOW
866 MAXCK=-MALLOW
867 ELSE
868 MINC=MINA
869 MAXC=MAXA
870 MINCK=MINAK
871 MAXCK=MINAK
872 ENDIF
873 C
874 NOUNT=0
875 IF(NXY-(KTOTAL+KINC).LE.LMINPK/2)KINC=NXY-KTOTAL
876 C ABOVE STATEMENT CONSTRAINS THE LAST GROUP TO BE NOT LESS THAN
877 C LMINPK/2 IN SIZE. IF A PROVISION LIKE THIS IS NOT INCLUDED,
878 C THERE WILL MANY TIMES BE A VERY SMALL GROUP AT THE END.
879 C
880 C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
881 C FOR EFFICIENCY. SINCE KINC IS USUALLY 1, USING SEPARATE
882 C LOOPS HERE DOESN'T BUY MUCH. A MISSING VALUE WILL ALWAYS
883 C TRANSFER BACK TO GROUP A.
884 C
885 IF(IS523.EQ.0)THEN
886 C
887 DO 185 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY)
888 IF(IC(K).LT.MINC)THEN
889 MINC=IC(K)
890 MINCK=K
891 ENDIF
892 IF(IC(K).GT.MAXC)THEN
893 MAXC=IC(K)
894 MAXCK=K
895 ENDIF
896 NOUNT=NOUNT+1
897 185 CONTINUE
898 C
899 ELSEIF(IS523.EQ.1)THEN
900 C
901 DO 187 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY)
902 IF(IC(K).EQ.MISSP)GO TO 186
903 IF(IC(K).LT.MINC)THEN
904 MINC=IC(K)
905 MINCK=K
906 ENDIF
907 IF(IC(K).GT.MAXC)THEN
908 MAXC=IC(K)
909 MAXCK=K
910 ENDIF
911 186 NOUNT=NOUNT+1
912 187 CONTINUE
913 C
914 ELSE
915 C
916 DO 190 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY)
917 IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 189
918 IF(IC(K).LT.MINC)THEN
919 MINC=IC(K)
920 MINCK=K
921 ENDIF
922 IF(IC(K).GT.MAXC)THEN
923 MAXC=IC(K)
924 MAXCK=K
925 ENDIF
926 189 NOUNT=NOUNT+1
927 190 CONTINUE
928 C
929 ENDIF
930 C
931 C***D WRITE(KFILDO,191)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA,
932 C***D 1 MINC,MAXC,NOUNT,IC(KTOTAL),IC(KTOTAL+1)
933 C***D191 FORMAT(' AT 191, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8,
934 C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3,
935 C***D 2 ' MINC ='I8,' MAXC ='I8,
936 C***D 3 ' NOUNT ='I5,' IC(KTOTAL) ='I9,' IC(KTOTAL+1) =',I9)
937 C
938 C IF THE NUMBER OF BITS NEEDED FOR GROUP C IS GT IBITA,
939 C THEN THIS GROUP A IS A GROUP TO PACK.
940 C
941 IF(MINC.EQ.MALLOW)THEN
942 MINC=MINA
943 MAXC=MAXA
944 MINCK=MINAK
945 MAXCK=MAXAK
946 MISLLC=1
947 GO TO 195
948 C WHEN THE NEW VALUE(S) ARE MISSING, THEY CAN ALWAYS
949 C BE ADDED.
950 C
951 ELSE
952 MISLLC=0
953 ENDIF
954 C
955 IF(MAXC-MINC.GE.IBXX2(IBITA)-LMISS) GO TO 200
956 C
957 C THE BITS NECESSARY FOR GROUP C HAS NOT INCREASED FROM THE
958 C BITS NECESSARY FOR GROUP A. ADD THIS POINT(S) TO GROUP A.
959 C COMPUTE THE NEXT GROUP B, ETC., UNLESS ALL POINTS HAVE BEEN
960 C USED.
961 C
962 195 KTOTAL=KTOTAL+NOUNT
963 KOUNTA=KOUNTA+NOUNT
964 MINA=MINC
965 MAXA=MAXC
966 MINAK=MINCK
967 MAXAK=MAXCK
968 MISLLA=MISLLC
969 ADDA=.TRUE.
970 IF(KTOTAL.GE.NXY)GO TO 200
971 C
972 IF(MINBK.GT.KTOTAL.AND.MAXBK.GT.KTOTAL)THEN
973 MSTART=NENDB+1
974 C THE MAX AND MIN OF GROUP B WERE NOT FROM THE POINTS
975 C REMOVED, SO THE WHOLE GROUP DOES NOT HAVE TO BE LOOKED
976 C AT TO DETERMINE THE NEW MAX AND MIN. RATHER START
977 C JUST BEYOND THE OLD NENDB.
978 IBITBS=IBITB
979 NENDB=1
980 GO TO 150
981 ELSE
982 GO TO 140
983 ENDIF
984 C
985 C *************************************
986 C
987 C GROUP A IS TO BE PACKED. STORE VALUES IN JMIN( ), JMAX( ),
988 C LBIT( ), AND NOV( ).
989 C
990 C *************************************
991 C
992 200 LX=LX+1
993 IF(LX.LE.NDG)GO TO 205
994 LMINPK=LMINPK+LMINPK/2
995 C WRITE(KFILDO,201)NDG,LMINPK,LX
996 C201 FORMAT(' ****NDG ='I5,' NOT LARGE ENOUGH.',
997 C 1 ' LMINPK IS INCREASED TO 'I3,' FOR THIS FIELD.'/
998 C 2 ' LX = 'I10)
999 IERSAV=716
1000 GO TO 105
1001 C
1002 205 JMIN(LX)=MINA
1003 JMAX(LX)=MAXA
1004 LBIT(LX)=IBITA
1005 NOV(LX)=KOUNTA
1006 KSTART=KTOTAL+1
1007 C
1008 IF(MISLLA.EQ.0)THEN
1009 MISSLX(LX)=MALLOW
1010 ELSE
1011 MISSLX(LX)=IC(KTOTAL)
1012 C IC(KTOTAL) WAS THE LAST VALUE PROCESSED. IF MISLLA NE 0,
1013 C THIS MUST BE THE MISSING VALUE FOR THIS GROUP.
1014 ENDIF
1015 C
1016 C***D WRITE(KFILDO,206)MISLLA,IC(KTOTAL),KTOTAL,LX,JMIN(LX),JMAX(LX),
1017 C***D 1 LBIT(LX),NOV(LX),MISSLX(LX)
1018 C***D206 FORMAT(' AT 206, MISLLA ='I2,' IC(KTOTAL) ='I5,' KTOTAL ='I8,
1019 C***D 1 ' LX ='I6,' JMIN(LX) ='I8,' JMAX(LX) ='I8,
1020 C***D 2 ' LBIT(LX) ='I5,' NOV(LX) ='I8,' MISSLX(LX) =',I7)
1021 C
1022 IF(KTOTAL.GE.NXY)GO TO 209
1023 C
1024 C THE NEW GROUP A WILL BE THE PREVIOUS GROUP B. SET LIMITS, ETC.
1025 C
1026 IBITA=IBITB
1027 MINA=MINB
1028 MAXA=MAXB
1029 MINAK=MINBK
1030 MAXAK=MAXBK
1031 MISLLA=MISLLB
1032 NENDA=NENDB
1033 KOUNTA=KOUNTB
1034 KTOTAL=KTOTAL+KOUNTA
1035 ADDA=.FALSE.
1036 GO TO 133
1037 C
1038 C *************************************
1039 C
1040 C CALCULATE IBIT, THE NUMBER OF BITS NEEDED TO HOLD THE GROUP
1041 C MINIMUM VALUES.
1042 C
1043 C *************************************
1044 C
1045 209 IBIT=0
1046 C
1047 DO 220 L=1,LX
1048 210 IF(JMIN(L).LT.IBXX2(IBIT))GO TO 220
1049 IBIT=IBIT+1
1050 GO TO 210
1051 220 CONTINUE
1052 C
1053 C INSERT THE VALUE IN JMIN( ) TO BE USED FOR ALL MISSING
1054 C VALUES WHEN LBIT( ) = 0. WHEN SECONDARY MISSING
1055 C VALUES CAN BE PRESENT, LBIT(L) WILL NOT = 0.
1056 C
1057 IF(IS523.EQ.1)THEN
1058 C
1059 DO 226 L=1,LX
1060 C
1061 IF(LBIT(L).EQ.0)THEN
1062 C
1063 IF(MISSLX(L).EQ.MISSP)THEN
1064 JMIN(L)=IBXX2(IBIT)-1
1065 ENDIF
1066 C
1067 ENDIF
1068 C
1069 226 CONTINUE
1070 C
1071 ENDIF
1072 C
1073 C *************************************
1074 C
1075 C CALCULATE JBIT, THE NUMBER OF BITS NEEDED TO HOLD THE BITS
1076 C NEEDED TO PACK THE VALUES IN THE GROUPS. BUT FIND AND
1077 C REMOVE THE REFERENCE VALUE FIRST.
1078 C
1079 C *************************************
1080 C
1081 C WRITE(KFILDO,228)CFEED,LX
1082 C228 FORMAT(A1,/' *****************************************'
1083 C 1 /' THE GROUP WIDTHS LBIT( ) FOR ',I8,' GROUPS'
1084 C 2 /' *****************************************')
1085 C WRITE(KFILDO,229) (LBIT(J),J=1,MIN(LX,100))
1086 C229 FORMAT(/' '20I6)
1087 C
1088 LBITREF=LBIT(1)
1089 C
1090 DO 230 K=1,LX
1091 IF(LBIT(K).LT.LBITREF)LBITREF=LBIT(K)
1092 230 CONTINUE
1093 C
1094 IF(LBITREF.NE.0)THEN
1095 C
1096 DO 240 K=1,LX
1097 LBIT(K)=LBIT(K)-LBITREF
1098 240 CONTINUE
1099 C
1100 ENDIF
1101 C
1102 C WRITE(KFILDO,241)CFEED,LBITREF
1103 C241 FORMAT(A1,/' *****************************************'
1104 C 1 /' THE GROUP WIDTHS LBIT( ) AFTER REMOVING REFERENCE ',
1105 C 2 I8,
1106 C 3 /' *****************************************')
1107 C WRITE(KFILDO,242) (LBIT(J),J=1,MIN(LX,100))
1108 C242 FORMAT(/' '20I6)
1109 C
1110 JBIT=0
1111 C
1112 DO 320 K=1,LX
1113 310 IF(LBIT(K).LT.IBXX2(JBIT))GO TO 320
1114 JBIT=JBIT+1
1115 GO TO 310
1116 320 CONTINUE
1117 C
1118 C *************************************
1119 C
1120 C CALCULATE KBIT, THE NUMBER OF BITS NEEDED TO HOLD THE NUMBER
1121 C OF VALUES IN THE GROUPS. BUT FIND AND REMOVE THE
1122 C REFERENCE FIRST.
1123 C
1124 C *************************************
1125 C
1126 C WRITE(KFILDO,321)CFEED,LX
1127 C321 FORMAT(A1,/' *****************************************'
1128 C 1 /' THE GROUP SIZES NOV( ) FOR ',I8,' GROUPS'
1129 C 2 /' *****************************************')
1130 C WRITE(KFILDO,322) (NOV(J),J=1,MIN(LX,100))
1131 C322 FORMAT(/' '20I6)
1132 C
1133 NOVREF=NOV(1)
1134 C
1135 DO 400 K=1,LX
1136 IF(NOV(K).LT.NOVREF)NOVREF=NOV(K)
1137 400 CONTINUE
1138 C
1139 IF(NOVREF.GT.0)THEN
1140 C
1141 DO 405 K=1,LX
1142 NOV(K)=NOV(K)-NOVREF
1143 405 CONTINUE
1144 C
1145 ENDIF
1146 C
1147 C WRITE(KFILDO,406)CFEED,NOVREF
1148 C406 FORMAT(A1,/' *****************************************'
1149 C 1 /' THE GROUP SIZES NOV( ) AFTER REMOVING REFERENCE ',I8,
1150 C 2 /' *****************************************')
1151 C WRITE(KFILDO,407) (NOV(J),J=1,MIN(LX,100))
1152 C407 FORMAT(/' '20I6)
1153 C WRITE(KFILDO,408)CFEED
1154 C408 FORMAT(A1,/' *****************************************'
1155 C 1 /' THE GROUP REFERENCES JMIN( )'
1156 C 2 /' *****************************************')
1157 C WRITE(KFILDO,409) (JMIN(J),J=1,MIN(LX,100))
1158 C409 FORMAT(/' '20I6)
1159 C
1160 KBIT=0
1161 C
1162 DO 420 K=1,LX
1163 410 IF(NOV(K).LT.IBXX2(KBIT))GO TO 420
1164 KBIT=KBIT+1
1165 GO TO 410
1166 420 CONTINUE
1167 C
1168 C DETERMINE WHETHER THE GROUP SIZES SHOULD BE REDUCED
1169 C FOR SPACE EFFICIENCY.
1170 C
1171 IF(IRED.EQ.0)THEN
1172 CALL REDUCE(KFILDO,JMIN,JMAX,LBIT,NOV,LX,NDG,IBIT,JBIT,KBIT,
1173 1 NOVREF,IBXX2,IER)
1174 C
1175 IF(IER.EQ.714.OR.IER.EQ.715)THEN
1176 C REDUCE HAS ABORTED. REEXECUTE PACK_GP WITHOUT REDUCE.
1177 C PROVIDE FOR A NON FATAL RETURN FROM REDUCE.
1178 IERSAV=IER
1179 IRED=1
1180 IER=0
1181 GO TO 102
1182 ENDIF
1183 C
1184 ENDIF
1185 C
1186 C CALL TIMPR(KFILDO,KFILDO,'END PACK_GP ')
1187 IF(IERSAV.NE.0)THEN
1188 IER=IERSAV
1189 RETURN
1190 ENDIF
1191 C
1192 C 900 IF(IER.NE.0)RETURN1
1193 C
1194 900 RETURN
1195 END