| blob | 110137e31497115a2768f2f47b4d4a9605e676e9 |
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))
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