source: trunk/WRF.COMMON/WRFV3/external/io_grib2/g2lib/reduce.F @ 2759

Last change on this file since 2759 was 2759, checked in by aslmd, 2 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size

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