reduce.f

Go to the documentation of this file.

 
 
      SUBROUTINE reduce(KFILDO,JMIN,JMAX,LBIT,NOV,LX,NDG,IBIT,JBIT,KBIT,
     1                  NOVREF,IBXX2,IER)            
 
      CHARACTER*1 CFEED
C
      dimension jmin(ndg),jmax(ndg),lbit(ndg),nov(ndg)
      dimension newbox(ndg),newboxp(ndg)
C        NEWBOX( ) AND NEWBOXP( ) ARE AUTOMATIC ARRAYS.
      dimension ntotbt(0:31),nboxj(0:31)
      dimension ibxx2(0:30)
C
      DATA ifeed/12/
C
      ier=0
      IF(lx.EQ.1)GO TO 410
C        IF THERE IS ONLY ONE GROUP, RETURN.
C
      cfeed=char(ifeed)
C
C        INITIALIZE NUMBER OF NEW BOXES PER GROUP TO ZERO.
C
      DO 110 l=1,lx
         newbox(l)=0
 110  CONTINUE
C
C        INITIALIZE NUMBER OF TOTAL NEW BOXES PER J TO ZERO.
C
      DO 112 j=0,31
         ntotbt(j)=999999999
         nboxj(j)=0
 112  CONTINUE
C
      iorigb=(ibit+jbit+kbit)*lx
C        IBIT = BITS TO PACK THE JMIN( ).
C        JBIT = BITS TO PACK THE LBIT( ).
C        KBIT = BITS TO PACK THE NOV( ).
C        LX = NUMBER OF GROUPS.
         ntotbt(kbit)=iorigb
C           THIS IS THE VALUE OF TOTAL BITS FOR THE ORIGINAL LX
C           GROUPS, WHICH REQUIRES KBITS TO PACK THE GROUP
C           LENGHTS.  SETTING THIS HERE MAKES ONE LESS LOOPS
C           NECESSARY BELOW.
C
C        COMPUTE BITS NOW USED FOR THE PARAMETERS DEFINED.
C
C        DETERMINE OTHER POSSIBILITES BY INCREASING LX AND DECREASING
C        NOV( ) WITH VALUES GREATER THAN THRESHOLDS.  ASSUME A GROUP IS
C        SPLIT INTO 2 OR MORE GROUPS SO THAT KBIT IS REDUCED WITHOUT
C        CHANGING IBIT OR JBIT.
C
      jj=0
C
      DO 200 j=min(30,kbit-1),2,-1
C           VALUES GE KBIT WILL NOT REQUIRE SPLITS.  ONCE THE TOTAL
C           BITS START INCREASING WITH DECREASING J, STOP.  ALSO, THE
C           NUMBER OF BITS REQUIRED IS KNOWN FOR KBITS = NTOTBT(KBIT).
C
         newboxt=0
C
         DO 190 l=1,lx
C
            IF(nov(l).LT.ibxx2(j))THEN
               newbox(l)=0
C                 NO SPLITS OR NEW BOXES.
               GO TO 190
            ELSE
               novl=nov(l)
C
               m=(nov(l)-1)/(ibxx2(j)-1)+1
C                 M IS FOUND BY SOLVING THE EQUATION BELOW FOR M:
C                 (NOV(L)+M-1)/M LT IBXX2(J)
C                 M GT (NOV(L)-1)/(IBXX2(J)-1)
C                 SET M = (NOV(L)-1)/(IBXX2(J)-1)+1
 130           novl=(nov(l)+m-1)/m
C                 THE +M-1 IS NECESSARY.  FOR INSTANCE, 15 WILL FIT
C                 INTO A BOX 4 BITS WIDE, BUT WON'T DIVIDE INTO
C                 TWO BOXES 3 BITS WIDE EACH.
C      
               IF(novl.LT.ibxx2(j))THEN
                  GO TO 185
               ELSE
                  m=m+1
C***                  WRITE(KFILDO,135)L,NOV(L),NOVL,M,J,IBXX2(J)
C*** 135              FORMAT(/' AT 135--L,NOV(L),NOVL,M,J,IBXX2(J)',6I10)               
                  GO TO 130
               ENDIF
C
C                 THE ABOVE DO LOOP WILL NEVER COMPLETE.
            ENDIF
C
 185        newbox(l)=m-1
            newboxt=newboxt+m-1
 190     CONTINUE
C
         nboxj(j)=newboxt
         ntotpr=ntotbt(j+1)
         ntotbt(j)=(ibit+jbit)*(lx+newboxt)+j*(lx+newboxt)
C
         IF(ntotbt(j).GE.ntotpr)THEN
            jj=j+1
