1      PROGRAM BUFRREPACK
2C
3C**** *BUFRREPACK*
4C
5C
6C     PURPOSE.
7C     --------
8C         REPACKS BUFR  DATA.
9C
10C
11C**   INTERFACE.
12C     ----------
13C
14C          NONE.
15C
16C     METHOD.
17C     -------
18C
19C          NONE.
20C
21C
22C     EXTERNALS.
23C     ----------
24C
25C         CALL BUSEL
26C         CALL BUFREX
27C         CALL BUFREN
28C         CALL BUPRS0
29C         CALL BUPRS1
30C         CALL BUPRS2
31C         CALL BUPRS3
32C         CALL BUPRT
33C         CALL BUUKEY
34C
35C     REFERENCE.
36C     ----------
37C
38C          NONE.
39C
40C     AUTHOR.
41C     -------
42C
43C          M. DRAGOSAVAC    *ECMWF*       15/02/95.
44C
45C
46C     MODIFICATIONS.
47C     --------------
48C
49C          NONE.
50C
51C
52      IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y)
53C
54      PARAMETER(JSUP =   9,JSEC0=   3,JSEC1= 40,JSEC2=4096,JSEC3= 4,
55     1      JSEC4=   2,JELEM=160000,JSUBS=400,JCVAL=150 ,JBUFL=512000,
56#ifdef JBPW_64
57     2          JBPW =  64,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT=1200,
58#else
59     2          JBPW =  32,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT=1200,
60#endif
61     3          JWORK=4096000,JKEY=46,JBYTE=512000)
62C
63      PARAMETER (KELEM=80000)
64      PARAMETER (KVALS=360000)
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),RQV(KELEM)
73      REAL*8 RVIND,EPS
74      DIMENSION KTDLST(KELEM),KTDEXP(KELEM),KRQ(KELEM)
75      DIMENSION KDATA(200)
76      DIMENSION IOUT(12800)
77C
78      CHARACTER*256 CF(100),COUT,CFIN
79      CHARACTER*64 CNAMES(KELEM)
80      CHARACTER*24 CUNITS(KELEM)
81      CHARACTER*80 CVALS(KVALS)
82      CHARACTER*80 YENC
83      CHARACTER*256 CARG(10)
84C
85cs      EXTERNAL GETARG
86C
87C     ------------------------------------------------------------------
88C*          1. INITIALIZE CONSTANTS AND VARIABLES.
89C              -----------------------------------
90 100  CONTINUE
91C
92C     MISSING VALUE INDICATOR
93C
94      ITLEN=6400
95      ITL=0
96      JZ=0
97      NW=0
98      NBYTES=JBPW/8
99      RVIND=1.7D38
100      NVIND=2147483647
101      IOBS=0
102      KRQL=0
103      NR=2555
104      KREQ(1)=0
105      KREQ(2)=0
106      DO 102 I=1,KELEM
107      RQV(I)=RVIND
108      KRQ(I)=NVIND
109 102  CONTINUE
110C
111C     INPUT FILE NAMES
112C
113      NARG=IARGC()
114      IF(NARG.LT.4) THEN
115         PRINT*,'USAGE -- bufr_repack -i infile -o outfile'
116         STOP
117      END IF
118      NFILE=NARG
119C
120      DO 104 J=1,NARG
121      CALL GETARG(J,CARG(J))
122 104  CONTINUE
123
124      II=0
125      IO=0
126      DO 105 J=1,NARG
127      IF(CARG(J).EQ.'-i') THEN
128         IN=J
129      ELSEIF(CARG(J).EQ.'-o') THEN
130         IO=J
131      END IF
132 105  CONTINUE
133      IF(IO.EQ.0.OR.IN.EQ.0) THEN
134         PRINT*,'USAGE -- bufr_repack -i infile -o outfile'
135         STOP
136      END IF
137C
138      COUT=CARG(IO+1)
139C
140      IF(IO.LT.IN) THEN
141         IST=IN+1
142         IEND=NARG
143      ELSE
144         IST=IN+1
145         IEND=IO-1
146      END IF
147C
148      JJ=INDEX(COUT,' ')
149C
150      CALL PBOPEN(IUNIT1,COUT(1:JJ),'W',IRET)
151      IF(IRET.EQ.-1) STOP 'OPEN FAILED ON BUFR.DAT'
152      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
153      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
154C
155      DO 101 II=IST,IEND
156      CFIN=CARG(II)
157      ILN=INDEX(CFIN,' ')
158C
159C*          1.2 OPEN FILE CONTAINING BUFR DATA.
160C               -------------------------------
161 120  CONTINUE
162C
163      IRET=0
164      CALL PBOPEN(IUNIT,CFIN(1:ILN),'R',IRET)
165      IF(IRET.EQ.-1) STOP 'OPEN FAILED'
166      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
167      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
168C
169C     -----------------------------------------------------------------
170C*          2. SET REQUEST FOR EXPANSION.
171C              --------------------------
172 200  CONTINUE
173C
174      OPRT=.FALSE.
175      OENC=.TRUE.
176      NCOM=1
177      OCOMP=.FALSE.
178      NR=0
179      OSEC3=.FALSE.
180C
181C*          2.1 SET REQUEST FOR PARTIAL EXPANSION.
182C               ----------------------------------
183 210  CONTINUE
184C
185C     SET VARIABLE TO PACK BIG VALUES AS MISSING VALUE INDICATOR
186C
187      KPMISS=1
188      KPRUS=0
189      NOKEY=0
190      CALL BUPRQ(KPMISS,KPRUS,NOKEY)
191C
192C     -----------------------------------------------------------------
193C*          3.  READ BUFR MESSAGE.
194C               ------------------
195 300  CONTINUE
196C
197      IERR=0
198      KBUFL=0
199C
200      IRET=0
201      CALL PBBUFR(IUNIT,KBUFF,JBYTE,KBUFL,IRET)
202      IF(IRET.EQ.-1) THEN
203          GO TO 900
204      END IF
205      IF(IRET.EQ.-2) STOP 'FILE HANDLING PROBLEM'
206      IF(IRET.EQ.-3) STOP 'ARRAY TOO SMALL FOR PRODUCT'
207C
208      N=N+1
209      IKBUFL=KBUFL
210      KBUFL=KBUFL/NBYTES+1
211      IF(N.LT.NR) GO TO 300
212C
213C     -----------------------------------------------------------------
214C*          4. EXPAND BUFR MESSAGE.
215C              --------------------
216 400  CONTINUE
217C
218      CALL BUS012(KBUFL,KBUFF,KSUP,KSEC0,KSEC1,KSEC2,KERR)
219      IF(KERR.NE.0) THEN
220         PRINT*,'ERROR IN BUS012: ',KERR
221         PRINT*,' BUFR MESSAGE NUMBER ',N,' CORRUPTED.'
222         KERR=0
223         GO TO 300
224      END IF
225C
226      IF(KSUP(6).GT.1) THEN
227         KEL=KVALS/KSUP(6)
228         if(KEL .gt.kelem) kel=kelem
229      ELSE
230         KEL=KELEM
231      END IF
232C
233      CALL BUFREX(KBUFL,KBUFF,KSUP,KSEC0 ,KSEC1,KSEC2 ,KSEC3 ,KSEC4,
234     1            KEL,CNAMES,CUNITS,KVALS,VALUES,CVALS,IERR)
235C
236      IF(IERR.NE.0) THEN
237         IF(IERR.EQ.45) GO TO 300
238         CALL EXIT(2)
239      END IF
240      IOBS=IOBS+KSEC3(3)
241C
242      CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
243      IF(KERR.NE.0) CALL EXIT(2)
244C
245C*          4.1 PRINT CONTENT OF EXPANDED DATA.
246C               -------------------------------
247 410  CONTINUE
248C
249      IF(.NOT.OPRT) GO TO 500
250      IF(.NOT.OSEC3) GO TO 450
251C
252C*          4.2 PRINT SECTION ZERO OF BUFR MESSAGE.
253C               -----------------------------------
254 420  CONTINUE
255C
256
257      CALL BUPRS0(KSEC0)
258C
259C*          4.3 PRINT SECTION ONE OF BUFR MESSAGE.
260C               -----------------------------------
261 430  CONTINUE
262C
263      CALL BUPRS1(KSEC1)
264C
265C
266C*          4.4 PRINT SECTION TWO OF BUFR MESSAGE.
267C               -----------------------------------
268 440  CONTINUE
269C
270C              AT ECMWF SECTION 2 CONTAINS RDB KEY.
271C              SO UNPACK KEY
272C
273      CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR)
274C
275C              PRINT KEY
276C
277      CALL BUPRS2(KSUP ,KEY)
278C
279C*          4.5 PRINT SECTION 3 OF BUFR MESSAGE.
280C               -----------------------------------
281 450  CONTINUE
282C
283C               FIRST GET DATA DESCRIPTORS
284C
285      CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
286      IF(KERR.NE.0) CALL EXIT(2)
287C
288C               PRINT  CONTENT
289C
290      IF(OSEC3) THEN
291         CALL BUPRS3(KSEC3,KTDLEN,KTDLST,KTDEXL,KTDEXP,KEL,CNAMES)
292      END IF
293C
294C*         4.6 PRINT SECTION 4 (DATA).
295C              -----------------------
296 460  CONTINUE
297C
298C          IN THE CASE OF MANY SUBSETS DEFINE RANGE OF SUBSETS
299C
300      IF(.NOT.OO) THEN
301      WRITE(*,'(A,$)') ' STARTING SUBSET TO BE PRINTED : '
302      READ(*,'(BN,I4)')   IST
303      WRITE(*,'(A,$)') ' ENDING SUBSET TO BE PRINTED : '
304      READ(*,'(BN,I4)')   IEND
305      OO=.FALSE.
306      END IF
307C
308C              PRINT DATA
309C
310      ICODE=0
311      CALL BUPRT(ICODE,IST,IEND,KEL,CNAMES,CUNITS,CVALS,
312     1           KVALS,VALUES,KSUP,KSEC1,IERR)
313C
314C              RESOLVE BIT MAPS
315C
316      IF(IEND.GT.KSEC3(3)) IEND=KSEC3(3)
317C
318      DO 461 IK=IST,IEND
319C
320      CALL BUBOX(IK,KSUP,KEL,KTDEXP,CNAMES,CUNITS,KVALS,VALUES,
321     1           KBOX,KAPP,KLEN,KBOXR,VALS,CBOXN,CBOXU,IERR)
322C
323      CALL BUPRTBOX(KBOX,KAPP,KLEN,KBOXR,VALS,CBOXN,CBOXU)
324C
325 461  CONTINUE
326C
327C     -----------------------------------------------------------------
328C*          5. COLLECT DATA FOR REPACKING.
329C              ---------------------------
330 500  CONTINUE
331C
332      IF(.NOT.OENC) GO TO 300
333C
334C               FIRST GET DATA DESCRIPTORS
335C
336      CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
337      IF(KERR.NE.0) CALL EXIT(2)
338C
339C     -----------------------------------------------------------------
340C*          6. PACK BUFR MESSAGE BACK INTO BUFR.
341C              ---------------------------------
342 600  CONTINUE
343C
344
345      KKK=0
346      KBUFL=JBUFL
347C
348C     GET REPLICATION FACTORS
349C
350      KK=0
351      DO 601 K=1,KSUP(5)
352      IF(KTDEXP(K).EQ.31001.OR.KTDEXP(K).EQ.31002.OR.
353     1   KTDEXP(K).EQ.31000) THEN
354         KK=KK+1
355         KDATA(KK)=NINT(VALUES(K))
356      END IF
357 601  CONTINUE
358C
359      KDLEN=2
360      IF(KK.NE.0) KDLEN=KK
361C
362C     --------------------------------
363C     |Modification to sections error|
364C     --------------------------------
365      if(ksec1(7).eq.54.or.ksec1(7).eq.55.or.ksec1(7).eq.155) then
366         do i=1,ksec3(3)
367         ij=7+(i-1)*kel
368         if(nint(values(ij)).eq.205) then
369            values(ij)=206.
370         elseif(nint(values(ij)).eq.206) then
371            values(ij)=205.
372         elseif(nint(values(ij)).eq.201) then
373            values(ij)=203.
374         end if
375         end do
376C
377
378      else
379         CALL PBWRITE(IUNIT1,KBUFF,IKBUFL,IERR)
380         IF(IERR.LT.0) THEN
381         PRINT*,'ERROR WRITING INTO TARGET FILE.'
382         CALL EXIT(2)
383         end if
384C
385          NW=NW+1
386C
387          GO TO 300
388      end if
389C
390C
391C*          6.2 ENCODE DATA INTO BUFR MESSAGE.
392C               ------------------------------
393 620  CONTINUE
394C
395      IF(KSEC1(5).NE.0) THEN
396         CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR)
397         IF(KERR.NE.0) THEN
398            PRINT*,'BUUKEY: ERROR ',KERR
399            CALL EXIT(2)
400         END IF
401      END IF
402C
403      IF(KSUP(6).EQ.0) THEN
404         PRINT*,'ZERO SUBSETS'
405         CALL EXIT(2)
406      END IF
407C
408C     GET INFORMATION FOR RDB KEY
409C
410      ksec2(1)=52
411      key(1)=52
412      KEY(15)=nint(values(7))
413C
414C     CALL BUCREKEY(KEL,KTDEXP,KSUP,KSEC1,KSEC3,KEY,
415C    1              VALUES,CVALS,KERR)
416C     IF(KERR.NE.0) THEN
417C        PRINT*,'ERROR IN BUCREKEY.'
418C        CALL EXIT(2)
419C     END IF
420C
421C     PACK NEW RDB KEY
422C
423C
424      CALL BUPKEY(KEY,KSEC1,KSEC2,KERR)
425      IF(KERR.NE.0) CALL EXIT(2)
426C
427      KSEC3(4)=128
428      IF(KSEC3(3).GT.1) KSEC3(4)=192
429C
430      CALL BUFREN( KSEC0,KSEC1,KSEC2,KSEC3,KSEC4,
431     1             KTDLEN,KTDLST,KDLEN,KDATA,KEL,        !KSUP(5),
432     2             KVALS,VALUES,CVALS,KBUFL,KBUFR,KERR)
433C
434      IF(KERR.GT.0) THEN
435         PRINT*,'ERROR DURING ENCODING.'
436         CALL EXIT(2)
437      END IF
438C
439C           6.3 WRITE PACKED BUFR MESSAGE INTO FILE.
440C               ------------------------------------
441 630  CONTINUE
442C
443      IKBUFL=KBUFL*4
444      CALL PBWRITE(IUNIT1,KBUFR,IKBUFL,IERR)
445      IF(IERR.LT.0) THEN
446         PRINT*,'ERROR WRITING INTO TARGET FILE.'
447         CALL EXIT(2)
448      END IF
449C
450      NW=NW+1
451C
452      GO TO 300
453C     -----------------------------------------------------------------
454C
455 810  CONTINUE
456C
457      WRITE(*,'(1H ,A)') 'OPEN ERROR ON INPUT FILE'
458      GO TO 900
459C
460 800  CONTINUE
461C
462      IF(IRET.EQ.-1) THEN
463         PRINT*,'NUMBER OF RECORDS PROCESSED ',N
464         PRINT*,'NUMBER OF RECORDS CONVERTED ',NW
465c
466      ELSE
467         PRINT*,' BUFR : ERROR= ',IERR
468      END IF
469C
470 900  CONTINUE
471C
472      PRINT*,'NUMBER OF RECORDS PROCESSED ',N
473      PRINT*,'NUMBER OF RECORDS CONVERTED ',NW
474C
475      CALL PBCLOSE(IUNIT,IRET)
476 101  CONTINUE
477C
478      CALL PBCLOSE(IUNIT1,IRET)
479C
480      END
481      SUBROUTINE CUTZERO(CHARPAR,KMIN)
482C
483C**** CUTZERO - SUBROUTINE TO REMOVE ZERO CHARACTERS.
484C
485C**   PURPOSE
486C     -------
487C
488C     TO REMOVE ZERO-FILL CHARACTERS FROM THE END OF A CHARACTER
489C     VARIABLE.
490C
491C     INTERFACE
492C     ---------
493C
494C     CALL CUTZERO(CHARPAR,KMIN)
495C
496C          CHARPAR  - CHARACTER VARIABLE WHICH MAY HAVE ZEROS AT THE
497C                     END OF THE VALID CHARACTERS, WHICH NEED TO BE
498C                     REMOVED;
499C                     RETURNED WITH THE ZERO CHARACTERS CONVERTED TO
500C                     BLANK.
501C
502C          KMIN     - INTEGER VARIABLE INDICATING A MINIMUM NUMBER OF
503C                     CHARACTERS AT THE BEGINNING OF THE STRING WHICH
504C                     MUST NOT BE CHANGED
505C
506C     THUS:
507C
508C     CHARPAR='ABC0000'
509C     CALL CUTZERO(CHARPAR,4)
510C
511C     WOULD RETURN THE VALUE 'ABC0   ' IN CHAR, AND WOULD NOT
512C     ALTER THE FIRST 4 CHARACTERS.
513C
514C     METHOD
515C     ------
516C
517C     THE STRIG IS TESTED FOR THE EXISTANCE OF A ZERO CHARACTER.
518C     IF NONE IS FOUND, NO CHANGE TAKES PLACE.
519C     IF ONE OR MORE ZERO CHARACTERS ARE PRESENT, THE END OF THE
520C     STRING IS LOCATED. WORKING BACKWARDS FROM THE END TO THE
521C     KMIN-1 POSITION, CHARACTERS ARE TESTED FOR ZERO. IF A ZERO
522C     IS FOUND, IT IS REPLACED BY BLANK. IF A NON-ZERO IS FOUND,
523C     THE REPLACEMENT LOOP TERMINATES.
524C
525C     MODIFICATIONS
526C     -------------
527C
528C     ORIGINAL VERSION - 25.01.95 - REX GIBSON - ECMWF.
529C
530      CHARACTER*(*) CHARPAR
531      CHARACTER*1   YZERO
532      INTEGER LEN
533C
534C     -----------------------------------------------------------
535C
536C*     1.     FIND AND REPLACE THE ZERO CHARACTERS.
537C
538  100 CONTINUE
539      YZERO=CHAR(0)
540      I1=INDEX(CHARPAR,'0')
541      IF (I1.GT.0) THEN
542         I2=MAX(I1,KMIN+1)
543         I3=INDEX(CHARPAR,' ')-1
544         IF (I3.LE.0) THEN
545            I3=LEN(CHARPAR)
546         ENDIF
547         DO 112 J=I3,I2,-1
548         IF (CHARPAR(J:J).EQ.'0') THEN
549             CHARPAR(J:J)=' '
550         ELSEIF (CHARPAR(J:J).EQ.YZERO) THEN
551             GO TO 112
552         ELSE
553             GO TO 114
554         ENDIF
555  112    CONTINUE
556C
557  114    CONTINUE
558      ENDIF
559C
560C     -----------------------------------------------------------
561C
562C*     2.     RETURN.
563C
564  200 CONTINUE
565C
566      END
567