SUBROUTINE REDUCE(KFILDO,JMIN,JMAX,LBIT,NOV,LX,NDG,IBIT,JBIT,KBIT, 1
1 NOVREF,IBXX2,IER)
C
C NOVEMBER 2001 GLAHN TDL GRIB2
C MARCH 2002 GLAHN COMMENT IER = 715
C MARCH 2002 GLAHN MODIFIED TO ACCOMMODATE LX=1 ON ENTRY
C
C PURPOSE
C DETERMINES WHETHER THE NUMBER OF GROUPS SHOULD BE
C INCREASED IN ORDER TO REDUCE THE SIZE OF THE LARGE
C GROUPS, AND TO MAKE THAT ADJUSTMENT. BY REDUCING THE
C SIZE OF THE LARGE GROUPS, LESS BITS MAY BE NECESSARY
C FOR PACKING THE GROUP SIZES AND ALL THE INFORMATION
C ABOUT THE GROUPS.
C
C THE REFERENCE FOR NOV( ) WAS REMOVED IN THE CALLING
C ROUTINE SO THAT KBIT COULD BE DETERMINED. THIS
C FURNISHES A STARTING POINT FOR THE ITERATIONS IN REDUCE.
C HOWEVER, THE REFERENCE MUST BE CONSIDERED.
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 JMIN(J) = THE MINIMUM OF EACH GROUP (J=1,LX). IT IS
C POSSIBLE AFTER SPLITTING THE GROUPS, JMIN( )
C WILL NOT BE THE MINIMUM OF THE NEW GROUP.
C THIS DOESN'T MATTER; JMIN( ) IS REALLY THE
C GROUP REFERENCE AND DOESN'T HAVE TO BE THE
C SMALLEST VALUE. (INPUT/OUTPUT)
C JMAX(J) = THE MAXIMUM OF EACH GROUP (J=1,LX).
C (INPUT/OUTPUT)
C LBIT(J) = THE NUMBER OF BITS NECESSARY TO PACK EACH GROUP
C (J=1,LX). (INPUT/OUTPUT)
C NOV(J) = THE NUMBER OF VALUES IN EACH GROUP (J=1,LX).
C (INPUT/OUTPUT)
C LX = THE NUMBER OF GROUPS. THIS WILL BE INCREASED
C IF GROUPS ARE SPLIT. (INPUT/OUTPUT)
C NDG = THE DIMENSION OF JMIN( ), JMAX( ), LBIT( ), AND
C NOV( ). (INPUT)
C IBIT = THE NUMBER OF BITS NECESSARY TO PACK THE JMIN(J)
C VALUES, J=1,LX. (INPUT)
C JBIT = THE NUMBER OF BITS NECESSARY TO PACK THE LBIT(J)
C VALUES, J=1,LX. (INPUT)
C KBIT = THE NUMBER OF BITS NECESSARY TO PACK THE NOV(J)
C VALUES, J=1,LX. IF THE GROUPS ARE SPLIT, KBIT
C IS REDUCED. (INPUT/OUTPUT)
C NOVREF = REFERENCE VALUE FOR NOV( ). (INPUT)
C IBXX2(J) = 2**J (J=0,30). (INPUT)
C IER = ERROR RETURN. (OUTPUT)
C 0 = GOOD RETURN.
C 714 = PROBLEM IN ALGORITHM. REDUCE ABORTED.
C 715 = NGP NOT LARGE ENOUGH. REDUCE ABORTED.
C NTOTBT(J) = THE TOTAL BITS USED FOR THE PACKING BITS J
C (J=1,30). (INTERNAL)
C NBOXJ(J) = NEW BOXES NEEDED FOR THE PACKING BITS J
C (J=1,30). (INTERNAL)
C NEWBOX(L) = NUMBER OF NEW BOXES (GROUPS) FOR EACH ORIGINAL
C GROUP (L=1,LX) FOR THE CURRENT J. (AUTOMATIC)
C (INTERNAL)
C NEWBOXP(L) = SAME AS NEWBOX( ) BUT FOR THE PREVIOUS J.
C THIS ELIMINATES RECOMPUTATION. (AUTOMATIC)
C (INTERNAL)
C CFEED = CONTAINS THE CHARACTER REPRESENTATION
C OF A PRINTER FORM FEED. (CHARACTER) (INTERNAL)
C IFEED = CONTAINS THE INTEGER VALUE OF A PRINTER
C FORM FEED. (INTERNAL)
C IORIGB = THE ORIGINAL NUMBER OF BITS NECESSARY
C FOR THE GROUP VALUES. (INTERNAL)
C 1 2 3 4 5 6 7 X
C
C NON SYSTEM SUBROUTINES CALLED
C NONE
c
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(31),NBOXJ(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=1,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