C              THE PLUS IS USED BECAUSE J DECREASES PER ITERATION.
            GO TO 250
         ELSE
C
C              SAVE THE TOTAL NEW BOXES AND NEWBOX( ) IN CASE THIS
C              IS THE J TO USE.
C
            newboxtp=newboxt
C
            DO 195 l=1,lx
               newboxp(l)=newbox(l)
 195        CONTINUE
C
C           WRITE(KFILDO,197)NEWBOXT,IBXX2(J)
C197        FORMAT(/' *****************************************'
C    1             /' THE NUMBER OF NEWBOXES PER GROUP OF THE TOTAL',
C    2              I10,' FOR GROUP MAXSIZE PLUS 1 ='I10
C    3             /' *****************************************')
C           WRITE(KFILDO,198) (NEWBOX(L),L=1,LX)
C198        FORMAT(/' '20I6/(' '20I6))
    
         ENDIF
C        
C205     WRITE(KFILDO,209)KBIT,IORIGB
C209     FORMAT(/' ORIGINAL BITS WITH KBIT OF',I5,' =',I10)
C        WRITE(KFILDO,210)(N,N=2,10),(IBXX2(N),N=2,10),
C    1                    (NTOTBT(N),N=2,10),(NBOXJ(N),N=2,10),
C    2                    (N,N=11,20),(IBXX2(N),N=11,20),
C    3                    (NTOTBT(N),N=11,20),(NBOXJ(N),N=11,20),
C    4                    (N,N=21,30),(IBXX2(N),N=11,20),
C    5                    (NTOTBT(N),N=21,30),(NBOXJ(N),N=21,30)
C210     FORMAT(/' THE TOTAL BYTES FOR MAXIMUM GROUP LENGTHS BY ROW'//
C    1      '   J         = THE NUMBER OF BITS PER GROUP LENGTH'/
C    2      '   IBXX2(J)  = THE MAXIMUM GROUP LENGTH PLUS 1 FOR THIS J'/
C    3      '   NTOTBT(J) = THE TOTAL BITS FOR THIS J'/
C    4      '   NBOXJ(J)  = THE NEW GROUPS FOR THIS J'/
C    5      4(/10X,9I10)/4(/10I10)/4(/10I10))
C
 200  CONTINUE
C
 250  pimp=((iorigb-ntotbt(jj))/float(iorigb))*100.
C     WRITE(KFILDO,252)PIMP,KBIT,JJ
C252  FORMAT(/' PERCENT IMPROVEMENT =',F6.1,
C    1        ' BY DECREASING GROUP LENGTHS FROM',I4,' TO',I4,' BITS')
      IF(pimp.GE.2.)THEN
C
C        WRITE(KFILDO,255)CFEED,NEWBOXTP,IBXX2(JJ)
C255     FORMAT(A1,/' *****************************************'
C    1             /' THE NUMBER OF NEWBOXES PER GROUP OF THE TOTAL',
C    2             I10,' FOR GROUP MAXSIZE PLUS 1 ='I10
C    2             /' *****************************************')
C        WRITE(KFILDO,256) (NEWBOXP(L),L=1,LX)
C256     FORMAT(/' '20I6)
C
C           ADJUST GROUP LENGTHS FOR MAXIMUM LENGTH OF JJ BITS.
C           THE MIN PER GROUP AND THE NUMBER OF BITS REQUIRED
C           PER GROUP ARE NOT CHANGED.  THIS MAY MEAN THAT A
C           GROUP HAS A MIN (OR REFERENCE) THAT IS NOT ZERO.
C           THIS SHOULD NOT MATTER TO THE UNPACKER.
C
         lxnkp=lx+newboxtp
C           LXNKP = THE NEW NUMBER OF BOXES
C  
         IF(lxnkp.GT.ndg)THEN
C              DIMENSIONS NOT LARGE ENOUGH.  PROBABLY AN ERROR
C              OF SOME SORT.  ABORT.
C           WRITE(KFILDO,257)NDG,LXNPK
C        1         2         3         4         5         6         7 X
C257        FORMAT(/' DIMENSIONS OF JMIN, ETC. IN REDUCE =',I8,
C    1              ' NOT LARGE ENOUGH FOR THE EXPANDED NUMBER OF',
C    2              ' GROUPS =',I8,'.  ABORT REDUCE.')
            ier=715
            GO TO 410
C              AN ABORT CAUSES THE CALLING PROGRAM TO REEXECUTE 
C              WITHOUT CALLING REDUCE.
         ENDIF
C
         lxn=lxnkp
C           LXN IS THE NUMBER OF THE BOX IN THE NEW SERIES BEING
C           FILLED.  IT DECREASES PER ITERATION.
         ibxx2m1=ibxx2(jj)-1
