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