Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

pack_gp.F @ 3964

Last change on this file since 3964 was 2759, checked in by aslmd, 3 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 41.6 KB

Line
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 -230 TO +230 (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 2J, J=0,30. IBXX2(30) = 230, 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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format