pack_gp.f

Go to the documentation of this file.

 
 
      SUBROUTINE pack_gp(IC,NXY,IS523,MINPK,INC,MISSP,MISSS,
     1                   JMIN,JMAX,LBIT,NOV,NDG,LX,IBIT,JBIT,KBIT,
     2                   NOVREF,LBITREF,IER)            
 
      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.
      INTEGER, PARAMETER :: IBXX2(0:30) = (/ 1, 2, 4, 8, 16, 32, 64,    &
     &     128, 256, 512, 1024, 2048, 4096, 8192, 16384, 32768, 65536,  &
     &     131072, 262144, 524288, 1048576, 2097152, 4194304, 8388608,  &
     &     16777216, 33554432, 67108864, 134217728, 268435456,          &
     &     536870912, 1073741824 /)
C
      
      parameter(ifeed=12)
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        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(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