SUBROUTINE PACK_GP(KFILDO,IC,NXY,IS523,MINPK,INC,MISSP,MISSS, 1 JMIN,JMAX,LBIT,NOV,NDG,LX,IBIT,JBIT,KBIT, 2 NOVREF,LBITREF,IER) C C FEBRUARY 1994 GLAHN TDL MOS-2000 C JUNE 1995 GLAHN MODIFIED FOR LMISS ERROR. C JULY 1996 GLAHN ADDED MISSS C FEBRUARY 1997 GLAHN REMOVED 4 REDUNDANT TESTS FOR C MISSP.EQ.0; INSERTED A TEST TO BETTER C HANDLE A STRING OF 9999'S C FEBRUARY 1997 GLAHN ADDED LOOPS TO ELIMINATE TEST FOR C MISSS WHEN MISSS = 0 C MARCH 1997 GLAHN CORRECTED FOR SECONDARY MISSING VALUE C MARCH 1997 GLAHN CORRECTED FOR USE OF LOCAL VALUE C OF MINPK C MARCH 1997 GLAHN CORRECTED FOR SECONDARY MISSING VALUE C MARCH 1997 GLAHN CHANGED CALCULATING NUMBER OF BITS C THROUGH EXPONENTS TO AN ARRAY (IMPROVED C OVERALL PACKING PERFORMANCE BY ABOUT C 35 PERCENT!). ALLOWED 0 BITS FOR C PACKING JMIN( ), LBIT( ), AND NOV( ). C MAY 1997 GLAHN A NUMBER OF CHANGES FOR EFFICIENCY. C MOD FUNCTIONS ELIMINATED AND ONE C IFTHEN ADDED. JOUNT REMOVED. C RECOMPUTATION OF BITS NOT MADE UNLESS C NECESSARY AFTER MOVING POINTS FROM C ONE GROUP TO ANOTHER. NENDB ADJUSTED C TO ELIMINATE POSSIBILITY OF VERY C SMALL GROUP AT THE END. C ABOUT 8 PERCENT IMPROVEMENT IN C OVERALL PACKING. ISKIPA REMOVED; C THERE IS ALWAYS A GROUP B THAT CAN C BECOME GROUP A. CONTROL ON SIZE C OF GROUP B (STATEMENT BELOW 150) C ADDED. ADDED ADDA, AND USE C OF GE AND LE INSTEAD OF GT AND LT C IN LOOPS BETWEEN 150 AND 160. C IBITBS ADDED TO SHORTEN TRIPS C THROUGH LOOP. C MARCH 2000 GLAHN MODIFIED FOR GRIB2; CHANGED NAME FROM C PACKGP C JANUARY 2001 GLAHN COMMENTS; IER = 706 SUBSTITUTED FOR C STOPS; ADDED RETURN1; REMOVED STATEMENT C NUMBER 110; ADDED IER AND * RETURN C NOVEMBER 2001 GLAHN CHANGED SOME DIAGNOSTIC FORMATS TO C ALLOW PRINTING LARGER NUMBERS C NOVEMBER 2001 GLAHN ADDED MISSLX( ) TO PUT MAXIMUM VALUE C INTO JMIN( ) WHEN ALL VALUES MISSING C TO AGREE WITH GRIB STANDARD. C NOVEMBER 2001 GLAHN CHANGED TWO TESTS ON MISSP AND MISSS C EQ 0 TO TESTS ON IS523. HOWEVER, C MISSP AND MISSS CANNOT IN GENERAL BE C = 0. C NOVEMBER 2001 GLAHN ADDED CALL TO REDUCE; DEFINED ITEST C BEFORE LOOPS TO REDUCE COMPUTATION; C STARTED LARGE GROUP WHEN ALL SAME C VALUE C DECEMBER 2001 GLAHN MODIFIED AND ADDED A FEW COMMENTS C JANUARY 2002 GLAHN REMOVED LOOP BEFORE 150 TO DETERMINE C A GROUP OF ALL SAME VALUE C JANUARY 2002 GLAHN CHANGED MALLOW FROM 9999999 TO 2**30+1, C AND MADE IT A PARAMETER C MARCH 2002 GLAHN ADDED NON FATAL IER = 716, 717; C REMOVED NENDB=NXY ABOVE 150; C ADDED IERSAV=0; COMMENTS C C PURPOSE C DETERMINES GROUPS OF VARIABLE SIZE, BUT AT LEAST OF C SIZE MINPK, THE ASSOCIATED MAX (JMAX( )) AND MIN (JMIN( )), C THE NUMBER OF BITS NECESSARY TO HOLD THE VALUES IN EACH C GROUP (LBIT( )), THE NUMBER OF VALUES IN EACH GROUP C (NOV( )), THE NUMBER OF BITS NECESSARY TO PACK THE JMIN( ) C VALUES (IBIT), THE NUMBER OF BITS NECESSARY TO PACK THE C LBIT( ) VALUES (JBIT), AND THE NUMBER OF BITS NECESSARY C TO PACK THE NOV( ) VALUES (KBIT). THE ROUTINE IS DESIGNED C TO DETERMINE THE GROUPS SUCH THAT A SMALL NUMBER OF BITS C IS NECESSARY TO PACK THE DATA WITHOUT EXCESSIVE C COMPUTATIONS. IF ALL VALUES IN THE GROUP ARE ZERO, THE C NUMBER OF BITS TO USE IN PACKING IS DEFINED AS ZERO WHEN C THERE CAN BE NO MISSING VALUES; WHEN THERE CAN BE MISSING C VALUES, THE NUMBER OF BITS MUST BE AT LEAST 1 TO HAVE C THE CAPABILITY TO RECOGNIZE THE MISSING VALUE. HOWEVER, C IF ALL VALUES IN A GROUP ARE MISSING, THE NUMBER OF BITS C NEEDED IS 0, AND THE UNPACKER RECOGNIZES THIS. C ALL VARIABLES ARE INTEGER. EVEN THOUGH THE GROUPS ARE C INITIALLY OF SIZE MINPK OR LARGER, AN ADJUSTMENT BETWEEN C TWO GROUPS (THE LOOKBACK PROCEDURE) MAY MAKE A GROUP C SMALLER THAN MINPK. THE CONTROL ON GROUP SIZE IS THAT C THE SUM OF THE SIZES OF THE TWO CONSECUTIVE GROUPS, EACH OF C SIZE MINPK OR LARGER, IS NOT DECREASED. WHEN DETERMINING C THE NUMBER OF BITS NECESSARY FOR PACKING, THE LARGEST C VALUE THAT CAN BE ACCOMMODATED IN, SAY, MBITS, IS C 2**MBITS-1; THIS LARGEST VALUE (AND THE NEXT SMALLEST C VALUE) IS RESERVED FOR THE MISSING VALUE INDICATOR (ONLY) C WHEN IS523 NE 0. IF THE DIMENSION NDG C IS NOT LARGE ENOUGH TO HOLD ALL THE GROUPS, THE LOCAL VALUE C OF MINPK IS INCREASED BY 50 PERCENT. THIS IS REPEATED C UNTIL NDG WILL SUFFICE. A DIAGNOSTIC IS PRINTED WHENEVER C THIS HAPPENS, WHICH SHOULD BE VERY RARELY. IF IT HAPPENS C OFTEN, NDG IN SUBROUTINE PACK SHOULD BE INCREASED AND C A CORRESPONDING INCREASE IN SUBROUTINE UNPACK MADE. C CONSIDERABLE CODE IS PROVIDED SO THAT NO MORE CHECKING C FOR MISSING VALUES WITHIN LOOPS IS DONE THAN NECESSARY; C THE ADDED EFFICIENCY OF THIS IS RELATIVELY MINOR, C BUT DOES NO HARM. FOR GRIB2, THE REFERENCE VALUE FOR C THE LENGTH OF GROUPS IN NOV( ) AND FOR THE NUMBER OF C BITS NECESSARY TO PACK GROUP VALUES ARE DETERMINED, C AND SUBTRACTED BEFORE JBIT AND KBIT ARE DETERMINED. C C WHEN 1 OR MORE GROUPS ARE LARGE COMPARED TO THE OTHERS, C THE WIDTH OF ALL GROUPS MUST BE AS LARGE AS THE LARGEST. C A SUBROUTINE REDUCE BREAKS UP LARGE GROUPS INTO 2 OR C MORE TO REDUCE TOTAL BITS REQUIRED. IF REDUCE SHOULD C ABORT, PACK_GP WILL BE EXECUTED AGAIN WITHOUT THE CALL C TO REDUCE. C C DATA SET USE C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) C C VARIABLES IN CALL SEQUENCE C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT) C IC( ) = ARRAY TO HOLD DATA FOR PACKING. THE VALUES C DO NOT HAVE TO BE POSITIVE AT THIS POINT, BUT C MUST BE IN THE RANGE -2**30 TO +2**30 (THE C THE VALUE OF MALLOW). THESE INTEGER VALUES C WILL BE RETAINED EXACTLY THROUGH PACKING AND C UNPACKING. (INPUT) C NXY = NUMBER OF VALUES IN IC( ). ALSO TREATED C AS ITS DIMENSION. (INPUT) C IS523 = missing value management C 0=data contains no missing values C 1=data contains Primary missing values C 2=data contains Primary and secondary missing values C (INPUT) C MINPK = THE MINIMUM SIZE OF EACH GROUP, EXCEPT POSSIBLY C THE LAST ONE. (INPUT) C INC = THE NUMBER OF VALUES TO ADD TO AN ALREADY C EXISTING GROUP IN DETERMINING WHETHER OR NOT C TO START A NEW GROUP. IDEALLY, THIS WOULD BE C 1, BUT EACH TIME INC VALUES ARE ATTEMPTED, THE C MAX AND MIN OF THE NEXT MINPK VALUES MUST BE C FOUND. THIS IS "A LOOP WITHIN A LOOP," AND C A SLIGHTLY LARGER VALUE MAY GIVE ABOUT AS GOOD C RESULTS WITH SLIGHTLY LESS COMPUTATIONAL TIME. C IF INC IS LE 0, 1 IS USED, AND A DIAGNOSTIC IS C OUTPUT. NOTE: IT IS EXPECTED THAT INC WILL C EQUAL 1. THE CODE USES INC PRIMARILY IN THE C LOOPS STARTING AT STATEMENT 180. IF INC C WERE 1, THERE WOULD NOT NEED TO BE LOOPS C AS SUCH. HOWEVER, KINC (THE LOCAL VALUE OF C INC) IS SET GE 1 WHEN NEAR THE END OF THE DATA C TO FORESTALL A VERY SMALL GROUP AT THE END. C (INPUT) C MISSP = WHEN MISSING POINTS CAN BE PRESENT IN THE DATA, C THEY WILL HAVE THE VALUE MISSP OR MISSS. C MISSP IS THE PRIMARY MISSING VALUE AND MISSS C IS THE SECONDARY MISSING VALUE . THESE MUST C NOT BE VALUES THAT WOULD OCCUR WITH SUBTRACTING C THE MINIMUM (REFERENCE) VALUE OR SCALING. C FOR EXAMPLE, MISSP = 0 WOULD NOT BE ADVISABLE. C (INPUT) C MISSS = SECONDARY MISSING VALUE INDICATOR (SEE MISSP). C (INPUT) C JMIN(J) = THE MINIMUM OF EACH GROUP (J=1,LX). (OUTPUT) C JMAX(J) = THE MAXIMUM OF EACH GROUP (J=1,LX). THIS IS C NOT REALLY NEEDED, BUT SINCE THE MAX OF EACH C GROUP MUST BE FOUND, SAVING IT HERE IS CHEAP C IN CASE THE USER WANTS IT. (OUTPUT) C LBIT(J) = THE NUMBER OF BITS NECESSARY TO PACK EACH GROUP C (J=1,LX). IT IS ASSUMED THE MINIMUM OF EACH C GROUP WILL BE REMOVED BEFORE PACKING, AND THE C VALUES TO PACK WILL, THEREFORE, ALL BE POSITIVE. C HOWEVER, IC( ) DOES NOT NECESSARILY CONTAIN C ALL POSITIVE VALUES. IF THE OVERALL MINIMUM C HAS BEEN REMOVED (THE USUAL CASE), THEN IC( ) C WILL CONTAIN ONLY POSITIVE VALUES. (OUTPUT) C NOV(J) = THE NUMBER OF VALUES IN EACH GROUP (J=1,LX). C (OUTPUT) C NDG = THE DIMENSION OF JMIN( ), JMAX( ), LBIT( ), AND C NOV( ). (INPUT) C LX = THE NUMBER OF GROUPS DETERMINED. (OUTPUT) C IBIT = THE NUMBER OF BITS NECESSARY TO PACK THE JMIN(J) C VALUES, J=1,LX. (OUTPUT) C JBIT = THE NUMBER OF BITS NECESSARY TO PACK THE LBIT(J) C VALUES, J=1,LX. (OUTPUT) C KBIT = THE NUMBER OF BITS NECESSARY TO PACK THE NOV(J) C VALUES, J=1,LX. (OUTPUT) C NOVREF = REFERENCE VALUE FOR NOV( ). (OUTPUT) C LBITREF = REFERENCE VALUE FOR LBIT( ). (OUTPUT) C IER = ERROR RETURN. C 706 = VALUE WILL NOT PACK IN 30 BITS--FATAL C 714 = ERROR IN REDUCE--NON-FATAL C 715 = NGP NOT LARGE ENOUGH IN REDUCE--NON-FATAL C 716 = MINPK INCEASED--NON-FATAL C 717 = INC SET = 1--NON-FATAL C (OUTPUT) C * = ALTERNATE RETURN WHEN IER NE 0 AND FATAL ERROR. C C INTERNAL VARIABLES C CFEED = CONTAINS THE CHARACTER REPRESENTATION C OF A PRINTER FORM FEED. C IFEED = CONTAINS THE INTEGER VALUE OF A PRINTER C FORM FEED. C KINC = WORKING COPY OF INC. MAY BE MODIFIED. C MINA = MINIMUM VALUE IN GROUP A. C MAXA = MAXIMUM VALUE IN GROUP A. C NENDA = THE PLACE IN IC( ) WHERE GROUP A ENDS. C KSTART = THE PLACE IN IC( ) WHERE GROUP A STARTS. C IBITA = NUMBER OF BITS NEEDED TO HOLD VALUES IN GROUP A. C MINB = MINIMUM VALUE IN GROUP B. C MAXB = MAXIMUM VALUE IN GROUP B. C NENDB = THE PLACE IN IC( ) WHERE GROUP B ENDS. C IBITB = NUMBER OF BITS NEEDED TO HOLD VALUES IN GROUP B. C MINC = MINIMUM VALUE IN GROUP C. C MAXC = MAXIMUM VALUE IN GROUP C. C KTOTAL = COUNT OF NUMBER OF VALUES IN IC( ) PROCESSED. C NOUNT = NUMBER OF VALUES ADDED TO GROUP A. C LMISS = 0 WHEN IS523 = 0. WHEN PACKING INTO A C SPECIFIC NUMBER OF BITS, SAY MBITS, C THE MAXIMUM VALUE THAT CAN BE HANDLED IS C 2**MBITS-1. WHEN IS523 = 1, INDICATING C PRIMARY MISSING VALUES, THIS MAXIMUM VALUE C IS RESERVED TO HOLD THE PRIMARY MISSING VALUE C INDICATOR AND LMISS = 1. WHEN IS523 = 2, C THE VALUE JUST BELOW THE MAXIMUM (I.E., C 2**MBITS-2) IS RESERVED TO HOLD THE SECONDARY C MISSING VALUE INDICATOR AND LMISS = 2. C LMINPK = LOCAL VALUE OF MINPK. THIS WILL BE ADJUSTED C UPWARD WHENEVER NDG IS NOT LARGE ENOUGH TO HOLD C ALL THE GROUPS. C MALLOW = THE LARGEST ALLOWABLE VALUE FOR PACKING. C MISLLA = SET TO 1 WHEN ALL VALUES IN GROUP A ARE MISSING. C THIS IS USED TO DISTINGUISH BETWEEN A REAL C MINIMUM WHEN ALL VALUES ARE NOT MISSING C AND A MINIMUM THAT HAS BEEN SET TO ZERO WHEN C ALL VALUES ARE MISSING. 0 OTHERWISE. C NOTE THAT THIS DOES NOT DISTINGUISH BETWEEN C PRIMARY AND SECONDARY MISSINGS WHEN SECONDARY C MISSINGS ARE PRESENT. THIS MEANS THAT C LBIT( ) WILL NOT BE ZERO WITH THE RESULTING C COMPRESSION EFFICIENCY WHEN SECONDARY MISSINGS C ARE PRESENT. ALSO NOTE THAT A CHECK HAS BEEN C MADE EARLIER TO DETERMINE THAT SECONDARY C MISSINGS ARE REALLY THERE. C MISLLB = SET TO 1 WHEN ALL VALUES IN GROUP B ARE MISSING. C THIS IS USED TO DISTINGUISH BETWEEN A REAL C MINIMUM WHEN ALL VALUES ARE NOT MISSING C AND A MINIMUM THAT HAS BEEN SET TO ZERO WHEN C ALL VALUES ARE MISSING. 0 OTHERWISE. C MISLLC = PERFORMS THE SAME FUNCTION FOR GROUP C THAT C MISLLA AND MISLLB DO FOR GROUPS B AND C, C RESPECTIVELY. C IBXX2(J) = AN ARRAY THAT WHEN THIS ROUTINE IS FIRST ENTERED C IS SET TO 2**J, J=0,30. IBXX2(30) = 2**30, WHICH C IS THE LARGEST VALUE PACKABLE, BECAUSE 2**31 C IS LARGER THAN THE INTEGER WORD SIZE. C IFIRST = SET BY DATA STATEMENT TO 0. CHANGED TO 1 ON C FIRST C ENTRY WHEN IBXX2( ) IS FILLED. C MINAK = KEEPS TRACK OF THE LOCATION IN IC( ) WHERE THE C MINIMUM VALUE IN GROUP A IS LOCATED. C MAXAK = DOES THE SAME AS MINAK, EXCEPT FOR THE MAXIMUM. C MINBK = THE SAME AS MINAK FOR GROUP B. C MAXBK = THE SAME AS MAXAK FOR GROUP B. C MINCK = THE SAME AS MINAK FOR GROUP C. C MAXCK = THE SAME AS MAXAK FOR GROUP C. C ADDA = KEEPS TRACK WHETHER OR NOT AN ATTEMPT TO ADD C POINTS TO GROUP A WAS MADE. IF SO, THEN ADDA C KEEPS FROM TRYING TO PUT ONE BACK INTO B. C (LOGICAL) C IBITBS = KEEPS CURRENT VALUE IF IBITB SO THAT LOOP C ENDING AT 166 DOESN'T HAVE TO START AT C IBITB = 0 EVERY TIME. C MISSLX(J) = MALLOW EXCEPT WHEN A GROUP IS ALL ONE VALUE (AND C LBIT(J) = 0) AND THAT VALUE IS MISSING. IN C THAT CASE, MISSLX(J) IS MISSP OR MISSS. THIS C GETS INSERTED INTO JMIN(J) LATER AS THE C MISSING INDICATOR; IT CAN'T BE PUT IN UNTIL C THE END, BECAUSE JMIN( ) IS USED TO CALCULATE C THE MAXIMUM NUMBER OF BITS (IBITS) NEEDED TO C PACK JMIN( ). C 1 2 3 4 5 6 7 X C C NON SYSTEM SUBROUTINES CALLED C NONE C PARAMETER (MALLOW=2**30+1) C CHARACTER*1 CFEED LOGICAL ADDA C DIMENSION IC(NXY) DIMENSION JMIN(NDG),JMAX(NDG),LBIT(NDG),NOV(NDG) DIMENSION MISSLX(NDG) C MISSLX( ) IS AN AUTOMATIC ARRAY. DIMENSION IBXX2(0:30) C SAVE IBXX2 C DATA IFEED/12/ DATA IFIRST/0/ C IER=0 IERSAV=0 C CALL TIMPR(KFILDO,KFILDO,'START PACK_GP ') CFEED=CHAR(IFEED) C IRED=0 C IRED IS A FLAG. WHEN ZERO, REDUCE WILL BE CALLED. C IF REDUCE ABORTS, IRED = 1 AND IS NOT CALLED. IN C THIS CASE PACK_GP EXECUTES AGAIN EXCEPT FOR REDUCE. C IF(INC.LE.0)THEN IERSAV=717 C WRITE(KFILDO,101)INC C101 FORMAT(/' ****INC ='I8,' NOT CORRECT IN PACK_GP. 1 IS USED.') ENDIF C C THERE WILL BE A RESTART OF PACK_GP IF SUBROUTINE REDUCE C ABORTS. THIS SHOULD NOT HAPPEN, BUT IF IT DOES, PACK_GP C WILL COMPLETE WITHOUT SUBROUTINE REDUCE. A NON FATAL C DIAGNOSTIC RETURN IS PROVIDED. C 102 KINC=MAX(INC,1) LMINPK=MINPK C C CALCULATE THE POWERS OF 2 THE FIRST TIME ENTERED. C IF(IFIRST.EQ.0)THEN IFIRST=1 IBXX2(0)=1 C DO 104 J=1,30 IBXX2(J)=IBXX2(J-1)*2 104 CONTINUE C ENDIF C C THERE WILL BE A RESTART AT 105 IS NDG IS NOT LARGE ENOUGH. C A NON FATAL DIAGNOSTIC RETURN IS PROVIDED. C 105 KSTART=1 KTOTAL=0 LX=0 ADDA=.FALSE. LMISS=0 IF(IS523.EQ.1)LMISS=1 IF(IS523.EQ.2)LMISS=2 C C ************************************* C C THIS SECTION COMPUTES STATISTICS FOR GROUP A. GROUP A IS C A GROUP OF SIZE LMINPK. C C ************************************* C IBITA=0 MINA=MALLOW MAXA=-MALLOW MINAK=MALLOW MAXAK=-MALLOW C C FIND THE MIN AND MAX OF GROUP A. THIS WILL INITIALLY BE OF C SIZE LMINPK (IF THERE ARE STILL LMINPK VALUES IN IC( )), BUT C WILL INCREASE IN SIZE IN INCREMENTS OF INC UNTIL A NEW C GROUP IS STARTED. THE DEFINITION OF GROUP A IS DONE HERE C ONLY ONCE (UPON INITIAL ENTRY), BECAUSE A GROUP B CAN ALWAYS C BECOME A NEW GROUP A AFTER A IS PACKED, EXCEPT IF LMINPK C HAS TO BE INCREASED BECAUSE NDG IS TOO SMALL. THEREFORE, C THE SEPARATE LOOPS FOR MISSING AND NON-MISSING HERE BUYS C ALMOST NOTHING. C NENDA=MIN(KSTART+LMINPK-1,NXY) IF(NXY-NENDA.LE.LMINPK/2)NENDA=NXY C ABOVE STATEMENT GUARANTEES THE LAST GROUP IS GT LMINPK/2 BY C MAKING THE ACTUAL GROUP LARGER. IF A PROVISION LIKE THIS IS C NOT INCLUDED, THERE WILL MANY TIMES BE A VERY SMALL GROUP C AT THE END. USE SEPARATE LOOPS FOR MISSING AND NO MISSING C VALUES FOR EFFICIENCY. C C DETERMINE WHETHER THERE IS A LONG STRING OF THE SAME VALUE C UNLESS NENDA = NXY. THIS MAY ALLOW A LARGE GROUP A TO C START WITH, AS WITH MISSING VALUES. SEPARATE LOOPS FOR C MISSING OPTIONS. THIS SECTION IS ONLY EXECUTED ONCE, C IN DETERMINING THE FIRST GROUP. IT HELPS FOR AN ARRAY C OF MOSTLY MISSING VALUES OR OF ONE VALUE, SUCH AS C RADAR OR PRECIP DATA. C IF(NENDA.NE.NXY.AND.IC(KSTART).EQ.IC(KSTART+1))THEN C NO NEED TO EXECUTE IF FIRST TWO VALUES ARE NOT EQUAL. C IF(IS523.EQ.0)THEN C THIS LOOP IS FOR NO MISSING VALUES. C DO 111 K=KSTART+1,NXY C IF(IC(K).NE.IC(KSTART))THEN NENDA=MAX(NENDA,K-1) GO TO 114 ENDIF C 111 CONTINUE C NENDA=NXY C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME. C ELSEIF(IS523.EQ.1)THEN C THIS LOOP IS FOR PRIMARY MISSING VALUES ONLY. C DO 112 K=KSTART+1,NXY C IF(IC(K).NE.MISSP)THEN C IF(IC(K).NE.IC(KSTART))THEN NENDA=MAX(NENDA,K-1) GO TO 114 ENDIF C ENDIF C 112 CONTINUE C NENDA=NXY C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME. C ELSE C THIS LOOP IS FOR PRIMARY AND SECONDARY MISSING VALUES. C DO 113 K=KSTART+1,NXY C IF(IC(K).NE.MISSP.AND.IC(K).NE.MISSS)THEN C IF(IC(K).NE.IC(KSTART))THEN NENDA=MAX(NENDA,K-1) GO TO 114 ENDIF C ENDIF C 113 CONTINUE C NENDA=NXY C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME. ENDIF C ENDIF C 114 IF(IS523.EQ.0)THEN C DO 115 K=KSTART,NENDA IF(IC(K).LT.MINA)THEN MINA=IC(K) MINAK=K ENDIF IF(IC(K).GT.MAXA)THEN MAXA=IC(K) MAXAK=K ENDIF 115 CONTINUE C ELSEIF(IS523.EQ.1)THEN C DO 117 K=KSTART,NENDA IF(IC(K).EQ.MISSP)GO TO 117 IF(IC(K).LT.MINA)THEN MINA=IC(K) MINAK=K ENDIF IF(IC(K).GT.MAXA)THEN MAXA=IC(K) MAXAK=K ENDIF 117 CONTINUE C ELSE C DO 120 K=KSTART,NENDA IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 120 IF(IC(K).LT.MINA)THEN MINA=IC(K) MINAK=K ENDIF IF(IC(K).GT.MAXA)THEN MAXA=IC(K) MAXAK=K ENDIF 120 CONTINUE C ENDIF C KOUNTA=NENDA-KSTART+1 C C INCREMENT KTOTAL AND FIND THE BITS NEEDED TO PACK THE A GROUP. C KTOTAL=KTOTAL+KOUNTA MISLLA=0 IF(MINA.NE.MALLOW)GO TO 125 C ALL MISSING VALUES MUST BE ACCOMMODATED. MINA=0 MAXA=0 MISLLA=1 IBITB=0 IF(IS523.NE.2)GO TO 130 C WHEN ALL VALUES ARE MISSING AND THERE ARE NO C SECONDARY MISSING VALUES, IBITA = 0. C OTHERWISE, IBITA MUST BE CALCULATED. C 125 ITEST=MAXA-MINA+LMISS C DO 126 IBITA=0,30 IF(ITEST.LT.IBXX2(IBITA))GO TO 130 C*** THIS TEST IS THE SAME AS: C*** IF(MAXA-MINA.LT.IBXX2(IBITA)-LMISS)GO TO 130 126 CONTINUE C C WRITE(KFILDO,127)MAXA,MINA C127 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.', C 1 ' MAXA ='I13,' MINA ='I13,'. ERROR AT 127.') IER=706 GO TO 900 C 130 CONTINUE C C***D WRITE(KFILDO,131)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA C***D131 FORMAT(' AT 130, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8, C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3) C 133 IF(KTOTAL.GE.NXY)GO TO 200 C C ************************************* C C THIS SECTION COMPUTES STATISTICS FOR GROUP B. GROUP B IS A C GROUP OF SIZE LMINPK IMMEDIATELY FOLLOWING GROUP A. C C ************************************* C 140 MINB=MALLOW MAXB=-MALLOW MINBK=MALLOW MAXBK=-MALLOW IBITBS=0 MSTART=KTOTAL+1 C C DETERMINE WHETHER THERE IS A LONG STRING OF THE SAME VALUE. C THIS WORKS WHEN THERE ARE NO MISSING VALUES. C NENDB=1 C IF(MSTART.LT.NXY)THEN C IF(IS523.EQ.0)THEN C THIS LOOP IS FOR NO MISSING VALUES. C DO 145 K=MSTART+1,NXY C IF(IC(K).NE.IC(MSTART))THEN NENDB=K-1 GO TO 150 ENDIF C 145 CONTINUE C NENDB=NXY C FALL THROUGH THE LOOP MEANS ALL REMAINING VALUES C ARE THE SAME. ENDIF C ENDIF C 150 NENDB=MAX(NENDB,MIN(KTOTAL+LMINPK,NXY)) C**** 150 NENDB=MIN(KTOTAL+LMINPK,NXY) C IF(NXY-NENDB.LE.LMINPK/2)NENDB=NXY C ABOVE STATEMENT GUARANTEES THE LAST GROUP IS GT LMINPK/2 BY C MAKING THE ACTUAL GROUP LARGER. IF A PROVISION LIKE THIS IS C NOT INCLUDED, THERE WILL MANY TIMES BE A VERY SMALL GROUP C AT THE END. USE SEPARATE LOOPS FOR MISSING AND NO MISSING C C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES C FOR EFFICIENCY. C IF(IS523.EQ.0)THEN C DO 155 K=MSTART,NENDB IF(IC(K).LE.MINB)THEN MINB=IC(K) C NOTE LE, NOT LT. LT COULD BE USED BUT THEN A C RECOMPUTE OVER THE WHOLE GROUP WOULD BE NEEDED C MORE OFTEN. SAME REASONING FOR GE AND OTHER C LOOPS BELOW. MINBK=K ENDIF IF(IC(K).GE.MAXB)THEN MAXB=IC(K) MAXBK=K ENDIF 155 CONTINUE C ELSEIF(IS523.EQ.1)THEN C DO 157 K=MSTART,NENDB IF(IC(K).EQ.MISSP)GO TO 157 IF(IC(K).LE.MINB)THEN MINB=IC(K) MINBK=K ENDIF IF(IC(K).GE.MAXB)THEN MAXB=IC(K) MAXBK=K ENDIF 157 CONTINUE C ELSE C DO 160 K=MSTART,NENDB IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 160 IF(IC(K).LE.MINB)THEN MINB=IC(K) MINBK=K ENDIF IF(IC(K).GE.MAXB)THEN MAXB=IC(K) MAXBK=K ENDIF 160 CONTINUE C ENDIF C KOUNTB=NENDB-KTOTAL MISLLB=0 IF(MINB.NE.MALLOW)GO TO 165 C ALL MISSING VALUES MUST BE ACCOMMODATED. MINB=0 MAXB=0 MISLLB=1 IBITB=0 C IF(IS523.NE.2)GO TO 170 C WHEN ALL VALUES ARE MISSING AND THERE ARE NO SECONDARY C MISSING VALUES, IBITB = 0. OTHERWISE, IBITB MUST BE C CALCULATED. C 165 DO 166 IBITB=IBITBS,30 IF(MAXB-MINB.LT.IBXX2(IBITB)-LMISS)GO TO 170 166 CONTINUE C C WRITE(KFILDO,167)MAXB,MINB C167 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.', C 1 ' MAXB ='I13,' MINB ='I13,'. ERROR AT 167.') IER=706 GO TO 900 C C COMPARE THE BITS NEEDED TO PACK GROUP B WITH THOSE NEEDED C TO PACK GROUP A. IF IBITB GE IBITA, TRY TO ADD TO GROUP A. C IF NOT, TRY TO ADD A'S POINTS TO B, UNLESS ADDITION TO A C HAS BEEN DONE. THIS LATTER IS CONTROLLED WITH ADDA. C 170 CONTINUE C C***D WRITE(KFILDO,171)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA, C***D 1 MINB,MAXB,IBITB,MISLLB C***D171 FORMAT(' AT 171, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8, C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3, C***D 2 ' MINB ='I8,' MAXB ='I8,' IBITB ='I3,' MISLLB ='I3) C IF(IBITB.GE.IBITA)GO TO 180 IF(ADDA)GO TO 200 C C ************************************* C C GROUP B REQUIRES LESS BITS THAN GROUP A. PUT AS MANY OF A'S C POINTS INTO B AS POSSIBLE WITHOUT EXCEEDING THE NUMBER OF C BITS NECESSARY TO PACK GROUP B. C C ************************************* C KOUNTS=KOUNTA C KOUNTA REFERS TO THE PRESENT GROUP A. MINTST=MINB MAXTST=MAXB MINTSTK=MINBK MAXTSTK=MAXBK C C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES C FOR EFFICIENCY. C IF(IS523.EQ.0)THEN C DO 1715 K=KTOTAL,KSTART,-1 C START WITH THE END OF THE GROUP AND WORK BACKWARDS. IF(IC(K).LT.MINB)THEN MINTST=IC(K) MINTSTK=K ELSEIF(IC(K).GT.MAXB)THEN MAXTST=IC(K) MAXTSTK=K ENDIF IF(MAXTST-MINTST.GE.IBXX2(IBITB))GO TO 174 C NOTE THAT FOR THIS LOOP, LMISS = 0. MINB=MINTST MAXB=MAXTST MINBK=MINTSTK MAXBK=MAXTSTK KOUNTA=KOUNTA-1 C THERE IS ONE LESS POINT NOW IN A. 1715 CONTINUE C ELSEIF(IS523.EQ.1)THEN C DO 1719 K=KTOTAL,KSTART,-1 C START WITH THE END OF THE GROUP AND WORK BACKWARDS. IF(IC(K).EQ.MISSP)GO TO 1718 IF(IC(K).LT.MINB)THEN MINTST=IC(K) MINTSTK=K ELSEIF(IC(K).GT.MAXB)THEN MAXTST=IC(K) MAXTSTK=K ENDIF IF(MAXTST-MINTST.GE.IBXX2(IBITB)-LMISS)GO TO 174 C FOR THIS LOOP, LMISS = 1. MINB=MINTST MAXB=MAXTST MINBK=MINTSTK MAXBK=MAXTSTK MISLLB=0 C WHEN THE POINT IS NON MISSING, MISLLB SET = 0. 1718 KOUNTA=KOUNTA-1 C THERE IS ONE LESS POINT NOW IN A. 1719 CONTINUE C ELSE C DO 173 K=KTOTAL,KSTART,-1 C START WITH THE END OF THE GROUP AND WORK BACKWARDS. IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 1729 IF(IC(K).LT.MINB)THEN MINTST=IC(K) MINTSTK=K ELSEIF(IC(K).GT.MAXB)THEN MAXTST=IC(K) MAXTSTK=K ENDIF IF(MAXTST-MINTST.GE.IBXX2(IBITB)-LMISS)GO TO 174 C FOR THIS LOOP, LMISS = 2. MINB=MINTST MAXB=MAXTST MINBK=MINTSTK MAXBK=MAXTSTK MISLLB=0 C WHEN THE POINT IS NON MISSING, MISLLB SET = 0. 1729 KOUNTA=KOUNTA-1 C THERE IS ONE LESS POINT NOW IN A. 173 CONTINUE C ENDIF C C AT THIS POINT, KOUNTA CONTAINS THE NUMBER OF POINTS TO CLOSE C OUT GROUP A WITH. GROUP B NOW STARTS WITH KSTART+KOUNTA AND C ENDS WITH NENDB. MINB AND MAXB HAVE BEEN ADJUSTED AS C NECESSARY TO REFLECT GROUP B (EVEN THOUGH THE NUMBER OF BITS C NEEDED TO PACK GROUP B HAVE NOT INCREASED, THE END POINTS C OF THE RANGE MAY HAVE). C 174 IF(KOUNTA.EQ.KOUNTS)GO TO 200 C ON TRANSFER, GROUP A WAS NOT CHANGED. CLOSE IT OUT. C C ONE OR MORE POINTS WERE TAKEN OUT OF A. RANGE AND IBITA C MAY HAVE TO BE RECOMPUTED; IBITA COULD BE LESS THAN C ORIGINALLY COMPUTED. IN FACT, GROUP A CAN NOW CONTAIN C ONLY ONE POINT AND BE PACKED WITH ZERO BITS C (UNLESS MISSS NE 0). C NOUTA=KOUNTS-KOUNTA KTOTAL=KTOTAL-NOUTA KOUNTB=KOUNTB+NOUTA IF(NENDA-NOUTA.GT.MINAK.AND.NENDA-NOUTA.GT.MAXAK)GO TO 200 C WHEN THE ABOVE TEST IS MET, THE MIN AND MAX OF THE C CURRENT GROUP A WERE WITHIN THE OLD GROUP A, SO THE C RANGE AND IBITA DO NOT NEED TO BE RECOMPUTED. C NOTE THAT MINAK AND MAXAK ARE NO LONGER NEEDED. IBITA=0 MINA=MALLOW MAXA=-MALLOW C C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES C FOR EFFICIENCY. C IF(IS523.EQ.0)THEN C DO 1742 K=KSTART,NENDA-NOUTA IF(IC(K).LT.MINA)THEN MINA=IC(K) ENDIF IF(IC(K).GT.MAXA)THEN MAXA=IC(K) ENDIF 1742 CONTINUE C ELSEIF(IS523.EQ.1)THEN C DO 1744 K=KSTART,NENDA-NOUTA IF(IC(K).EQ.MISSP)GO TO 1744 IF(IC(K).LT.MINA)THEN MINA=IC(K) ENDIF IF(IC(K).GT.MAXA)THEN MAXA=IC(K) ENDIF 1744 CONTINUE C ELSE C DO 175 K=KSTART,NENDA-NOUTA IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 175 IF(IC(K).LT.MINA)THEN MINA=IC(K) ENDIF IF(IC(K).GT.MAXA)THEN MAXA=IC(K) ENDIF 175 CONTINUE C ENDIF C MISLLA=0 IF(MINA.NE.MALLOW)GO TO 1750 C ALL MISSING VALUES MUST BE ACCOMMODATED. MINA=0 MAXA=0 MISLLA=1 IF(IS523.NE.2)GO TO 177 C WHEN ALL VALUES ARE MISSING AND THERE ARE NO SECONDARY C MISSING VALUES IBITA = 0 AS ORIGINALLY SET. OTHERWISE, C IBITA MUST BE CALCULATED. C 1750 ITEST=MAXA-MINA+LMISS C DO 176 IBITA=0,30 IF(ITEST.LT.IBXX2(IBITA))GO TO 177 C*** THIS TEST IS THE SAME AS: C*** IF(MAXA-MINA.LT.IBXX2(IBITA)-LMISS)GO TO 177 176 CONTINUE C C WRITE(KFILDO,1760)MAXA,MINA C1760 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.', C 1 ' MAXA ='I13,' MINA ='I13,'. ERROR AT 1760.') IER=706 GO TO 900 C 177 CONTINUE GO TO 200 C C ************************************* C C AT THIS POINT, GROUP B REQUIRES AS MANY BITS TO PACK AS GROUPA. C THEREFORE, TRY TO ADD INC POINTS TO GROUP A WITHOUT INCREASING C IBITA. THIS AUGMENTED GROUP IS CALLED GROUP C. C C ************************************* C 180 IF(MISLLA.EQ.1)THEN MINC=MALLOW MINCK=MALLOW MAXC=-MALLOW MAXCK=-MALLOW ELSE MINC=MINA MAXC=MAXA MINCK=MINAK MAXCK=MINAK ENDIF C NOUNT=0 IF(NXY-(KTOTAL+KINC).LE.LMINPK/2)KINC=NXY-KTOTAL C ABOVE STATEMENT CONSTRAINS THE LAST GROUP TO BE NOT LESS THAN C LMINPK/2 IN SIZE. IF A PROVISION LIKE THIS IS NOT INCLUDED, C THERE WILL MANY TIMES BE A VERY SMALL GROUP AT THE END. C C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES C FOR EFFICIENCY. SINCE KINC IS USUALLY 1, USING SEPARATE C LOOPS HERE DOESN'T BUY MUCH. A MISSING VALUE WILL ALWAYS C TRANSFER BACK TO GROUP A. C IF(IS523.EQ.0)THEN C DO 185 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY) IF(IC(K).LT.MINC)THEN MINC=IC(K) MINCK=K ENDIF IF(IC(K).GT.MAXC)THEN MAXC=IC(K) MAXCK=K ENDIF NOUNT=NOUNT+1 185 CONTINUE C ELSEIF(IS523.EQ.1)THEN C DO 187 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY) IF(IC(K).EQ.MISSP)GO TO 186 IF(IC(K).LT.MINC)THEN MINC=IC(K) MINCK=K ENDIF IF(IC(K).GT.MAXC)THEN MAXC=IC(K) MAXCK=K ENDIF 186 NOUNT=NOUNT+1 187 CONTINUE C ELSE C DO 190 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY) IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 189 IF(IC(K).LT.MINC)THEN MINC=IC(K) MINCK=K ENDIF IF(IC(K).GT.MAXC)THEN MAXC=IC(K) MAXCK=K ENDIF 189 NOUNT=NOUNT+1 190 CONTINUE C ENDIF C C***D WRITE(KFILDO,191)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA, C***D 1 MINC,MAXC,NOUNT,IC(KTOTAL),IC(KTOTAL+1) C***D191 FORMAT(' AT 191, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8, C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3, C***D 2 ' MINC ='I8,' MAXC ='I8, C***D 3 ' NOUNT ='I5,' IC(KTOTAL) ='I9,' IC(KTOTAL+1) =',I9) C C IF THE NUMBER OF BITS NEEDED FOR GROUP C IS GT IBITA, C THEN THIS GROUP A IS A GROUP TO PACK. C IF(MINC.EQ.MALLOW)THEN MINC=MINA MAXC=MAXA MINCK=MINAK MAXCK=MAXAK MISLLC=1 GO TO 195 C WHEN THE NEW VALUE(S) ARE MISSING, THEY CAN ALWAYS C BE ADDED. C ELSE MISLLC=0 ENDIF C IF(MAXC-MINC.GE.IBXX2(IBITA)-LMISS) GO TO 200 C C THE BITS NECESSARY FOR GROUP C HAS NOT INCREASED FROM THE C BITS NECESSARY FOR GROUP A. ADD THIS POINT(S) TO GROUP A. C COMPUTE THE NEXT GROUP B, ETC., UNLESS ALL POINTS HAVE BEEN C USED. C 195 KTOTAL=KTOTAL+NOUNT KOUNTA=KOUNTA+NOUNT MINA=MINC MAXA=MAXC MINAK=MINCK MAXAK=MAXCK MISLLA=MISLLC ADDA=.TRUE. IF(KTOTAL.GE.NXY)GO TO 200 C IF(MINBK.GT.KTOTAL.AND.MAXBK.GT.KTOTAL)THEN MSTART=NENDB+1 C THE MAX AND MIN OF GROUP B WERE NOT FROM THE POINTS C REMOVED, SO THE WHOLE GROUP DOES NOT HAVE TO BE LOOKED C AT TO DETERMINE THE NEW MAX AND MIN. RATHER START C JUST BEYOND THE OLD NENDB. IBITBS=IBITB NENDB=1 GO TO 150 ELSE GO TO 140 ENDIF C C ************************************* C C GROUP A IS TO BE PACKED. STORE VALUES IN JMIN( ), JMAX( ), C LBIT( ), AND NOV( ). C C ************************************* C 200 LX=LX+1 IF(LX.LE.NDG)GO TO 205 LMINPK=LMINPK+LMINPK/2 C WRITE(KFILDO,201)NDG,LMINPK,LX C201 FORMAT(' ****NDG ='I5,' NOT LARGE ENOUGH.', C 1 ' LMINPK IS INCREASED TO 'I3,' FOR THIS FIELD.'/ C 2 ' LX = 'I10) IERSAV=716 GO TO 105 C 205 JMIN(LX)=MINA JMAX(LX)=MAXA LBIT(LX)=IBITA NOV(LX)=KOUNTA KSTART=KTOTAL+1 C IF(MISLLA.EQ.0)THEN MISSLX(LX)=MALLOW ELSE MISSLX(LX)=IC(KTOTAL) C IC(KTOTAL) WAS THE LAST VALUE PROCESSED. IF MISLLA NE 0, C THIS MUST BE THE MISSING VALUE FOR THIS GROUP. ENDIF C C***D WRITE(KFILDO,206)MISLLA,IC(KTOTAL),KTOTAL,LX,JMIN(LX),JMAX(LX), C***D 1 LBIT(LX),NOV(LX),MISSLX(LX) C***D206 FORMAT(' AT 206, MISLLA ='I2,' IC(KTOTAL) ='I5,' KTOTAL ='I8, C***D 1 ' LX ='I6,' JMIN(LX) ='I8,' JMAX(LX) ='I8, C***D 2 ' LBIT(LX) ='I5,' NOV(LX) ='I8,' MISSLX(LX) =',I7) C IF(KTOTAL.GE.NXY)GO TO 209 C C THE NEW GROUP A WILL BE THE PREVIOUS GROUP B. SET LIMITS, ETC. C IBITA=IBITB MINA=MINB MAXA=MAXB MINAK=MINBK MAXAK=MAXBK MISLLA=MISLLB NENDA=NENDB KOUNTA=KOUNTB KTOTAL=KTOTAL+KOUNTA ADDA=.FALSE. GO TO 133 C C ************************************* C C CALCULATE IBIT, THE NUMBER OF BITS NEEDED TO HOLD THE GROUP C MINIMUM VALUES. C C ************************************* C 209 IBIT=0 C DO 220 L=1,LX 210 IF(JMIN(L).LT.IBXX2(IBIT))GO TO 220 IBIT=IBIT+1 GO TO 210 220 CONTINUE C C INSERT THE VALUE IN JMIN( ) TO BE USED FOR ALL MISSING C VALUES WHEN LBIT( ) = 0. WHEN SECONDARY MISSING C VALUES CAN BE PRESENT, LBIT(L) WILL NOT = 0. C IF(IS523.EQ.1)THEN C DO 226 L=1,LX C IF(LBIT(L).EQ.0)THEN C IF(MISSLX(L).EQ.MISSP)THEN JMIN(L)=IBXX2(IBIT)-1 ENDIF C ENDIF C 226 CONTINUE C ENDIF C C ************************************* C C CALCULATE JBIT, THE NUMBER OF BITS NEEDED TO HOLD THE BITS C NEEDED TO PACK THE VALUES IN THE GROUPS. BUT FIND AND C REMOVE THE REFERENCE VALUE FIRST. C C ************************************* C C WRITE(KFILDO,228)CFEED,LX C228 FORMAT(A1,/' *****************************************' C 1 /' THE GROUP WIDTHS LBIT( ) FOR ',I8,' GROUPS' C 2 /' *****************************************') C WRITE(KFILDO,229) (LBIT(J),J=1,MIN(LX,100)) C229 FORMAT(/' '20I6) C LBITREF=LBIT(1) C DO 230 K=1,LX IF(LBIT(K).LT.LBITREF)LBITREF=LBIT(K) 230 CONTINUE C IF(LBITREF.NE.0)THEN C DO 240 K=1,LX LBIT(K)=LBIT(K)-LBITREF 240 CONTINUE C ENDIF C C WRITE(KFILDO,241)CFEED,LBITREF C241 FORMAT(A1,/' *****************************************' C 1 /' THE GROUP WIDTHS LBIT( ) AFTER REMOVING REFERENCE ', C 2 I8, C 3 /' *****************************************') C WRITE(KFILDO,242) (LBIT(J),J=1,MIN(LX,100)) C242 FORMAT(/' '20I6) C JBIT=0 C DO 320 K=1,LX 310 IF(LBIT(K).LT.IBXX2(JBIT))GO TO 320 JBIT=JBIT+1 GO TO 310 320 CONTINUE C C ************************************* C C CALCULATE KBIT, THE NUMBER OF BITS NEEDED TO HOLD THE NUMBER C OF VALUES IN THE GROUPS. BUT FIND AND REMOVE THE C REFERENCE FIRST. C C ************************************* C C WRITE(KFILDO,321)CFEED,LX C321 FORMAT(A1,/' *****************************************' C 1 /' THE GROUP SIZES NOV( ) FOR ',I8,' GROUPS' C 2 /' *****************************************') C WRITE(KFILDO,322) (NOV(J),J=1,MIN(LX,100)) C322 FORMAT(/' '20I6) C NOVREF=NOV(1) C DO 400 K=1,LX IF(NOV(K).LT.NOVREF)NOVREF=NOV(K) 400 CONTINUE C IF(NOVREF.GT.0)THEN C DO 405 K=1,LX NOV(K)=NOV(K)-NOVREF 405 CONTINUE C ENDIF C C WRITE(KFILDO,406)CFEED,NOVREF C406 FORMAT(A1,/' *****************************************' C 1 /' THE GROUP SIZES NOV( ) AFTER REMOVING REFERENCE ',I8, C 2 /' *****************************************') C WRITE(KFILDO,407) (NOV(J),J=1,MIN(LX,100)) C407 FORMAT(/' '20I6) C WRITE(KFILDO,408)CFEED C408 FORMAT(A1,/' *****************************************' C 1 /' THE GROUP REFERENCES JMIN( )' C 2 /' *****************************************') C WRITE(KFILDO,409) (JMIN(J),J=1,MIN(LX,100)) C409 FORMAT(/' '20I6) C KBIT=0 C DO 420 K=1,LX 410 IF(NOV(K).LT.IBXX2(KBIT))GO TO 420 KBIT=KBIT+1 GO TO 410 420 CONTINUE C C DETERMINE WHETHER THE GROUP SIZES SHOULD BE REDUCED C FOR SPACE EFFICIENCY. C IF(IRED.EQ.0)THEN CALL REDUCE(KFILDO,JMIN,JMAX,LBIT,NOV,LX,NDG,IBIT,JBIT,KBIT, 1 NOVREF,IBXX2,IER) C IF(IER.EQ.714.OR.IER.EQ.715)THEN C REDUCE HAS ABORTED. REEXECUTE PACK_GP WITHOUT REDUCE. C PROVIDE FOR A NON FATAL RETURN FROM REDUCE. IERSAV=IER IRED=1 IER=0 GO TO 102 ENDIF C ENDIF C C CALL TIMPR(KFILDO,KFILDO,'END PACK_GP ') IF(IERSAV.NE.0)THEN IER=IERSAV RETURN ENDIF C C 900 IF(IER.NE.0)RETURN1 C 900 RETURN END