1      PROGRAM BUCOMPRESS
2C
3C**** *BUFR*
4C
5C
6C     PURPOSE.
7C     --------
8C
9C           PACKS BUFR MULTI SUBSET DATA IN THE COMPRESSED FORM
10C           THE NUMBER OF SUBSETS TO BE COMPRESSED IS DEFINED IN
11C           THE NAMLIST FILE.
12C
13C
14C**   INTERFACE.
15C     ----------
16C
17C          BUCOMPRESS OUTFILE NAMELIST_FILENAME
18C
19C     METHOD.
20C     -------
21C
22C          NONE.
23C
24C
25C     EXTERNALS.
26C     ----------
27C
28C         CALL BUSEL
29C         CALL BUFREX
30C         CALL BUFREN
31C         CALL BUPRS0
32C         CALL BUPRS1
33C         CALL BUPRS2
34C         CALL BUPRS3
35C         CALL BUPRT
36C         CALL BUUKEY
37C
38C     REFERENCE.
39C     ----------
40C
41C          NONE.
42C
43C     AUTHOR.
44C     -------
45C
46C          M. DRAGOSAVAC    *ECMWF*       15/09/87.
47C
48C
49C     MODIFICATIONS.
50C     --------------
51C
52C          NONE.
53C
54C
55      IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y)
56C
57      PARAMETER(JSUP =   9,JSEC0=   3,JSEC1= 40,JSEC2=4096 ,JSEC3= 4,
58     1       JSEC4=   2,JELEM=160000,JSUBS=400,JCVAL=150 ,JBUFL=512000,
59     2          JBPW =  32,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT=1200,
60     3          JWORK=4096000,JKEY=46,JBYTE=512000)
61C
62      PARAMETER (JTYPE=256)
63      PARAMETER (KELEM=20000)
64      PARAMETER (KVALS=80000)
65C
66      DIMENSION KBUFF(JBUFL)
67      DIMENSION KBUFR(JBUFL)
68      DIMENSION KSUP(JSUP)  ,KSEC0(JSEC0),KSEC1(JSEC1)
69      DIMENSION KSEC2(JSEC2),KSEC3(JSEC3),KSEC4(JSEC4)
70      DIMENSION KEY  (JKEY),KREQ(2)
71C
72      REAL*8 VALUES(KVALS),VALUE(KVALS),VALS(KVALS)
73      REAL*8 RVIND,EPS
74C
75      DIMENSION KTDLST(KELEM),KTDEXP(KELEM)
76      DIMENSION KDATA(200)
77      DIMENSION ICOMP(JTYPE)
78C
79      CHARACTER*256 CARG(4),COUT,CFIN
80      CHARACTER*64 CNAMES(KELEM)
81      CHARACTER*24 CUNITS(KELEM)
82      CHARACTER*80 CVALS(KVALS)
83      CHARACTER*80 CVAL(KVALS)
84      CHARACTER*80 YENC
85C
86      CHARACTER*5 CFNAME(JTYPE)
87C
88C      DATA CFNAME/'st001','st002','st003','st004','st005',
89C     1            'st009','st011','st012','st013','st014',
90C     2            'st019','st021','st022','st023','st051',
91C     2            'st061','st062','st063','st071','st072',
92C     3            'st073','st082','st083','st084','st085',
93C     4            'st091','st092','st095','st101','st102',
94C     5            'st103','st104','st105','st106','st121',
95C     6            'st122','st123','st124','st125','st127',
96C     7            'st128','st131','st132','st133','st142',
97C     8            'st144','st145','st164'/
98C
99C      DATA ICOMP/200,200,200,200,200,
100C     1           200,200,200,200,200,
101C     2           200,200,200,200,052,
102C     2           052,052,052,052,052,
103C     3           052,050,050,050,050,
104C     4           001,001,001,001,001,
105C     5           001,001,001,001,001,
106C     5           361,001,001,001,001,
107C     7            -1,001,200,200,200,
108C     8           100/
109C
110       DATA CFNAME/JTYPE*' '/
111      NAMELIST /COMPRESS/ CFNAME,ICOMP
112cs      EXTERNAL GETARG
113C
114C     ------------------------------------------------------------------
115C*          1. INITIALIZE CONSTANTS AND VARIABLES.
116C              -----------------------------------
117 100  CONTINUE
118C
119C     MISSING VALUE INDICATOR
120C
121      RVIND=1.7E38
122      NVIND=2147483647
123      NREAD=0
124      NSUBS=0
125      NW=0
126      ITOTAL=0
127      NBYTES=JBPW/8
128C
129C
130C     GET INPUT AND OUTPUT FILE NAME.
131C
132      NARG=IARGC()
133C
134      IF(NARG.LT.4) THEN
135         PRINT*,'USAGE -- bufr_compress -i namelist -o outfile'
136         STOP
137      END IF
138C
139      DO 101 J=1,NARG
140      CALL GETARG(J,CARG(J))
141 101  CONTINUE
142C
143      DO 102 J=1,NARG,2
144      IF(CARG(J).EQ.'-i') THEN
145         CFIN=CARG(J+1)
146      ELSEIF(CARG(J).EQ.'-o') THEN
147         COUT=CARG(J+1)
148      ELSE
149          PRINT*,'USAGE -- bufr_compress -i namelist -o outfile'
150          STOP
151      END IF
152102   CONTINUE
153C
154      KRQL=0
155      NR=0
156      KREQ(1)=0
157      KREQ(2)=0
158C
159C*          1.2 OPEN NAMELIST AND OUTPUT FILE
160C               -----------------------------
161 120  CONTINUE
162C
163C               OPEN NAMELIST
164C
165      OPEN(UNIT=60,FILE=CFIN,ERR=125,IOSTAT=IOS,
166     1                 STATUS='OLD',
167     2                 FORM='FORMATTED')
168C
169      GO TO 126
170C
171 125  CONTINUE
172C
173      PRINT*,'OPEN ERRO ON NAMELIST FILE.'
174      CALL MY_EXIT(2)
175C
176 126  CONTINUE
177C
178      READ(60,COMPRESS)
179      CLOSE(60)
180C
181C     CHECK HOW MANY FILES IN THE NAMELIST
182C
183      NFILES=256
184C     DO 127 I=1,JTYPE
185C     IF(CFNAME(I).EQ.' ') THEN
186C        NFILES=I-1
187C        GO TO 128
188C     END IF
189C127  CONTINUE
190C
191 128  CONTINUE
192C
193C               OPEN OUTPUT FILE
194C
195      PRINT*,'NUMBER OF FILES TO PROCESS=',NFILES
196      II=INDEX(COUT,' ')
197      II=II-1
198      CALL PBOPEN(IUNIT1,COUT(1:II),'A',IRET)
199      IF(IRET.EQ.-1) STOP 'OPEN FAILED ON OUTPUT FILE'
200      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
201      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
202C
203C               OPEN INPUT FILES
204C
205      DO 121 IO=1,NFILES
206C
207      IRET=0
208      CALL PBOPEN(IUNIT,CFNAME(IO),'R',IRET)
209      IF(IRET.EQ.-1) THEN
210        GO TO 121
211      END IF
212      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
213      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
214C
215C
216C     -----------------------------------------------------------------
217C*          2. SET REQUEST FOR EXPANSION.
218C              --------------------------
219 200  CONTINUE
220C
221      ICODE=0
222      NCOM=ICOMP(IO)
223      OCOMP=.TRUE.
224C
225C
226C     -----------------------------------------------------------------
227C*          3.  READ BUFR MESSAGE.
228C               ------------------
229 300  CONTINUE
230C
231      IERR=0
232      KBUFL=0
233C
234      IRET=0
235      CALL PBBUFR(IUNIT,KBUFF,JBYTE,KBUFL,IRET)
236      IF(IRET.EQ.-1) THEN
237         IF(N.NE.0) GO TO 600
238         GO TO 122
239      END IF
240      IF(IRET.EQ.-2) STOP 'FILE HANDLING PROBLEM'
241      IF(IRET.EQ.-3) STOP 'ARRAY TOO SMALL FOR PRODUCT'
242C
243      NREAD=NREAD+1
244      KBUFL=KBUFL/NBYTES+1
245C
246C     -----------------------------------------------------------------
247C*          4. EXPAND BUFR MESSAGE.
248C              --------------------
249 400  CONTINUE
250C
251      CALL BUS012(KBUFL,KBUFF,KSUP,KSEC0,KSEC1,KSEC2,KERR)
252      IF(KERR.NE.0) THEN
253         PRINT*,'ERROR IN BUS012: ',KERR
254         PRINT*,' BUFR MESSAGE NUMBER ',N,' CORRUPTED.'
255         KERR=0
256         GO TO 300
257      END IF
258C
259      KEL=KELEM
260      IF(KSUP(6).GT.1) KEL=JWORK/KSUP(6)
261C
262      CALL BUFREX(KBUFL,KBUFF,KSUP,KSEC0 ,KSEC1,KSEC2 ,KSEC3 ,KSEC4,
263     1            KEL,CNAMES,CUNITS,KVALS,VALUES,CVALS,IERR)
264C
265      IF(IERR.NE.0) THEN
266         IF(IERR.EQ.2) THEN
267            IERR=0
268         ELSE
269            CALL MY_EXIT(2)
270         END IF
271      END IF
272C
273      NSUBS=NSUBS+KSEC3(3)
274C
275C     -----------------------------------------------------------------
276C*          5. COLLECT DATA FOR REPACKING.
277C              ---------------------------
278 500  CONTINUE
279C
280C               FIRST GET DATA DESCRIPTORS
281C
282      CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
283      IF(KERR.NE.0) CALL MY_EXIT(2)
284C
285C     CHECK IF ANOUGH SPACE FOR COMPRESSION
286C
287C
288C     CHECK FOR MAXIMUM NUMBER OF SUBSETS TO BE PACKED
289C
290      IF(NCOM.LT.0) THEN
291         NCOM=JWORK/KTDEXL
292         WRITE(*,'(I4,A,I3)')
293     1   NCOM,' SUB-SETS COMPRESSED FOR SUB-TYPE ',KSEC1(7)
294      ELSE
295         IF(NCOM*KTDEXL.GT.JWORK) THEN
296         PRINT*,'TOO MANY SUBSETS TO BE PACKED.'
297         PRINT*,'MAXIMUM NUMBER OF SUBSETS TO BE PACKED =',JWORK/KTDEXL
298         CALL MY_EXIT(2)
299         END IF
300      END IF
301C
302      DO 503 J=1,KSUP(6)
303      N=N+1
304C
305      DO 502 I=1,KSUP(5)
306      IV=I+(J-1)*KEL
307      IN=I+(N-1)*KSUP(5)
308C
309      IF(CUNITS(I).EQ.'CCITTIA5') THEN
310         IPOS =VALUES(IV)/1000.
311         ICHAR=NINT(VALUES(IV)-IPOS*1000)
312         KKK=KKK+1
313         VALUE(IN)=KKK*1000+ICHAR
314         CVAL(KKK)=CVALS(IPOS)
315      ELSE
316         VALUE(IN)=VALUES(IV)
317      END IF
318 502  CONTINUE
319      IF(N.EQ.NCOM) THEN
320        JLAST=J
321        GO TO 600
322      END IF
323 503  CONTINUE
324C
325      IF(N.EQ.NCOM)    GO TO 600
326C
327      GO TO 300
328C     -----------------------------------------------------------------
329C*          6. PACK BUFR MESSAGE BACK INTO BUFR.
330C              ---------------------------------
331 600  CONTINUE
332C
333
334      KKK=0
335      KSEC3(3)=N
336      KSEC1(8)=1
337      KSEC3(4)=128                    ! NO COMPRESSION
338      IF(KSEC3(3).GT.1) KSEC3(4)=192  ! COMPRESSION
339      N=0
340      KBUFL=JBUFL
341C
342C     GET REPLICATION FACTORS
343C
344      KK=0
345      DO 601 K=1,KSUP(5)
346      IF(KTDEXP(K).EQ.31001.OR.KTDEXP(K).EQ.31002.OR.
347     1   KTDEXP(K).EQ.31011.OR.KTDEXP(K).EQ.31012) THEN
348         KK=KK+1
349         KDATA(KK)=NINT(VALUES(K))
350      END IF
351 601  CONTINUE
352C
353      KDLEN=2
354      IF(KK.NE.0) KDLEN=KK
355C
356C*          6.2 ENCODE DATA INTO BUFR MESSAGE.
357C               ------------------------------
358 620  CONTINUE
359C
360C       CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR)
361C
362C      PACK RDB KEY
363C
364C
365       KLM=KSUP(5)
366C
367       CALL SETLALO(KSEC1(7),KLA,KLO,KERR)
368       IF(KERR.NE.0) CALL MY_EXIT(2)
369C
370       CALL FMMH( KLA,KLO,KLM,VALUE,KSEC3,RMINLAT,RMINLON,
371     1           RMAXLAT,RMAXLON)
372C       CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR)
373C       IF(KERR.NE.0) THEN
374C          CALL MY_EXIT(2)
375C       END IF
376C
377       MINLAT=NINT(RMINLAT*100000)+9000000
378       MAXLAT=NINT(RMAXLAT*100000)+9000000
379       MINLON=NINT(RMINLON*100000)+18000000
380       MAXLON=NINT(RMAXLON*100000)+18000000
381C
382       KEY(10)=MINLON
383       KEY(11)=MINLAT
384       KEY(12)=MAXLON
385       KEY(13)=MAXLAT
386       KEY(14)=KSEC3(3)
387C
388C       CALL BUPKEY(KEY,KSEC1,KSEC2,KERR)
389C       IF(KERR.NE.0) THEN
390C          PRINT*,'FILE IN PROCESS IS ',CFNAME(IO)
391C          CALL MY_EXIT(2)
392C       END IF
393C
394       CALL BUFREN( KSEC0,KSEC1,KSEC2,KSEC3,KSEC4,
395     1              KTDLEN,KTDLST,KDLEN,KDATA,KSUP(5),
396     2              KVALS,VALUE,CVAL,KBUFL,KBUFR,KERR)
397C
398      IF(KERR.NE.0) THEN
399         PRINT*,'ERROR DURING ENCODING.'
400         CALL MY_EXIT(2)
401      END IF
402C
403C           6.3 WRITE PACKED BUFR MESSAGE INTO FILE.
404C               ------------------------------------
405 630  CONTINUE
406C
407      ILEN=KBUFL*NBYTES
408C
409      IERR=0
410      CALL PBWRITE(IUNIT1,KBUFR,ILEN,IERR)
411      IF(IERR.LT.0)  THEN
412         PRINT*,'PBWRITE: WRITE ERROR ',IERR
413         CALL MY_EXIT(2)
414      END IF
415C
416      ITOTAL=ITOTAL+KSEC3(3)
417C
418      IF(IRET.EQ.-1) THEN
419         NW=NW+1
420         GO TO 122
421      END IF
422C
423      NW=NW+1
424C
425      N=0
426      IF(JLAST.LT.KSUP(6)) THEN
427C
428C        MOVE THE REST OF DATA INTO VALUE ARRAY
429C
430         DO 505 J=JLAST+1,KSUP(6)
431         N=N+1
432         DO 504 I=1,KSUP(5)
433         IV=I+(J-1)*KEL
434         IN=I+(N-1)*KSUP(5)
435C
436         IF(CUNITS(I).EQ.'CCITTIA5') THEN
437            IPOS =VALUES(I)/1000.
438            ICHAR=NINT(VALUES(IV)-IPOS*1000)
439            KKK=KKK+1
440            VALUE(IN)=KKK*1000+ICHAR
441            CVAL(KKK)=CVALS(IPOS)
442         ELSE
443            VALUE(IN)=VALUES(IV)
444         END IF
445 504     CONTINUE
446 505     CONTINUE
447      END IF
448C
449      IF(NCOM.LE.KSUP(6)-JLAST) THEN
450         KSUP(6)=KSUP(6)-JLAST
451         N=0
452        GO TO 500
453      END IF
454C
455      GO TO 300
456C
457 122  CONTINUE
458C
459      IRET=0
460      CALL PBCLOSE(IUNIT,IRET)
461C
462 121  CONTINUE
463C
464C     -----------------------------------------------------------------
465 900  CONTINUE
466C
467       PRINT*,'NUMBER OF MESSAGES READ        ',NREAD
468       PRINT*,'NUMBER OF MESSAGES WRITTEN     ',NW
469       PRINT*,'NUMBER OF SUBSETS              ',NSUBS
470       PRINT*,'NUMBER OF OBSERVATIONS WRITTEN ',ITOTAL
471C
472      CALL PBCLOSE(IUNIT1,IRET)
473C
474      END
475