ungrib/src/ngl/g2/reduce.f

   1       SUBROUTINE REDUCE(KFILDO,JMIN,JMAX,LBIT,NOV,LX,NDG,IBIT,JBIT,KBIT,
   2      1                  NOVREF,IBXX2,IER)
   3 C
   4 C        NOVEMBER 2001   GLAHN   TDL   GRIB2
   5 C        MARCH    2002   GLAHN   COMMENT IER = 715
   6 C        MARCH    2002   GLAHN   MODIFIED TO ACCOMMODATE LX=1 ON ENTRY
   7 C
   8 C        PURPOSE
   9 C            DETERMINES WHETHER THE NUMBER OF GROUPS SHOULD BE
  10 C            INCREASED IN ORDER TO REDUCE THE SIZE OF THE LARGE
  11 C            GROUPS, AND TO MAKE THAT ADJUSTMENT.  BY REDUCING THE
  12 C            SIZE OF THE LARGE GROUPS, LESS BITS MAY BE NECESSARY
  13 C            FOR PACKING THE GROUP SIZES AND ALL THE INFORMATION
  14 C            ABOUT THE GROUPS.
  15 C
  16 C            THE REFERENCE FOR NOV( ) WAS REMOVED IN THE CALLING
  17 C            ROUTINE SO THAT KBIT COULD BE DETERMINED.  THIS
  18 C            FURNISHES A STARTING POINT FOR THE ITERATIONS IN REDUCE.
  19 C            HOWEVER, THE REFERENCE MUST BE CONSIDERED.
  20 C
  21 C        DATA SET USE
  22 C           KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT)
  23 C
  24 C        VARIABLES IN CALL SEQUENCE
  25 C              KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE.  (INPUT)
  26 C             JMIN(J) = THE MINIMUM OF EACH GROUP (J=1,LX).  IT IS
  27 C                       POSSIBLE AFTER SPLITTING THE GROUPS, JMIN( )
  28 C                       WILL NOT BE THE MINIMUM OF THE NEW GROUP.
  29 C                       THIS DOESN'T MATTER; JMIN( ) IS REALLY THE
  30 C                       GROUP REFERENCE AND DOESN'T HAVE TO BE THE
  31 C                       SMALLEST VALUE.  (INPUT/OUTPUT)
  32 C             JMAX(J) = THE MAXIMUM OF EACH GROUP (J=1,LX).
  33 C                       (INPUT/OUTPUT)
  34 C             LBIT(J) = THE NUMBER OF BITS NECESSARY TO PACK EACH GROUP
  35 C                       (J=1,LX).  (INPUT/OUTPUT)
  36 C              NOV(J) = THE NUMBER OF VALUES IN EACH GROUP (J=1,LX).
  37 C                       (INPUT/OUTPUT)
  38 C                  LX = THE NUMBER OF GROUPS.  THIS WILL BE INCREASED
  39 C                       IF GROUPS ARE SPLIT.  (INPUT/OUTPUT)
  40 C                 NDG = THE DIMENSION OF JMIN( ), JMAX( ), LBIT( ), AND
  41 C                       NOV( ).  (INPUT)
  42 C                IBIT = THE NUMBER OF BITS NECESSARY TO PACK THE JMIN(J)
  43 C                       VALUES, J=1,LX.  (INPUT)
  44 C                JBIT = THE NUMBER OF BITS NECESSARY TO PACK THE LBIT(J)
  45 C                       VALUES, J=1,LX.  (INPUT)
  46 C                KBIT = THE NUMBER OF BITS NECESSARY TO PACK THE NOV(J)
  47 C                       VALUES, J=1,LX.  IF THE GROUPS ARE SPLIT, KBIT
  48 C                       IS REDUCED.  (INPUT/OUTPUT)
  49 C              NOVREF = REFERENCE VALUE FOR NOV( ).  (INPUT)
  50 C            IBXX2(J) = 2**J (J=0,30).  (INPUT)
  51 C                 IER = ERROR RETURN.  (OUTPUT)
  52 C                         0 = GOOD RETURN.
  53 C                       714 = PROBLEM IN ALGORITHM.  REDUCE ABORTED.
  54 C                       715 = NGP NOT LARGE ENOUGH.  REDUCE ABORTED.
  55 C           NTOTBT(J) = THE TOTAL BITS USED FOR THE PACKING BITS J
  56 C                       (J=1,30).  (INTERNAL)
  57 C            NBOXJ(J) = NEW BOXES NEEDED FOR THE PACKING BITS J
  58 C                       (J=1,30).  (INTERNAL)
  59 C           NEWBOX(L) = NUMBER OF NEW BOXES (GROUPS) FOR EACH ORIGINAL
  60 C                       GROUP (L=1,LX) FOR THE CURRENT J.  (AUTOMATIC)
  61 C                       (INTERNAL)
  62 C          NEWBOXP(L) = SAME AS NEWBOX( ) BUT FOR THE PREVIOUS J.
  63 C                       THIS ELIMINATES RECOMPUTATION.  (AUTOMATIC)
  64 C                       (INTERNAL)
  65 C               CFEED = CONTAINS THE CHARACTER REPRESENTATION
  66 C                       OF A PRINTER FORM FEED.  (CHARACTER) (INTERNAL)
  67 C               IFEED = CONTAINS THE INTEGER VALUE OF A PRINTER
  68 C                       FORM FEED.  (INTERNAL)
  69 C              IORIGB = THE ORIGINAL NUMBER OF BITS NECESSARY
  70 C                       FOR THE GROUP VALUES.  (INTERNAL)
  71 C        1         2         3         4         5         6         7 X
  72 C
  73 C        NON SYSTEM SUBROUTINES CALLED
  74 C           NONE
  75 c
  76       CHARACTER*1 CFEED
  77 C
  78       DIMENSION JMIN(NDG),JMAX(NDG),LBIT(NDG),NOV(NDG)
  79       DIMENSION NEWBOX(NDG),NEWBOXP(NDG)
  80 C        NEWBOX( ) AND NEWBOXP( ) ARE AUTOMATIC ARRAYS.
  81       DIMENSION NTOTBT(31),NBOXJ(31)
  82       DIMENSION IBXX2(0:30)
  83 C
  84       DATA IFEED/12/
  85 C
  86       IER=0
  87       IF(LX.EQ.1)GO TO 410
  88 C        IF THERE IS ONLY ONE GROUP, RETURN.
  89 C
  90       CFEED=CHAR(IFEED)
  91 C
  92 C        INITIALIZE NUMBER OF NEW BOXES PER GROUP TO ZERO.
  93 C
  94       DO 110 L=1,LX
  95          NEWBOX(L)=0
  96  110  CONTINUE
  97 C
  98 C        INITIALIZE NUMBER OF TOTAL NEW BOXES PER J TO ZERO.
  99 C
 100       DO 112 J=1,31
 101          NTOTBT(J)=999999999
 102          NBOXJ(J)=0
 103  112  CONTINUE
 104 C
 105       IORIGB=(IBIT+JBIT+KBIT)*LX
 106 C        IBIT = BITS TO PACK THE JMIN( ).
 107 C        JBIT = BITS TO PACK THE LBIT( ).
 108 C        KBIT = BITS TO PACK THE NOV( ).
 109 C        LX = NUMBER OF GROUPS.
 110          NTOTBT(KBIT)=IORIGB
 111 C           THIS IS THE VALUE OF TOTAL BITS FOR THE ORIGINAL LX
 112 C           GROUPS, WHICH REQUIRES KBITS TO PACK THE GROUP
 113 C           LENGHTS.  SETTING THIS HERE MAKES ONE LESS LOOPS
 114 C           NECESSARY BELOW.
 115 C
 116 C        COMPUTE BITS NOW USED FOR THE PARAMETERS DEFINED.
 117 C
 118 C        DETERMINE OTHER POSSIBILITES BY INCREASING LX AND DECREASING
 119 C        NOV( ) WITH VALUES GREATER THAN THRESHOLDS.  ASSUME A GROUP IS
 120 C        SPLIT INTO 2 OR MORE GROUPS SO THAT KBIT IS REDUCED WITHOUT
 121 C        CHANGING IBIT OR JBIT.
 122 C
 123       JJ=0
 124 C
 125       DO 200 J=MIN(30,KBIT-1),2,-1
 126 C           VALUES GE KBIT WILL NOT REQUIRE SPLITS.  ONCE THE TOTAL
 127 C           BITS START INCREASING WITH DECREASING J, STOP.  ALSO, THE
 128 C           NUMBER OF BITS REQUIRED IS KNOWN FOR KBITS = NTOTBT(KBIT).
 129 C
 130          NEWBOXT=0
 131 C
 132          DO 190 L=1,LX
 133 C
 134             IF(NOV(L).LT.IBXX2(J))THEN
 135                NEWBOX(L)=0
 136 C                 NO SPLITS OR NEW BOXES.
 137                GO TO 190
 138             ELSE
 139                NOVL=NOV(L)
 140 C
 141                M=(NOV(L)-1)/(IBXX2(J)-1)+1
 142 C                 M IS FOUND BY SOLVING THE EQUATION BELOW FOR M:
 143 C                 (NOV(L)+M-1)/M LT IBXX2(J)
 144 C                 M GT (NOV(L)-1)/(IBXX2(J)-1)
 145 C                 SET M = (NOV(L)-1)/(IBXX2(J)-1)+1
 146  130           NOVL=(NOV(L)+M-1)/M
 147 C                 THE +M-1 IS NECESSARY.  FOR INSTANCE, 15 WILL FIT
 148 C                 INTO A BOX 4 BITS WIDE, BUT WON'T DIVIDE INTO
 149 C                 TWO BOXES 3 BITS WIDE EACH.
 150 C
 151                IF(NOVL.LT.IBXX2(J))THEN
 152                   GO TO 185
 153                ELSE
 154                   M=M+1
 155 C***                  WRITE(KFILDO,135)L,NOV(L),NOVL,M,J,IBXX2(J)
 156 C*** 135              FORMAT(/' AT 135--L,NOV(L),NOVL,M,J,IBXX2(J)',6I10)
 157                   GO TO 130
 158                ENDIF
 159 C
 160 C                 THE ABOVE DO LOOP WILL NEVER COMPLETE.
 161             ENDIF
 162 C
 163  185        NEWBOX(L)=M-1
 164             NEWBOXT=NEWBOXT+M-1
 165  190     CONTINUE
 166 C
 167          NBOXJ(J)=NEWBOXT
 168          NTOTPR=NTOTBT(J+1)
 169          NTOTBT(J)=(IBIT+JBIT)*(LX+NEWBOXT)+J*(LX+NEWBOXT)
 170 C
 171          IF(NTOTBT(J).GE.NTOTPR)THEN
 172             JJ=J+1
 173 C              THE PLUS IS USED BECAUSE J DECREASES PER ITERATION.
 174             GO TO 250
 175          ELSE
 176 C
 177 C              SAVE THE TOTAL NEW BOXES AND NEWBOX( ) IN CASE THIS
 178 C              IS THE J TO USE.
 179 C
 180             NEWBOXTP=NEWBOXT
 181 C
 182             DO 195 L=1,LX
 183                NEWBOXP(L)=NEWBOX(L)
 184  195        CONTINUE
 185 C
 186 C           WRITE(KFILDO,197)NEWBOXT,IBXX2(J)
 187 C197        FORMAT(/' *****************************************'
 188 C    1             /' THE NUMBER OF NEWBOXES PER GROUP OF THE TOTAL',
 189 C    2              I10,' FOR GROUP MAXSIZE PLUS 1 ='I10
 190 C    3             /' *****************************************')
 191 C           WRITE(KFILDO,198) (NEWBOX(L),L=1,LX)
 192 C198        FORMAT(/' '20I6/(' '20I6))
 193
 194          ENDIF
 195 C
 196 C205     WRITE(KFILDO,209)KBIT,IORIGB
 197 C209     FORMAT(/' ORIGINAL BITS WITH KBIT OF',I5,' =',I10)
 198 C        WRITE(KFILDO,210)(N,N=2,10),(IBXX2(N),N=2,10),
 199 C    1                    (NTOTBT(N),N=2,10),(NBOXJ(N),N=2,10),
 200 C    2                    (N,N=11,20),(IBXX2(N),N=11,20),
 201 C    3                    (NTOTBT(N),N=11,20),(NBOXJ(N),N=11,20),
 202 C    4                    (N,N=21,30),(IBXX2(N),N=11,20),
 203 C    5                    (NTOTBT(N),N=21,30),(NBOXJ(N),N=21,30)
 204 C210     FORMAT(/' THE TOTAL BYTES FOR MAXIMUM GROUP LENGTHS BY ROW'//
 205 C    1      '   J         = THE NUMBER OF BITS PER GROUP LENGTH'/
 206 C    2      '   IBXX2(J)  = THE MAXIMUM GROUP LENGTH PLUS 1 FOR THIS J'/
 207 C    3      '   NTOTBT(J) = THE TOTAL BITS FOR THIS J'/
 208 C    4      '   NBOXJ(J)  = THE NEW GROUPS FOR THIS J'/
 209 C    5      4(/10X,9I10)/4(/10I10)/4(/10I10))
 210 C
 211  200  CONTINUE
 212 C
 213  250  PIMP=((IORIGB-NTOTBT(JJ))/FLOAT(IORIGB))*100.
 214 C     WRITE(KFILDO,252)PIMP,KBIT,JJ
 215 C252  FORMAT(/' PERCENT IMPROVEMENT =',F6.1,
 216 C    1        ' BY DECREASING GROUP LENGTHS FROM',I4,' TO',I4,' BITS')
 217       IF(PIMP.GE.2.)THEN
 218 C
 219 C        WRITE(KFILDO,255)CFEED,NEWBOXTP,IBXX2(JJ)
 220 C255     FORMAT(A1,/' *****************************************'
 221 C    1             /' THE NUMBER OF NEWBOXES PER GROUP OF THE TOTAL',
 222 C    2             I10,' FOR GROUP MAXSIZE PLUS 1 ='I10
 223 C    2             /' *****************************************')
 224 C        WRITE(KFILDO,256) (NEWBOXP(L),L=1,LX)
 225 C256     FORMAT(/' '20I6)
 226 C
 227 C           ADJUST GROUP LENGTHS FOR MAXIMUM LENGTH OF JJ BITS.
 228 C           THE MIN PER GROUP AND THE NUMBER OF BITS REQUIRED
 229 C           PER GROUP ARE NOT CHANGED.  THIS MAY MEAN THAT A
 230 C           GROUP HAS A MIN (OR REFERENCE) THAT IS NOT ZERO.
 231 C           THIS SHOULD NOT MATTER TO THE UNPACKER.
 232 C
 233          LXNKP=LX+NEWBOXTP
 234 C           LXNKP = THE NEW NUMBER OF BOXES
 235 C
 236          IF(LXNKP.GT.NDG)THEN
 237 C              DIMENSIONS NOT LARGE ENOUGH.  PROBABLY AN ERROR
 238 C              OF SOME SORT.  ABORT.
 239 C           WRITE(KFILDO,257)NDG,LXNPK
 240 C        1         2         3         4         5         6         7 X
 241 C257        FORMAT(/' DIMENSIONS OF JMIN, ETC. IN REDUCE =',I8,
 242 C    1              ' NOT LARGE ENOUGH FOR THE EXPANDED NUMBER OF',
 243 C    2              ' GROUPS =',I8,'.  ABORT REDUCE.')
 244             IER=715
 245             GO TO 410
 246 C              AN ABORT CAUSES THE CALLING PROGRAM TO REEXECUTE
 247 C              WITHOUT CALLING REDUCE.
 248          ENDIF
 249 C
 250          LXN=LXNKP
 251 C           LXN IS THE NUMBER OF THE BOX IN THE NEW SERIES BEING
 252 C           FILLED.  IT DECREASES PER ITERATION.
 253          IBXX2M1=IBXX2(JJ)-1
 254 C           IBXX2M1 IS THE MAXIMUM NUMBER OF VALUES PER GROUP.
 255 C
 256          DO 300 L=LX,1,-1
 257 C
 258 C              THE VALUES IS NOV( ) REPRESENT THOSE VALUES + NOVREF.
 259 C              WHEN VALUES ARE MOVED TO ANOTHER BOX, EACH VALUE
 260 C              MOVED TO A NEW BOX REPRESENTS THAT VALUE + NOVREF.
 261 C              THIS HAS TO BE CONSIDERED IN MOVING VALUES.
 262 C
 263             IF(NEWBOXP(L)*(IBXX2M1+NOVREF)+NOVREF.GT.NOV(L)+NOVREF)THEN
 264 C                 IF THE ABOVE TEST IS MET, THEN MOVING IBXX2M1 VALUES
 265 C                 FOR ALL NEW BOXES WILL LEAVE A NEGATIVE NUMBER FOR
 266 C                 THE LAST BOX.  NOT A TOLERABLE SITUATION.
 267                MOVMIN=(NOV(L)-(NEWBOXP(L))*NOVREF)/NEWBOXP(L)
 268                LEFT=NOV(L)
 269 C                 LEFT = THE NUMBER OF VALUES TO MOVE FROM THE ORIGINAL
 270 C                 BOX TO EACH NEW BOX EXCEPT THE LAST.  LEFT IS THE
 271 C                 NUMBER LEFT TO MOVE.
 272             ELSE
 273                MOVMIN=IBXX2M1
 274 C                 MOVMIN VALUES CAN BE MOVED FOR EACH NEW BOX.
 275                LEFT=NOV(L)
 276 C                 LEFT IS THE NUMBER OF VALUES LEFT TO MOVE.
 277             ENDIF
 278 C
 279             IF(NEWBOXP(L).GT.0)THEN
 280                IF((MOVMIN+NOVREF)*NEWBOXP(L)+NOVREF.LE.NOV(L)+NOVREF.
 281      1          AND.(MOVMIN+NOVREF)*(NEWBOXP(L)+1).GE.NOV(L)+NOVREF)THEN
 282                   GO TO 288
 283                ELSE
 284 C***D                 WRITE(KFILDO,287)L,MOVMIN,NOVREF,NEWBOXP(L),NOV(L)
 285 C***D287              FORMAT(/' AT 287 IN REDUCE--L,MOVMIN,NOVREF,',
 286 C***D    1                    'NEWBOXP(L),NOV(L)',5I12
 287 C***D    2                    ' REDUCE ABORTED.')
 288 C              WRITE(KFILDO,2870)
 289 C2870          FORMAT(/' AN ERROR IN REDUCE ALGORITHM.  ABORT REDUCE.')
 290                IER=714
 291                GO TO 410
 292 C                 AN ABORT CAUSES THE CALLING PROGRAM TO REEXECUTE
 293 C                 WITHOUT CALLING REDUCE.
 294                ENDIF
 295 C
 296             ENDIF
 297 C
 298  288        DO 290 J=1,NEWBOXP(L)+1
 299                MOVE=MIN(MOVMIN,LEFT)
 300                JMIN(LXN)=JMIN(L)
 301                JMAX(LXN)=JMAX(L)
 302                LBIT(LXN)=LBIT(L)
 303                NOV(LXN)=MOVE
 304                LXN=LXN-1
 305                LEFT=LEFT-(MOVE+NOVREF)
 306 C                 THE MOVE OF MOVE VALUES REALLY REPRESENTS A MOVE OF
 307 C                 MOVE + NOVREF VALUES.
 308  290        CONTINUE
 309 C
 310             IF(LEFT.NE.-NOVREF)THEN
 311 C***               WRITE(KFILDO,292)L,LXN,MOVE,LXNKP,IBXX2(JJ),LEFT,NOV(L),
 312 C***     1                          MOVMIN
 313 C*** 292           FORMAT(' AT 292 IN REDUCE--L,LXN,MOVE,LXNKP,',
 314 C***     1                'IBXX2(JJ),LEFT,NOV(L),MOVMIN'/8I12)
 315             ENDIF
 316 C
 317  300     CONTINUE
 318 C
 319          LX=LXNKP
 320 C           LX IS NOW THE NEW NUMBER OF GROUPS.
 321          KBIT=JJ
 322 C           KBIT IS NOW THE NEW NUMBER OF BITS REQUIRED FOR PACKING
 323 C           GROUP LENGHTS.
 324       ENDIF
 325 C
 326 C     WRITE(KFILDO,406)CFEED,LX
 327 C406  FORMAT(A1,/' *****************************************'
 328 C    1          /' THE GROUP SIZES NOV( ) AFTER REDUCTION IN SIZE',
 329 C    2           ' FOR'I10,' GROUPS',
 330 C    3          /' *****************************************')
 331 C     WRITE(KFILDO,407) (NOV(J),J=1,LX)
 332 C407  FORMAT(/' '20I6)
 333 C     WRITE(KFILDO,408)CFEED,LX
 334 C408  FORMAT(A1,/' *****************************************'
 335 C    1          /' THE GROUP MINIMA JMIN( ) AFTER REDUCTION IN SIZE',
 336 C    2           ' FOR'I10,' GROUPS',
 337 C    3          /' *****************************************')
 338 C     WRITE(KFILDO,409) (JMIN(J),J=1,LX)
 339 C409  FORMAT(/' '20I6)
 340 C
 341  410  RETURN
 342       END
 343