SUBROUTINE PACK_GP(KFILDO,IC,NXY,IS523,MINPK,INC,MISSP,MISSS, 2,1
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