C           IBXX2M1 IS THE MAXIMUM NUMBER OF VALUES PER GROUP.
C
         DO 300 l=lx,1,-1
C
C              THE VALUES IS NOV( ) REPRESENT THOSE VALUES + NOVREF.
C              WHEN VALUES ARE MOVED TO ANOTHER BOX, EACH VALUE
C              MOVED TO A NEW BOX REPRESENTS THAT VALUE + NOVREF.
C              THIS HAS TO BE CONSIDERED IN MOVING VALUES.
C
            IF(newboxp(l)*(ibxx2m1+novref)+novref.GT.nov(l)+novref)THEN
C                 IF THE ABOVE TEST IS MET, THEN MOVING IBXX2M1 VALUES
C                 FOR ALL NEW BOXES WILL LEAVE A NEGATIVE NUMBER FOR
C                 THE LAST BOX.  NOT A TOLERABLE SITUATION.
               movmin=(nov(l)-(newboxp(l))*novref)/newboxp(l)
               left=nov(l)
C                 LEFT = THE NUMBER OF VALUES TO MOVE FROM THE ORIGINAL
C                 BOX TO EACH NEW BOX EXCEPT THE LAST.  LEFT IS THE
C                 NUMBER LEFT TO MOVE.
            ELSE
               movmin=ibxx2m1
C                 MOVMIN VALUES CAN BE MOVED FOR EACH NEW BOX.
               left=nov(l)
C                 LEFT IS THE NUMBER OF VALUES LEFT TO MOVE.
            ENDIF
C
            IF(newboxp(l).GT.0)THEN
               IF((movmin+novref)*newboxp(l)+novref.LE.nov(l)+novref.
     1          and.(movmin+novref)*(newboxp(l)+1).GE.nov(l)+novref)THEN
                  GO TO 288
               ELSE
C***D                 WRITE(KFILDO,287)L,MOVMIN,NOVREF,NEWBOXP(L),NOV(L)
C***D287              FORMAT(/' AT 287 IN REDUCE--L,MOVMIN,NOVREF,',
C***D    1                    'NEWBOXP(L),NOV(L)',5I12
C***D    2                    ' REDUCE ABORTED.')
C              WRITE(KFILDO,2870)
C2870          FORMAT(/' AN ERROR IN REDUCE ALGORITHM.  ABORT REDUCE.')
               ier=714
               GO TO 410
C                 AN ABORT CAUSES THE CALLING PROGRAM TO REEXECUTE 
C                 WITHOUT CALLING REDUCE.
               ENDIF
C
            ENDIF
C
 288        DO 290 j=1,newboxp(l)+1
               move=min(movmin,left)
               jmin(lxn)=jmin(l)
               jmax(lxn)=jmax(l)
               lbit(lxn)=lbit(l)
               nov(lxn)=move
               lxn=lxn-1
               left=left-(move+novref)
C                 THE MOVE OF MOVE VALUES REALLY REPRESENTS A MOVE OF
C                 MOVE + NOVREF VALUES.
 290        CONTINUE
C
            IF(left.NE.-novref)THEN
C***               WRITE(KFILDO,292)L,LXN,MOVE,LXNKP,IBXX2(JJ),LEFT,NOV(L),
C***     1                          MOVMIN
C*** 292           FORMAT(' AT 292 IN REDUCE--L,LXN,MOVE,LXNKP,',
C***     1                'IBXX2(JJ),LEFT,NOV(L),MOVMIN'/8I12)
            ENDIF
C     
 300     CONTINUE
C
         lx=lxnkp
C           LX IS NOW THE NEW NUMBER OF GROUPS.
         kbit=jj
C           KBIT IS NOW THE NEW NUMBER OF BITS REQUIRED FOR PACKING
C           GROUP LENGHTS.
      ENDIF
C
C     WRITE(KFILDO,406)CFEED,LX
C406  FORMAT(A1,/' *****************************************'
C    1          /' THE GROUP SIZES NOV( ) AFTER REDUCTION IN SIZE',
C    2           ' FOR'I10,' GROUPS',
C    3          /' *****************************************')
C     WRITE(KFILDO,407) (NOV(J),J=1,LX)
C407  FORMAT(/' '20I6)
C     WRITE(KFILDO,408)CFEED,LX
C408  FORMAT(A1,/' *****************************************'
C    1          /' THE GROUP MINIMA JMIN( ) AFTER REDUCTION IN SIZE',
C    2           ' FOR'I10,' GROUPS',
C    3          /' *****************************************')
C     WRITE(KFILDO,409) (JMIN(J),J=1,LX)
C409  FORMAT(/' '20I6)
C
 410  RETURN
      END