1      PROGRAM BUFR_ADD_BIAS
2!
3!**** *BUFR_ADD_BIAS*
4!
5!
6!     PURPOSE.
7!     --------
8!         Add bias information to the existing synop bufr data
9!
10!
11!**   INTERFACE.
12!     ----------
13!
14!          NONE.
15!
16!     METHOD.
17!     -------
18!
19!          NONE.
20!
21!
22!     EXTERNALS.
23!     ----------
24!
25!         CALL BUSEL
26!         CALL BUFREX
27!         CALL BUFREN
28!         CALL BUPRS0
29!         CALL BUPRS1
30!         CALL BUPRS2
31!         CALL BUPRS3
32!         CALL BUPRT
33!         CALL BUUKEY
34!
35!     REFERENCE.
36!     ----------
37!
38!          NONE.
39!
40!     AUTHOR.
41!     -------
42!
43!          M. DRAGOSAVAC    *ECMWF*       /17/03/2004.
44!
45!
46!     MODIFICATIONS.
47!     --------------
48!
49!          NONE.
50!
51!
52      IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y)
53!
54      PARAMETER(JSUP =   9,JSEC0=   3,JSEC1= 40,JSEC2= 4096 ,JSEC3= 4, &
55            JSEC4=   2,JELEM=160000,JSUBS=400,JCVAL=150 ,JBUFL=512000, &
56#ifdef JBPW_64
57            JBPW =  64,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT=1200, &
58#else
59            JBPW =  32,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT=1200, &
60#endif
61            JWORK=4096000,JKEY=46,JBYTE=512000)
62!
63      PARAMETER (KELEM=40000)
64      PARAMETER (KVALS=360000)
65      PARAMETER (NSTATIONS=15000)
66!
67      DIMENSION KBUFF(JBUFL)
68      DIMENSION KBUFR(JBUFL)
69      DIMENSION KSUP(JSUP)  ,KSEC0(JSEC0),KSEC1(JSEC1)
70      DIMENSION KSEC2(JSEC2),KSEC3(JSEC3),KSEC4(JSEC4)
71      DIMENSION KEY  (JKEY),KREQ(2)
72!
73      REAL*8 VALUES(KVALS),VALUE(KVALS),RQV(KELEM)
74      REAL*8 RVIND,EPS
75      REAL*8 BIAS_VALUE0, BIAS_VALUE1
76!
77      DIMENSION KTDLST(KELEM),KTDEXP(KELEM),KRQ(KELEM)
78      DIMENSION KDATA(200)
79      DIMENSION IOUT(12800)
80!
81      CHARACTER*256 CF(100),COUT,CFIN,CLIST
82      CHARACTER*64 CNAMES(KELEM)
83      CHARACTER*24 CUNITS(KELEM)
84      CHARACTER*80 CVALS(KVALS)
85      CHARACTER*80 YENC
86      CHARACTER*256 CARG(10)
87      CHARACTER*8   CIDENT, CTEMP
88      INTEGER DATE
89      DIMENSION ITYPE(NSTATIONS)
90      DIMENSION ISBT(NSTATIONS)
91      DIMENSION IPC(NSTATIONS)
92      DIMENSION BIAS(NSTATIONS)
93      CHARACTER*8 CID(NSTATIONS)
94!
95!s      EXTERNAL GETARG
96!
97!     ------------------------------------------------------------------
98!*          1. INITIALIZE CONSTANTS AND VARIABLES.
99!              -----------------------------------
100 100  CONTINUE
101!
102!     MISSING VALUE INDICATOR
103!
104      icount=0
105      ITLEN=6400
106      ITL=0
107      JZ=0
108      NW=0
109      N=0
110      NBYTES=JBPW/8
111      RVIND=1.7E38
112      NVIND=2147483647
113      IOBS=0
114      KRQL=0
115      NR=0
116      KREQ(1)=0
117      KREQ(2)=0
118      DO 102 I=1,KELEM
119      RQV(I)=RVIND
120      KRQ(I)=NVIND
121 102  CONTINUE
122!
123!     INPUT FILE NAMES
124!
125      NARG=IARGC()
126      IF(NARG.LT.4) THEN
127         PRINT*,'USAGE -- bufr_add_bias -i infile -o outfile -l list'
128         STOP
129      END IF
130      NFILE=NARG
131!
132      DO 104 J=1,NARG
133      CALL GETARG(J,CARG(J))
134 104  CONTINUE
135
136      II=0
137      IO=0
138      IN=0
139      IL=0
140      DO 105 J=1,NARG
141      IF(CARG(J).EQ.'-i') THEN
142         IN=J
143      ELSEIF(CARG(J).EQ.'-o') THEN
144         IO=J
145      ELSEIF(CARG(J).EQ.'-l') THEN
146         IL=J
147      END IF
148 105  CONTINUE
149      IF(IO.EQ.0.OR.IN.EQ.0) THEN
150         PRINT*,'USAGE -- bufr_add_bias -i infile -o outfile -l list'
151         STOP
152      END IF
153!
154      COUT=CARG(IO+1)
155      CFIN=CARG(IN+1)
156      CLIST=CARG(IL+1)
157!
158      JJ=INDEX(COUT,' ')
159!
160      CALL PBOPEN(IUNIT1,COUT(1:JJ),'W',IRET)
161      IF(IRET.EQ.-1) STOP 'OPEN FAILED ON BUFR.DAT'
162      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
163      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
164!
165      ILN=INDEX(CFIN,' ')
166!
167!*          1.2 OPEN FILE CONTAINING BUFR DATA.
168!               -------------------------------
169 120  CONTINUE
170!
171      IRET=0
172      CALL PBOPEN(IUNIT,CFIN(1:ILN),'R',IRET)
173      IF(IRET.EQ.-1) STOP 'OPEN FAILED'
174      IF(IRET.EQ.-2) STOP 'INVALID FILE NAME'
175      IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED'
176!
177      IF(IL.NE.0) THEN
178         ILL=INDEX(CLIST,' ')
179!
180         OPEN(UNIT=37,FILE=CLIST(1:ILL-1),IOSTAT=IOS, &
181              STATUS='OLD',FORM='FORMATTED')
182!
183         READ(37,'(A)') CLINE
184         READ(37,'(10x,I10.10)') DATE
185         READ(37,'(16x,I12.12)') NUM_STATIONS
186         READ(37,'(19x,F8.2)')   TRESHOLD
187         READ(37,'(A)') CLINE
188         READ(37,'(A)') CLINE
189!
190         if(NUM_STATIONS.GT.NSTATIONS) THEN
191            print*,'Error: too many stations in the list.'
192            call exit(2)
193         end if
194         DO I=1,NUM_STATIONS
195         READ(37,'(A8,I4,I5,I3,F11.2)') CID(I), ITYPE(I),ISBT(I), &
196                                        IPC(I),BIAS(I)
197!        write(*,*) CID(I), ITYPE(I),ISBT(I),IPC(I),BIAS(I)
198         END DO
199
200      END IF
201!
202!     -----------------------------------------------------------------
203!*          2. SET REQUEST FOR EXPANSION.
204!              --------------------------
205 200  CONTINUE
206!
207      OPRT=.FALSE.
208      OENC=.TRUE.
209      NCOM=1
210      OCOMP=.FALSE.
211      NR=0
212      OSEC3=.FALSE.
213!
214!*          2.1 SET REQUEST FOR PARTIAL EXPANSION.
215!               ----------------------------------
216 210  CONTINUE
217!
218!     SET VARIABLE TO PACK BIG VALUES AS MISSING VALUE INDICATOR
219!
220      KPMISS=1
221      KPRUS=0
222      NOKEY=0
223      CALL BUPRQ(KPMISS,KPRUS,NOKEY)
224!
225!     -----------------------------------------------------------------
226!*          3.  READ BUFR MESSAGE.
227!               ------------------
228 300  CONTINUE
229!
230      IERR=0
231      KBUFL=0
232!
233      IRET=0
234      icount=icount+1
235!     print *, '++++ processing message #',icount
236      CALL PBBUFR(IUNIT,KBUFF,JBYTE,KBUFL,IRET)
237      IF(IRET.EQ.-1) THEN
238          GO TO 900
239      END IF
240      IF(IRET.EQ.-2) STOP 'FILE HANDLING PROBLEM'
241      IF(IRET.EQ.-3) STOP 'ARRAY TOO SMALL FOR PRODUCT'
242!
243      N=N+1
244      IKBUFL=KBUFL
245      KBUFL=KBUFL/NBYTES+1
246      IF(N.LT.NR) GO TO 300
247!
248!     -----------------------------------------------------------------
249!*          4. EXPAND BUFR MESSAGE.
250!              --------------------
251 400  CONTINUE
252!
253      CALL BUS012(KBUFL,KBUFF,KSUP,KSEC0,KSEC1,KSEC2,KERR)
254      IF(KERR.NE.0) THEN
255         PRINT*,'ERROR IN BUS012: ',KERR
256         PRINT*,' BUFR MESSAGE NUMBER ',N,' CORRUPTED.'
257         KERR=0
258         GO TO 300
259      END IF
260      KBUFFL=KSEC0(2)
261!
262      OSURF=.false.
263      IF(ksec1(6).ne.0.and.ksec1(6).ne.1) then
264         CALL PBWRITE(IUNIT1,KBUFF,IKBUFL,IERR)
265         go to 300
266      else
267         if(ksec1(7).eq.  1) OSURF=.true.
268         if(ksec1(7).eq.  3) OSURF=.true.
269         if(ksec1(7).eq.  9) OSURF=.true.
270         if(ksec1(7).eq. 11) OSURF=.true.
271         if(ksec1(7).eq. 13) OSURF=.true.
272         if(ksec1(7).eq. 19) OSURF=.true.
273         if(ksec1(7).eq. 21) OSURF=.true.
274         if(ksec1(7).eq.140) OSURF=.true.
275         if(ksec1(7).eq.147) OSURF=.true.
276         if(ksec1(7).eq.170) OSURF=.true.
277         if(ksec1(7).eq.172) OSURF=.true.
278         if(ksec1(7).eq.176) OSURF=.true.
279         if(ksec1(7).eq.180) OSURF=.true.
280         if(ksec1(7).eq.181) OSURF=.true.
281         if(ksec1(7).eq.182) OSURF=.true.
282      end if
283!
284      if(.not.OSURF) then
285         CALL PBWRITE(IUNIT1,KBUFF,IKBUFL,IERR)
286         go to 300
287      end if
288!
289      IF(KSUP(6).GT.1) THEN
290         KEL=JWORK/KSUP(6)
291      ELSE
292         KEL=KELEM
293      END IF
294!
295      CALL BUFREX(KBUFL,KBUFF,KSUP,KSEC0 ,KSEC1,KSEC2 ,KSEC3 ,KSEC4,&
296                  KEL,CNAMES,CUNITS,KVALS,VALUES,CVALS,IERR)
297!
298      IF(IERR.NE.0) THEN
299         IF(IERR.EQ.45) GO TO 300
300         CALL EXIT(2)
301      END IF
302      IOBS=IOBS+KSEC3(3)
303!
304      CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
305      IF(KERR.NE.0) CALL EXIT(2)
306!
307!*          4.1 PRINT CONTENT OF EXPANDED DATA.
308!               -------------------------------
309 410  CONTINUE
310!
311      IF(.NOT.OPRT) GO TO 500
312      IF(.NOT.OSEC3) GO TO 450
313!
314!*          4.2 PRINT SECTION ZERO OF BUFR MESSAGE.
315!               -----------------------------------
316 420  CONTINUE
317!
318
319      CALL BUPRS0(KSEC0)
320!
321!*          4.3 PRINT SECTION ONE OF BUFR MESSAGE.
322!               -----------------------------------
323 430  CONTINUE
324!
325      CALL BUPRS1(KSEC1)
326!
327!
328!*          4.4 PRINT SECTION TWO OF BUFR MESSAGE.
329!               -----------------------------------
330 440  CONTINUE
331!
332!              AT ECMWF SECTION 2 CONTAINS RDB KEY.
333!              SO UNPACK KEY
334!
335      CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR)
336!
337!              PRINT KEY
338!
339      CALL BUPRS2(KSUP ,KEY)
340!
341!*          4.5 PRINT SECTION 3 OF BUFR MESSAGE.
342!               -----------------------------------
343 450  CONTINUE
344!
345!               FIRST GET DATA DESCRIPTORS
346!
347      CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
348      IF(KERR.NE.0) CALL EXIT(2)
349!
350!               PRINT  CONTENT
351!
352      IF(OSEC3) THEN
353         CALL BUPRS3(KSEC3,KTDLEN,KTDLST,KTDEXL,KTDEXP,KEL,CNAMES)
354      END IF
355!
356!*         4.6 PRINT SECTION 4 (DATA).
357!              -----------------------
358 460  CONTINUE
359!
360!          IN THE CASE OF MANY SUBSETS DEFINE RANGE OF SUBSETS
361!
362      IF(.NOT.OO) THEN
363      WRITE(*,'(A,$)') ' STARTING SUBSET TO BE PRINTED : '
364      READ(*,'(BN,I4)')   IST
365      WRITE(*,'(A,$)') ' ENDING SUBSET TO BE PRINTED : '
366      READ(*,'(BN,I4)')   IEND
367      OO=.FALSE.
368      END IF
369!
370!              PRINT DATA
371!
372      ICODE=0
373      CALL BUPRT(ICODE,IST,IEND,KEL,CNAMES,CUNITS,CVALS,&
374                 KVALS,VALUES,KSUP,KSEC1,IERR)
375!
376!              RESOLVE BIT MAPS
377!
378!     IF(IEND.GT.KSEC3(3)) IEND=KSEC3(3)
379!
380!     DO 461 IK=IST,IEND
381!
382!     CALL BUBOX(IK,KSUP,KEL,KTDEXP,CNAMES,CUNITS,KVALS,VALUES,
383!    1           KBOX,KAPP,KLEN,KBOXR,VALS,CBOXN,CBOXU,IERR)
384!
385!     CALL BUPRTBOX(KBOX,KAPP,KLEN,KBOXR,VALS,CBOXN,CBOXU)
386!
387!461  CONTINUE
388!
389!     -----------------------------------------------------------------
390!*          5. COLLECT DATA FOR REPACKING.
391!              ---------------------------
392 500  CONTINUE
393!
394      IF(.NOT.OENC) GO TO 300
395!
396!               FIRST GET DATA DESCRIPTORS
397!
398      CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR)
399      IF(KERR.NE.0) CALL EXIT(2)
400!
401!     -----------------------------------------------------------------
402!*          6. PACK BUFR MESSAGE BACK INTO BUFR.
403!              ---------------------------------
404 600  CONTINUE
405!
406
407      KKK=0
408      KBUFL=JBUFL
409!
410!     GET REPLICATION FACTORS
411!
412      KK=0
413      DO 601 K=1,KSUP(5)
414      IF(KTDEXP(K).EQ.31001.OR.KTDEXP(K).EQ.31002.OR.&
415         KTDEXP(K).EQ.31000.OR.&
416         KTDEXP(K).EQ.31000) THEN
417         KK=KK+1
418         KDATA(KK)=NINT(VALUES(K))
419      END IF
420 601  CONTINUE
421!
422      KDLEN=2
423      IF(KK.NE.0) KDLEN=KK
424!
425!     --------------------------------
426!     |Modification to sections 3
427!     --------------------------------
428!
429      i_end=ksup(5)
430      do i=1,ksup(5)
431        if(ktdexp(i) .eq. 222000) then
432          i_end=i-1
433          exit
434        endif
435        if(ktdexp(i) .eq. 225000) then
436          i_end=i-1
437          exit
438        endif
439      end do
440! skip message if bitmap cannot be built due to YYY too big in 101YYY
441      if (i_end>255) then
442        print*,'message #',icount,' skipped. Too many elements'
443        GO TO 300
444      endif
445      ip=ktdlen
446!
447      ip=ip+1
448      ktdlst(ip)=225000
449      ip=ip+1
450      ktdlst(ip)=236000
451      ip=ip+1
452      ktdlst(ip)=101000+i_end
453      ip=ip+1
454      ktdlst(ip)=031031
455      ip=ip+1
456      ktdlst(ip)=001031
457      ip=ip+1
458      ktdlst(ip)=001032
459      ip=ip+1
460      ktdlst(ip)=008024
461      ip=ip+1
462      if(ksec1(7).eq.140.OR.ksec1(7).eq.147) then
463         ktdlst(ip)=101001
464      else
465         ktdlst(ip)=101002
466      end if
467      ip=ip+1
468      ktdlst(ip)=225255
469!
470      ktdlen=ip
471!
472!     Add a new bit map and bias
473!
474      ip=ksup(5)
475
476      ip=ip+1
477      values(ip)=0.0
478      ip=ip+1
479      values(ip)=0.0
480!
481      i_010004=0
482      i_010051=0
483      i_007004=0
484      nqcentries=0
485      do i=1,i_end
486        if(ktdexp(i) .eq. 010004.and.nqcentries.lt.2) then
487          i_010004=i
488          nqcentries=nqcentries+1
489        endif
490        if(ktdexp(i) .eq. 010051.and.nqcentries.lt.2) then
491          i_010051=i
492          nqcentries=nqcentries+1
493        endif
494        if(ktdexp(i) .eq. 007004.and.nqcentries.lt.2) then
495          i_007004=i
496          nqcentries=nqcentries+1
497        endif
498      end do
499!
500      do iz=1,i_end
501       ip=ip+1
502       values(ip)=1.
503       if(iz.eq.i_010004) values(ip)=0.
504       if(iz.eq.i_010051) values(ip)=0.
505       if(iz.eq.i_007004) values(ip)=0.
506      end do
507
508      ip=ip+1
509      values(ip)=98.
510      ip=ip+1
511      values(ip)=10.
512      ip=ip+1
513      values(ip)=40.      ! bias
514      ip=ip+1
515      if(IL.eq.0) then
516         values(ip)=rvind
517         if(ksec1(7).ne.140.OR.ksec1(7).eq.147) then
518           ip=ip+1
519           values(ip)=rvind
520         end if
521      else
522!        create identifier
523         if(ksec1(7).eq.1.or.ksec1(7).eq.3.or.ksec1(7).eq.170 &
524            .or.ksec1(7).eq.172.or.ksec1(7).eq.176) then
525            cident=' '
526            if(values(1).eq.rvind.or.values(2).eq.rvind) then
527               cident=' '
528               PRINT*,'Missing block and/or station number'
529!              CALL PBOPEN(IUERR,'error.bufr','W',IRET)
530!              CALL PBWRITE(IUERR,KBUFF,KBUFFL,IERR)
531!              CALL PBCLOSE(IUERR)
532            else
533              write(cident,'(i2.2,i3.3)',iostat=ios) nint(values(1)),&
534              nint(values(2))
535              if(ios.ne.0) then
536                 print*,'internal write error=',ios
537                 call exit(2)
538              end if
539            end if
540         elseif(ksec1(7).eq.9.or.ksec1(7).eq.11.or.&
541             ksec1(7).eq.13.or.ksec1(7).eq.19.or.ksec1(7).eq.180) then
542             cident=cvals(1)
543!        elseif(ksec1(7).eq.178) then
544!           if(values(1).eq.rvind.or.values(2).eq.rvind) then
545!              print*,values(1),' ',values(2)
546!              cident=' '
547!           else
548!             write(cident,'(i4.4,i10.10)',iostat=ios) nint(values(1)),
549!    1        nint(values(2))
550!             if(ios.ne.0) then
551!                print*,'internal write error=',ios
552!                call exit(2)
553!             end if
554!           end if
555         elseif(ksec1(7).eq.9.or.ksec1(7).eq.11.or.&
556            ksec1(7).eq.13.or.ksec1(7).eq.19.or.ksec1(7).eq.180) then
557             cident=cvals(1)
558         elseif(ksec1(7).eq.21) then
559             cident=' '
560             if(values(1).eq.rvind) then
561                cident=' '
562             else
563                write(cident,'(i5.5)',iostat=ios) nint(values(1))
564                if(ios.ne.0) then
565                  print*,'internal write error=',ios
566                  call exit(2)
567               end if
568            end if
569         elseif((ksec1(7).eq.181).or.(ksec1(7).eq.182)) then
570             cident=' '
571             if(values(1).eq.rvind) then
572                cident=' '
573             else
574                write(cident,'(i7.7)',iostat=ios) nint(values(1))
575                if(ios.ne.0) then
576                  print*,'internal write error=',ios
577                  call exit(2)
578               end if
579            end if
580         elseif(ksec1(7).eq.140.OR.ksec1(7).eq.147) then
581             cident=' '
582             cident=cvals(1)
583         else
584             cident=' '
585         end if
586         ctemp=adjustr(cident)
587         call get_bias(ctemp,ksec1,NUM_STATIONS,cid,itype,&
588              isbt,ipc,bias,bias_value0,bias_value1,ierr)
589         values(ip)=bias_value1
590         if(ksec1(7).ne.140.OR.ksec1(7).eq.147) then
591            ip=ip+1
592            values(ip)=bias_value0
593         end if
594      end if
595
596      kel =ip
597!
598!*          6.2 ENCODE DATA INTO BUFR MESSAGE.
599!               ------------------------------
600 620  CONTINUE
601!
602      KSEC3(4)=128
603      IF(KSEC3(3).GT.1) KSEC3(4)=192
604      CALL BUFREN( KSEC0,KSEC1,KSEC2,KSEC3,KSEC4, &
605                   KTDLEN,KTDLST,KDLEN,KDATA,KEL, &
606                   KVALS,VALUES,CVALS,KBUFL,KBUFR,KERR)
607!
608      IF(KERR.GT.0) THEN
609         PRINT*,'ERROR DURING ENCODING. Message skipped'
610         CALL PBOPEN(IUERR,'error.bufr','W',IRET)
611         CALL PBWRITE(IUERR,KBUFF,KBUFFL,IERR)
612         CALL PBCLOSE(IUERR)
613!        CALL EXIT(2)
614         GO TO 300
615      END IF
616
617      NW=NW+1
618!
619!           6.3 WRITE PACKED BUFR MESSAGE INTO FILE.
620!               ------------------------------------
621 630  CONTINUE
622!
623      IKBUFL=KBUFL*4
624      CALL PBWRITE(IUNIT1,KBUFR,IKBUFL,IERR)
625      IF(IERR.LT.0) THEN
626         PRINT*,'ERROR WRITING INTO TARGET FILE.'
627         CALL EXIT(2)
628      END IF
629!
630!
631      GO TO 300
632!     -----------------------------------------------------------------
633!
634 810  CONTINUE
635!
636      WRITE(*,'(1H ,A)') 'OPEN ERROR ON INPUT FILE'
637      GO TO 900
638!
639 800  CONTINUE
640!
641      IF(IRET.EQ.-1) THEN
642         PRINT*,'NUMBER OF RECORDS PROCESSED ',N
643         PRINT*,'NUMBER OF RECORDS CONVERTED ',NW
644!
645      ELSE
646         PRINT*,' BUFR : ERROR= ',IERR
647      END IF
648!
649 900  CONTINUE
650!
651      PRINT*,'NUMBER OF RECORDS PROCESSED ',N
652      PRINT*,'NUMBER OF RECORDS CONVERTED ',NW
653!
654      CALL PBCLOSE(IUNIT,IRET)
655!
656      CALL PBCLOSE(IUNIT1,IRET)
657!
658      END
659      SUBROUTINE CUTZERO(CHARPAR,KMIN)
660!
661!**** CUTZERO - SUBROUTINE TO REMOVE ZERO CHARACTERS.
662!
663!**   PURPOSE
664!     -------
665!
666!     TO REMOVE ZERO-FILL CHARACTERS FROM THE END OF A CHARACTER
667!     VARIABLE.
668!
669!     INTERFACE
670!     ---------
671!
672!     CALL CUTZERO(CHARPAR,KMIN)
673!
674!          CHARPAR  - CHARACTER VARIABLE WHICH MAY HAVE ZEROS AT THE
675!                     END OF THE VALID CHARACTERS, WHICH NEED TO BE
676!                     REMOVED;
677!                     RETURNED WITH THE ZERO CHARACTERS CONVERTED TO
678!                     BLANK.
679!
680!          KMIN     - INTEGER VARIABLE INDICATING A MINIMUM NUMBER OF
681!                     CHARACTERS AT THE BEGINNING OF THE STRING WHICH
682!                     MUST NOT BE CHANGED
683!
684!     THUS:
685!
686!     CHARPAR='ABC0000'
687!     CALL CUTZERO(CHARPAR,4)
688!
689!     WOULD RETURN THE VALUE 'ABC0   ' IN CHAR, AND WOULD NOT
690!     ALTER THE FIRST 4 CHARACTERS.
691!
692!     METHOD
693!     ------
694!
695!     THE STRIG IS TESTED FOR THE EXISTANCE OF A ZERO CHARACTER.
696!     IF NONE IS FOUND, NO CHANGE TAKES PLACE.
697!     IF ONE OR MORE ZERO CHARACTERS ARE PRESENT, THE END OF THE
698!     STRING IS LOCATED. WORKING BACKWARDS FROM THE END TO THE
699!     KMIN-1 POSITION, CHARACTERS ARE TESTED FOR ZERO. IF A ZERO
700!     IS FOUND, IT IS REPLACED BY BLANK. IF A NON-ZERO IS FOUND,
701!     THE REPLACEMENT LOOP TERMINATES.
702!
703!     MODIFICATIONS
704!     -------------
705!
706!     ORIGINAL VERSION - 25.01.95 - REX GIBSON - ECMWF.
707!
708      CHARACTER*(*) CHARPAR
709      CHARACTER*1   YZERO
710      INTEGER LEN
711!
712!     -----------------------------------------------------------
713!
714!*     1.     FIND AND REPLACE THE ZERO CHARACTERS.
715!
716  100 CONTINUE
717      YZERO=CHAR(0)
718      I1=INDEX(CHARPAR,'0')
719      IF (I1.GT.0) THEN
720         I2=MAX(I1,KMIN+1)
721         I3=INDEX(CHARPAR,' ')-1
722         IF (I3.LE.0) THEN
723            I3=LEN(CHARPAR)
724         ENDIF
725         DO 112 J=I3,I2,-1
726         IF (CHARPAR(J:J).EQ.'0') THEN
727             CHARPAR(J:J)=' '
728         ELSEIF (CHARPAR(J:J).EQ.YZERO) THEN
729             GO TO 112
730         ELSE
731             GO TO 114
732         ENDIF
733  112    CONTINUE
734!
735  114    CONTINUE
736      ENDIF
737!
738!     -----------------------------------------------------------
739!
740!*     2.     RETURN.
741!
742  200 CONTINUE
743!
744      END
745      SUBROUTINE  GET_BIAS(CIDENT,KSEC1,K_STATIONS,CID,KTYPE,KSBT,&
746                KPC,BIAS,BIAS_VALUE0,BIAS_VALUE1,KERR)
747!**** *GET_BIAS*
748!
749!
750!     PURPOSE.
751!     --------
752!
753!          Get bias value for particular station
754!
755!
756!**   INTERFACE.
757!     ----------
758!
759!          NONE.
760!
761!     METHOD.
762!     -------
763!
764!          NONE.
765!
766!
767!     EXTERNALS.
768!     ----------
769!
770!          NONE.
771!
772!     REFERENCE.
773!     ----------
774!
775!          NONE.
776!
777!     AUTHOR.
778!     -------
779!
780!
781!          M. DRAGOSAVAC    *ECMWF*       06/11/2004.
782!
783!
784!     MODIFICATIONS.
785!     --------------
786!
787!          NONE.
788!
789!
790!
791!     -------------------------------------------------------------
792
793      CHARACTER*8 CIDENT
794      DIMENSION KSEC1(*), KTYPE(*), KSBT(*), KPC(*),BIAS(*)
795      CHARACTER*(*) CID(*)
796      REAL*8 BIAS_VALUE0, BIAS_VALUE1
797
798      KERR=0
799      BIAS_VALUE0=1.7D38
800      BIAS_VALUE1=1.7D38
801!
802      IF(K_STATIONS.EQ.0) RETURN
803
804      DO I=1,K_STATIONS
805        if(CIDENT.eq.CID(I)) THEN
806           IF(KSEC1(6).EQ.KTYPE(I).AND.KSEC1(7).EQ.KSBT(I).AND.&
807              KPC(i).EQ.0) THEN
808              BIAS_VALUE0=BIAS(I)
809           ELSEIF(KSEC1(6).EQ.KTYPE(I).AND.KSEC1(7).EQ.KSBT(I).AND.&
810              KPC(I).EQ.1) THEN
811              BIAS_VALUE1=BIAS(I)
812           END IF
813        END IF
814      END DO
815      RETURN
816      END
817