1 PROGRAM synop2bufr 2C 3C 4c**** *synop2bufr* 5c 6c 7c PURPOSE. 8c -------- 9c Read GTS bulletin from the file 10c and creates WMO 307080 template bufr data 11c 12c 13c** INTERFACE. 14c ---------- 15c 16c NONE. 17c 18c METHOD. 19c ------- 20c 21c NONE. 22c 23c 24c EXTERNALS. 25c ---------- 26c 27c 28c REFERENCE. 29c ---------- 30c 31c NONE. 32c 33c AUTHOR. 34c ------- 35c 36c MILAN DRAGOSAVAC *ECMWF* 2009/04/27 37c 38c 39c MODIFICATIONS. 40c -------------- 41c 42c NONE. 43c 44c 45c IMPLICIT NONE 46c 47c 48 include 'cominit.h' 49c 50c 51 CHARACTER*256 CARG(10) 52c 53 CHARACTER*256 CINFILE 54 CHARACTER*256 COUTFILE 55 56 INTEGER NARG 57 INTEGER IARGC 58 INTEGER I,J,IO,IN,IERR,K 59 INTEGER KBUFL 60 INTEGER KBUFR(128000) 61 INTEGER IUNIT,IUNIT1 62 LOGICAL FIRST 63 64 CHARACTER*512000 YOUT 65 CHARACTER*3 CCCC 66c ------------------------------------------------------------------ 67 68c GET INPUT AND OUTPUT FILE NAME. 69 70 NCENTRE=0 71 NARG=IARGC() 72 73 DO J=1,NARG 74 CALL GETARG(J,CARG(J)) 75 END DO 76 77 cinfile=' ' 78 coutfile=' ' 79 80 DO J=1,NARG,2 81 IF(CARG(J).EQ.'-i') THEN 82 CINFILE=CARG(J+1) 83 IN=index(CINFILE,' ') 84 IN=IN-1 85 ELSEIF(CARG(J).EQ.'-o') THEN 86 COUTFILE=CARG(J+1) 87 IO=index(COUTFILE,' ') 88 IO=IO-1 89 ELSEIF(CARG(J).EQ.'-c') THEN 90 CCCC=CARG(J+1) 91 read(CCCC,'(i3.3)') NCENTRE 92 END IF 93 END DO 94c 95 if(in .eq.0 .or.io .eq.0 .or. NCENTRE.eq.0) then 96 PRINT*,'USAGE -- synop2bufr -i infile -o outfile -c centre' 97 STOP 98 END IF 99 100c* 1.2 OPEN FILE CONTAINING GTS BULLETIN and BUFR FILE. 101 102 120 CONTINUE 103 104 CALL PBOPEN(IUNIT,CINFILE(1:IN),'R',IERR) 105 IF(IERR.EQ.-1) STOP 'OPEN FAILED INPUT FILE' 106 IF(IERR.EQ.-2) STOP 'INVALID FILE NAME' 107 IF(IERR.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED' 108 109 CALL PBOPEN(IUNIT1,COUTFILE(1:IO),'W',IERR) 110 IF(IERR.EQ.-1) STOP 'OPEN FAILED ON OUTPUT FILE' 111 IF(IERR.EQ.-2) STOP 'INVALID FILE NAME' 112 IF(IERR.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED' 113 114 first=.true. 115c ----------------------------------------------------------------- 116 117c* 3. READ INPUT FILE 118c --------------- 119 300 CONTINUE 120 121 KREC=0 122 IERR=0 123 DO WHILE ( IERR .eq.0) 124 K=0 125 CALL READ_GTS(IUNIT,YOUT,K,IERR) 126 IF(IERR.eq.1) THEN 127 ierr=0 128 KREC=KREC+1 129 print*,'Bulletin number ---------',KREC 130! print*,YOUT(1:len_trim(YOUT)) 131 CALL DECODE(K,YOUT,IERR) 132 if(ierr.ne.0) then 133 print*,'Error in decoding bulletin ',ierr 134 ierr=0 135 end if 136 Print*,'The file is processed' 137 go to 400 138 end if 139 KREC=KREC+1 140 print*,'Bulletin number ---------',KREC 141! print*,YOUT(1:len_trim(YOUT)) 142c 143 ierr=0 144 CALL DECODE(K,YOUT,IERR) 145 if(ierr.ne.0) then 146 print*,'Error in decoding bulletin ',ierr 147 ierr=0 148 end if 149c 150 END DO 151c 152 400 continue 153c400 CALL PBCLOSE(IUNIT,IERR) 154c CALL PBCLOSE(IUNIT1,IERR) 155 156 END 157 158 SUBROUTINE DECODE(KLEN,YIN,IERR) 159C 160C 161 162C 163C**** *DECODE* 164C 165C 166C PURPOSE. 167C -------- 168C CONTROLLING ROUTINE FOR DECODING 169C DATA. 170C 171C 172C** INTERFACE. 173C ---------- 174C 175C *CALL* *DECODE(KLEN,YIN,KBUFL,KBUFR,KERR)* 176C KLEN - size in bytes of YIN 177C YIN - character string containing one bulletin 178C KUNIT - output file unit number 179C KERR - return error code 180C 181C METHOD. 182C ------- 183C 184C NONE. 185C 186C 187C EXTERNALS. 188C ---------- 189C 190C 191C REFERENCE. 192C ---------- 193C 194C NONE. 195C 196C AUTHOR. 197C ------- 198C 199C M. D. DRAGOSAVAC *ECMWF* 2009/04/27 200C 201C 202C MODIFICATIONS. 203C -------------- 204C 205C NONE. 206C 207C 208 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 209C 210C 211 INCLUDE 'parameter.h' 212 INCLUDE 'combuff.h' 213 INCLUDE 'comwork.h' 214 INCLUDE 'comrec.h' 215 INCLUDE 'compoin.h' 216 INCLUDE 'comstat.h' 217 INCLUDE 'comkey.h' 218C 219 CHARACTER*(*) YIN 220C 221C ------------------------------------------------------------------ 222C* 1. INITIALIZE VARIABLES AND CONSTANTS. 223C ---------------------------------- 224 100 CONTINUE 225C 226 IERR=0 227C 228 229 CALL INITVAR( IERR ) 230 IF(IERR.NE.0) CALL exit(2) 231C 232C Move character string into integer array 233C 234 ILEN=KLEN 235C 236 DO 141 I=1,ILEN 237C 238 KCHAR(I)=IAND(ICHAR(YIN(I:I)),127) 239C 240 141 CONTINUE 241 242C --------------------------------------------------------------- 243 244 CALL SYNOP(IERR) 245C 246 RETURN 247 248C 249C ------------------------------------------------------------------ 250C 251 1000 CONTINUE 252C 253 RETURN 254 END 255 SUBROUTINE SYNOP(IERR) 256C 257C 258C**** *SYNOP* 259C 260C 261C 262C PURPOSE. 263C -------- 264C CONTROLLING ROUTINE FOR DECODING 265C SYNOP DATA. 266C 267C 268C** INTERFACE. 269C ---------- 270C 271C NONE. 272C 273C METHOD. 274C ------- 275C 276C NONE. 277C 278C 279C EXTERNALS. 280C ---------- 281C 282C *CALL* *INITVAR( IERR )* 283C *CALL* *PROCRFB( IERR )* 284C *CALL* *PROCHDR( IERR )* 285C *CALL* *PROCTXT( IERR )* 286C *CALL* *PROCT1S( IERR )* 287C 288C REFERENCE. 289C ---------- 290C 291C NONE. 292C 293C AUTHOR. 294C ------- 295C 296C M. D. DRAGOSAVAC *ECMWF* 15/08/88. 297C 298C 299C MODIFICATIONS. 300C -------------- 301C 302C NONE. 303C 304C 305 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 306C 307C 308 INCLUDE 'parameter.h' 309 INCLUDE 'comwork.h' 310 INCLUDE 'combuff.h' 311 INCLUDE 'comrec.h' 312C 313C ------------------------------------------------------------------ 314C* 1. INITIALIZE VARIABLES AND CONSTANTS. 315C ---------------------------------- 316 100 CONTINUE 317C 318C ------------------------------------------------------------------ 319C* 3. FORMAT BULLETIN. 320C ---------------- 321 300 CONTINUE 322C 323 CALL PROCRFB( IERR ) 324 IF(IERR.NE.0) RETURN 325C ------------------------------------------------------------------ 326C* 4. DECODE BULLETIN HEADER. 327C ----------------------- 328 400 CONTINUE 329C 330 CALL PROCHDR( IERR ) 331 IF(KERR.NE.0) RETURN 332C ------------------------------------------------------------------ 333C* 5. CHECK TEXT OF BULLETIN. 334C ----------------------- 335 500 CONTINUE 336C 337 CALL PROCTXT( IERR ) 338 IF(KERR.NE.0) RETURN 339C 340C ------------------------------------------------------------------ 341C* 6. CALL APPROPRIATE ROUTINE TO DECODE SYNOP DATA. 342C --------------------------------------------- 343 600 CONTINUE 344C 345 CALL PROCT1S( IERR ) 346C 347C ------------------------------------------------------------------ 348 RETURN 349 END 350 SUBROUTINE PROCRFB ( IERR ) 351C 352C 353C**** *PROCRFB* 354C 355C 356C PURPOSE. 357C -------- 358C PURPOSE OF THIS ROUTINE IS TO FORMAT BULLETIN. 359C 360C** INTERFACE. 361C ---------- 362C 363C *CALL* *PROCRFB(IERR)* 364C 365C METHOD. 366C ------- 367C 368C NONE. 369C 370C 371C EXTERNALS. 372C ---------- 373C 374C NONE. 375C 376C REFERENCE. 377C ---------- 378C 379C NONE. 380C 381C AUTHOR. 382C ------- 383C 384C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 385C J. HENNESSY *ECMWF* 386C 387C MODIFICATIONS. 388C -------------- 389C 390C NONE. 391C 392C 393 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 394C 395C 396 INCLUDE 'parameter.h' 397 INCLUDE 'combuff.h' 398 INCLUDE 'comwork.h' 399 INCLUDE 'comindx.h' 400 INCLUDE 'comstat.h' 401C ------------------------------------------------------------------ 402C* 1. KEEP SOURCE OF DATA AND DATE/TIME OF ARRIVAL. 403C --------------------------------------------- 404 100 CONTINUE 405C 406 DO 101 I=1,3 407C 408 KHEAD(I)=MINDIC ! THIS WILL BE CHANGED ACCORDING TO THE KEY. 409C 410 101 CONTINUE 411C ------------------------------------------------------------------ 412C* 2. DEFINE T1 AND T2 FROM ABBREVIATED HEADING. 413C ------------------------------------------ 414 200 CONTINUE 415 416 DO 202 I=1,ILEN 417C 418 IF(KCHAR(I).GE.65.AND.KCHAR(I).LE.90) GO TO 203 419C 420 202 CONTINUE 421C 422 IT1=27 423 GO TO 210 424C 425 203 CONTINUE 426C 427 IT1=KCHAR(I )-64 428 IT2=KCHAR(I+1)-64 429C 430 IF(IT1.NE.19) THEN 431 IERR=1 432 IT1=27 433 RETURN 434 END IF 435C 436C CHECK IF 'T2' CHARACTER IS LETTER. 437C 438 IF(IT2.LT.1.OR.IT2.GT.26) IT1=27 439C 440C* 2.1 LAST CHARACTER OF BULLETIN CAN BE IN ANY OF THE LAST 441C ----------------------------------------------------- 442C 5 WORDS. IF CHARACTER IS 'ETX' REPLACE BY 'GS' . 443C ------------------------------------------------- 444C IF NEITHER CAN BE FOUND INSERT 'GS' AS LAST CHARACTER. 445C ------------------------------------------------------ 446 210 CONTINUE 447C 448 IST=ILEN-5 449C 450 DO 211 I=1,ILEN 451C 452 IF (KCHAR(I).EQ.3.OR.KCHAR(I).EQ.29) THEN 453 KCHAR(I)= 29 454 IGS=I 455 RETURN 456 END IF 457C 458 211 CONTINUE 459C 460 I=I-1 461 KCHAR(I)= 29 462 IGS=I 463C 464 RETURN 465 END 466 SUBROUTINE PROCTXT ( IERR ) 467C 468C 469C**** *PROCTXT* 470C 471C 472C PURPOSE. 473C -------- 474C CHECKS WHETHER BULLETIN CONTAINS USEFUL DATA . 475C THE FOLLOWING BULLETINS ARE CONSIDERED TO CONTAIN 476C NO USEFUL DATA. 477C 1. TEXT OF 'NIL' , OR VARIANTS OF THIS. 478C 2. TEXT OF 'NO DATA AVAILABLE'. 479C 3. TEXT OF 'NO REPORTS AVAILABLE'. 480C 1. - 3. ARE DETERMINED SIMPLY BY CHECKING 481C THE LENGTH OF THE TEXT . IF IT IS LESS 482C THAN 26 THERE CANT BE ANY USEFUL DATA IN IT 483C 4. UK AND GERMAN DOMESTIC BULLETINS WHICH DO 484C NOT CONFORM TO WMO CODES. 485C 486C INPUT : BULLETIN IN ARRAY 'KCHAR' , 487C ONE CHARACTER PER WORD. 488C 489C OUTPUT : KERR = 0 INDICATES BULLETIN CONTENTS REQUIRED. 490C = 1 MEANS TEXT OF 'NIL' ETC. 491C = 2 UK OR GERMAN DOMESTIC BULLETIN. 492C 493C** INTERFACE. 494C ---------- 495C 496C *CALL* *PROCTXT(IERR)* 497C 498C METHOD. 499C ------- 500C 501C NONE. 502C 503C 504C EXTERNALS. 505C ---------- 506C 507C *CALL* *NEXTLET(I,J)* 508C *CALL* *PRTBULL(I,J)* 509C *CALL* *SAVBULL(IERR)* 510C 511C REFERENCE. 512C ---------- 513C 514C NONE. 515C 516C AUTHOR. 517C ------- 518C 519C M. D. DRAGOSAVAC *ECMWF* 15/08/88. 520C J. HENNESSY *ECMWF* 521C 522C MODIFICATIONS. 523C -------------- 524C 525C NONE. 526C 527C 528 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 529C 530 INCLUDE 'parameter.h' 531 INCLUDE 'comwork.h' 532 INCLUDE 'comindx.h' 533 INCLUDE 'comstat.h' 534 INCLUDE 'combuff.h' 535C 536C ------------------------------------------------------------------ 537C 538C* 1. CLEAR ERROR INDICATOR. 539C ---------------------- 540 100 CONTINUE 541C 542 KERR= 0 543C 544C 545C* 1.1 CHECK IF BULLETIN IS TOO SHORT I.E. "NIL" BULLETIN. 546C --------------------------------------------------- 547 110 CONTINUE 548C 549 ILE = IGS - IMI 550 IF(ILE .LT. 26) THEN 551 KERR = 7 552 NUMBERR(7) = NUMBERR(7) + 1 553c KCHAR(IGS)=KCHAR(IGS).OR.128 554 KCHAR(IGS)=IAND(KCHAR(IGS),128) 555C GO TO 900 556 END IF 557C 558C 559C* 1.2 CHECK IF THE BULLETIN IS DOMESTIC FROM UK OR GERMANY. 560C ----------------------------------------------------- 561C THIS IS DONE BY CHECKING IF THE BULLETIN HAS 562C -------------------------------------------- 563C CCCC OF (EG--,ED--) OTHER THAN (EGRR,EDZW). 564C ------------------------------------------- 565 120 CONTINUE 566C 567 IPT=IAH+4 568 CALL NEXTLET(IPT,JAH) 569C 570C IF BULLETINS HAVE 'CCCC' NOT 'ED--' OR 'EG--' , RETURN. 571C 572 IF ( KCHAR(IPT).NE.69 ) RETURN 573 IF ( KCHAR(IPT+1).NE.71.AND.KCHAR(IPT+1).NE.68 ) RETURN 574C 575C FIRST UK 576C 577 IF (KCHAR(IPT+1).EQ.71) 578 C THEN 579 IF(KCHAR(IPT+2) .NE. 82 .OR. 580 1 KCHAR(IPT+3) .NE. 82) 581 2 KERR = 8 582 ELSE 583C 584C THEN GERMANY 585C 586 IF(KCHAR(IPT+2) .NE. 90 .OR. 587 1 KCHAR(IPT+3) .NE. 87) 588 2 KERR = 8 589 END IF 590C 591C MARK CCCC GROUP IF REQUIRED. 592C 593 IF ( KERR.EQ.8 ) THEN 594 KCHAR(IPT+4) = IOR(KCHAR(IPT+4),128) 595 NUMBERR(8) = NUMBERR(8) + 1 596 END IF 597C 598C 1.3 TREAT IN ACCORDANCE WITH DEFINED OPTIONS. 599C ----------------------------------------- 600 130 CONTINUE 601C 602C RETURN IF NO ERROR. 603C 604 IF ( KERR.EQ.0 ) RETURN 605C 606C 607 900 CONTINUE 608C 609 N = KERR - 1 610 N1 =IAND(ISHFT(IOPTS(677),-N),1) 611 N2 =IAND(ISHFT(IOPTS(678),-N),1) 612C 613C 1.4 PRINT BULLETIN IF REQUIRED. 614C --------------------------- 615 140 CONTINUE 616C 617 IF (N1.EQ.1) THEN 618 WRITE (*,9900) KERR 619 CALL PRTBULL (1,IGS) 620 END IF 621C 622C 1.5 WRITE TO ERROR FILE IF REQUIRED. 623C -------------------------------- 624 150 CONTINUE 625C 626 IF ( N2.EQ.1 ) CALL SAVBULL(IERR) 627 RETURN 628C ----------------------------------------------------------------- 629 9900 FORMAT (1H ,'BULLETIN ERROR NUMBER ',I2.2) 630C ----------------------------------------------------------------- 631 END 632 SUBROUTINE PROCHDR ( IERR ) 633C 634C 635C**** *PROCHDR 636C 637C 638C PURPOSE. 639C -------- 640C DEODE BULLETIN HEADER AND INSERT REQUIRED PARAMETERS 641C IN DECODED REPORT HEADER. 642C 643C LOCATES BEGINNING AND END OF ABBREVIATED HEADER AND 644C 'MIMIMJMJ' LINES. 645C 646C INPUT : BULLETIN IN KCHAR(1) - KCHAR(IGS) 647C 648C BULLETIN RECORD HEADER IN KINT(1) - KINT(5) 649C 650C 'IT1' = 27 INDICATING BULLETIN HAS NOT BEEN 651C IDENTIFIED FROM 'TT' OF ABBREVIATED HEADER. 652C 653C OUTPUT : KDEC(10) = DAY OF MONTH ( INTEGER ) . YY 654C KDEC(11) = TIME OF BULLETIN - HOURS ( INTEGER ) . G 655C KDEC(12) = TIME OF BULLETIN - MINS ( INTEGER ) . GG 656C 657C KDEC(14) = 0 IF ORIGIN OF REPORT IS FGGE. 658C 1 " " " " " BRACKNELL. 659C 2 " " " " " OFFENBACH. 660C 661C KDEC(20) =1 NIL 662C KDEC(21) =1 IF BULLETIN IS 'COR' , OTHERWISE 663C = 0 . 664C 665C KDEC(21) = 1 IF BULLERIN IS 'CCA' 666C KDEC(21) = 2 IF BULLERIN IS 'CCB' 667C KDEC(21) = 3 IF BULLERIN IS 'CCC' 668C KDEC(21) = 4 IF BULLERIN IS 'CCD' 669C . 670C . 671C 672C KDEC(18) = DATE OF BULLETIN ARRIVAL ( ON VAX ) 673C KDEC(19) = TIME " " " " " 674C 675C IAH = " " BEGINNING OF 'ABBREVIATED HEADER' 676C JAH = " " END " " " 677C 678C IMI = " " BEGINNING OF 'MIMIMJMJ' LINE. 679C JMI = " " END " " " 680C 681C KERR = 0 IF NO ERROR FATAL TO DECODING ENCOUNTERED. 682C = 1 IF BULLETIN HAS LESS THAN 3 LINES. 683C = 2 IF BULLETIN IS NOT RECOGNISED. 684C 685C 686C** INTERFACE. 687C ---------- 688C 689C *CALL* *PROCHDR( IERR )* 690C 691C METHOD. 692C ------- 693C 694C NONE. 695C 696C 697C EXTERNALS. 698C ---------- 699C 700C *CALL* *NEXTPRT(I,J)* 701C *CALL* *NEXTEND(I,J)* 702C *CALL* *NEXTFIG(I,J)* 703C *CALL* *EXTGRP (I,N1,N2,N3,N4,N5,N,IRET)* 704C *CALL* *NEXTLET(I,J)* 705C *CALL* *SAVBULL(IERR )* 706C 707C REFERENCE. 708C ---------- 709C 710C NONE. 711C 712C AUTHOR. 713C ------- 714C 715C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 716C J. HENNESSY *ECMWF* 717C 718C 719C MODIFICATIONS. 720C -------------- 721C 722C NONE. 723C 724C 725 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 726C 727 INCLUDE 'parameter.h' 728 INCLUDE 'comwork.h' 729 INCLUDE 'combuff.h' 730 INCLUDE 'comindx.h' 731 INCLUDE 'comstat.h' 732C 733 DIMENSION ILST(26) 734 DATA ILST/65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80, 735 1 81,82,83,84,85,86,87,88,89,90/ 736C ------------------------------------------------------------------ 737C 738C* 1. CLEAR ERROR INDICATOR AND SET REPORT HEADER AREA 739C ------------------------------------------------ 740C TO MISSING DATA INDICATOR. 741C -------------------------- 742 100 CONTINUE 743C 744 KERR=0 745C 746 DO 101 I=1,24 747C 748 KDEC(I)= MINDIC 749C 750 101 CONTINUE 751C 752C* 1.1 FLAG FIELDS SET TO ZERO. 753C ------------------------ 754 110 CONTINUE 755C 756 KDEC(13)=0 757 KDEC(15)=0 758 KDEC(21)=0 759C 760C* 2. LOCATE BEGINNING AND END OF 'STARTING LINE' , 761C --------------------------------------------- 762C 'ABBREVIATED HEADER' AND 'MIMIMJMJ LINE ' . 763C ------------------------------------------- 764C 765 ISL = 1 766 CALL NEXTPRT ( ISL,IGS ) 767 JSL = ISL 768 CALL NEXTEND ( JSL,IGS ) 769 IAH = JSL 770 CALL NEXTPRT ( IAH,IGS ) 771 JAH =IAH 772 CALL NEXTEND ( JAH,IGS ) 773 IMI = JAH 774 CALL NEXTPRT ( IMI,IGS ) 775 JMI = IMI 776 CALL NEXTEND ( JMI,IGS ) 777C 778C* 2.1 IF THESE 3 LINES CANNOT BE LOCATED , BULLETIN CONSISTS 779C ------------------------------------------------------ 780C OF LESS THAN 3 LINES. 781C --------------------- 782 210 CONTINUE 783C 784 IF ( JMI.GT.IGS ) THEN 785C 786C SET ERROR NUMBER AND MARK ERROR. 787C 788 KERR = 1 789 KCHAR(IGS)=IOR(KCHAR(IGS),128) 790 NUMBERR(1) = NUMBERR(1) + 1 791 GO TO 300 792 END IF 793C 794C 795C 796C* 2.2 BULLETIN CANNOT BE IDENTIFIED FROM 'TT' . 797C ----------------------------------------- 798 220 CONTINUE 799C 800 IF ( IT1.EQ.27 ) THEN 801C 802C SET ERROR NUMBER AND MARK ERROR. 803C 804 KERR = 2 805 KCHAR(IAH+2)=IOR(KCHAR(IAH+2),128) 806 NUMBERR(2) = NUMBERR(2) + 1 807 GO TO 300 808 END IF 809C 810C 811C* 2.3 NO CHECKS ARE MADE ON TTAAII OR CCCC GROUPS. 812C -------------------------------------------- 813 230 CONTINUE 814C 815C 816C 817C* 2.4 LOCATE AND DECODE 'YYGGGG' GROUP . 818C ---------------------------------- 819 240 CONTINUE 820C 821C SCAN 'KCHAR' FOR FIRST FIGURE AFTER 'II' FIGURES. 822C 823 IPT = IAH + 6 824 CALL NEXTFIG ( IPT,JAH ) 825 IF ( IPT.GE.JAH ) THEN 826 KERR = 5 827 ELSE 828C 829C EXTRACT YY,GG AND GG AND CONVERT TO INTEGERS 830C IN WORDS 10-12 OF 'KINT' . 831C 832 CALL EXTGRP( IPT,2,2,2,0,0,10,IRET ) 833 IPT = IABS(IPT) 834C 835C TEST VALIDITY OF YY,GG AND GG. 836C THIS TEST MAKES CHECKING RETURN CODE 'IRET' 837C UNNECESSARY. 838C 839 IF ( KINT(10).LT.1.OR.KINT(10).GT.31 ) 840 C THEN 841 KERR = 5 842 KINT(10) = MINDIC 843 END IF 844C 845 IF ( KINT(11).LT.0.OR.KINT(11).GT.23 ) 846 C THEN 847 KERR = 5 848 KINT(11) = MINDIC 849 END IF 850C 851 IF ( KINT(12).LT.0.OR.KINT(12).GT.59 ) 852 C THEN 853 KERR = 5 854 KINT(11) = MINDIC 855 END IF 856C 857C 858C COPY TO DECODED REPORT HEADER AREA 859C AND RESET WORDS IN 'KINT'. 860C 861 DO 241 I=10,12 862 KDEC(I) = KINT(I) 863 KINT(I) = MINDIC 864 241 CONTINUE 865C 866 END IF 867C 868C MARK ERROR IN YYGGGG GROUP. 869C 870 IF ( KERR.EQ.5 ) THEN 871 KCHAR(IPT)=IOR(KCHAR(IPT),128) 872 NUMBERR(5) = NUMBERR(5) + 1 873 END IF 874C 875C 876C 877C 878C* 2.5 THE ONLY CHECK ON 'BBB' IS FOR 'COR'. 879C ------------------------------------- 880 250 CONTINUE 881C 882C FIND NEXT LETTER IN ABBREVIATED HEADER LINE AND CHECK IF 'C' (67) 883C 884C CALL PRTBULL(1,IGS) 885 CALL NEXTLET ( IPT,JAH ) 886C 887 IF ( KCHAR(IPT).EQ.67.AND.KCHAR(IPT+1).EQ.79) THEN 888 KDEC(21)=1 889 GO TO 260 890 END IF 891 IF ( KCHAR(IPT).EQ.67.AND.KCHAR(IPT+1).EQ.67) 892 1 THEN 893 DO 251 IJ=1,26 894 IF(KCHAR(IPT+2).EQ.ILST(IJ)) THEN 895 KDEC(21)=IJ 896 GO TO 260 897 END IF 898C 899 251 CONTINUE 900C 901 END IF 902C 903C 904C 905C* 2.6 INSERT ORIGIN AND DATE/TIME OF ARRIVAL OF BULLETIN. 906C --------------------------------------------------- 907 260 CONTINUE 908C 909C ORIGIN IS DERIVED FROM KEY . BRACKNELL FILE 910C NAMES START WITH 'B' AND OFFENBACH WITH 'C'. THIS FILENAME IS 911C IN ASCCI CODE ( 'B' =66 , 'C' = 67) 912C 913 KDEC(14) = MINDIC ! ORIGIN WILL BE DEFINED FROM KEY. 914C 915C 916 KDEC(18) = MINDIC ! DATE AND TIME OF ARRIVAL 917 KDEC(19) = MINDIC ! 918C 919C 920C 921C* 2.7 TREAT ERROR BULLETIN IN ACCORDANCE WITH DEFINED OPTIONS. 922C -------------------------------------------------------- 923 270 CONTINUE 924C 925C RETURN IF NO ERRORS FOUND. 926C 927 IF ( KERR.EQ.0 ) RETURN 928C 929C 930C* 3. HANDLE ERROR BULLETIN. 931C ---------------------- 932 300 CONTINUE 933C 934 N = KERR-1 935 N1 =IAND(ISHFT(IOPTS(677),-N),1) 936 N2 =IAND(ISHFT(IOPTS(678),-N),1) 937C 938C* 3.1 PRINT BULLETIN IF REQUIRED. 939C --------------------------- 940 310 CONTINUE 941C 942 IF ( N1.EQ.1 ) THEN 943 WRITE (*,9900) KERR 944 CALL PRTBULL ( 1,IGS) 945 END IF 946C 947C* 3.2 WRITE BULLETIN TO ERROR FILE IF REQUIRED. 948C ----------------------------------------- 949 320 CONTINUE 950C 951 IF ( N2.EQ.1 ) CALL SAVBULL(IERR) 952C 953C* 3.3 ONLY ERRORS 1 AND 2 ARE FATAL TO DECODING , SO CLEAR 954C ----------------------------------------------------- 955C ERROR INDICATOR BEFORE RETURNING. 956C --------------------------------- 957 330 CONTINUE 958 959 IF ( KERR.GT.2 ) KERR = 0 960C 961C 962 RETURN 963C 964C 965 9900 FORMAT (1H ,'BULLETIN ERROR NUMBER ',I2.2) 966C 967C 968 END 969 SUBROUTINE PROCT1S ( IERR ) 970C 971C 972C**** *PROCT1S* 973C 974C 975C PURPOSE. 976C -------- 977C CONTROLLING ROUTINE FOR DECODING SURFASE 978C DATA ( BULLETINS WITH 'T1' OF 'S' ) 979C 980C INPUT : IERR IS NOT USED ON INPUT. 981C 982C IT2 = 1-26 CORRESPONDING TO 'T2' OF A-Z. 983C 984C OUTPUT : IERR IS UNALTERED UNLESS A FATAL ERROR OCCURRS , 985C WHEN IT IS SET TO 1. 986C 987C** INTERFACE. 988C ---------- 989C 990C *CALL* *PROCT1S(IERR)* 991C 992C METHOD. 993C ------- 994C 995C NONE. 996C 997C 998C EXTERNALS. 999C ---------- 1000C 1001C *CALL* *BULLSM(IERR)* 1002C 1003C REFERENCE. 1004C ---------- 1005C 1006C NONE. 1007C 1008C AUTHOR. 1009C ------- 1010C 1011C 1012C 1013C MODIFICATIONS. 1014C -------------- 1015C 1016C M. DRAGOSAVAC *ECMWF* AUG 1988. 1017C 1018C 1019C 1020 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 1021C 1022C 1023 INCLUDE 'parameter.h' 1024 INCLUDE 'comwork.h' 1025C 1026C ------------------------------------------------------------------ 1027C* 1. CALL APPROPRIATE ROUTINE, 'IT2' CONTAINS AN INTEGER IN THE 1028C --------------------------------------------------------- 1029C RANGE 1-26, CORRESPONDING TO 'T2' OF ABBREVIATED HEADER. 1030C ------------------------------------------------------- 1031 100 CONTINUE 1032C 1033C 1034 GOTO ( 110,120,130,140,150,160,170,180,190,200,210,220,230, 1035 C 240,250,260,270,280,290,300,310,320,330,340,350,360) IT2 1036C 1037C ----------------------------------------------------------------- 1038C* 1.1 BULLETINS WITH 'TT' = 'SA'. 1039C ---------------------------------------------- 1040 110 CONTINUE 1041 RETURN 1042C ----------------------------------------------------------------- 1043C* 1.2 BULLETINS WITH 'TT' = 'SB'. 1044C --------------------------- 1045 120 CONTINUE 1046 RETURN 1047C ----------------------------------------------------------------- 1048C* 1.3 BULLETINS WITH 'TT' = 'SC'. 1049C --------------------------- 1050 130 CONTINUE 1051 RETURN 1052C ----------------------------------------------------------------- 1053C* 1.4 BULLETINS WITH 'TT' = 'SD'. 1054C --------------------------- 1055 140 CONTINUE 1056 RETURN 1057C ----------------------------------------------------------------- 1058C* 1.5 BULLETINS WITH 'TT' = 'SE'. 1059C ---------------------------- 1060 150 CONTINUE 1061 RETURN 1062C ----------------------------------------------------------------- 1063C* 1.6 BULLETINS WITH 'TT' = 'SF'. 1064C --------------------------- 1065 160 CONTINUE 1066 RETURN 1067C ----------------------------------------------------------------- 1068C* 1.7 BULLETINS WITH 'TT' = 'SG'. 1069C ---------------------------- 1070 170 CONTINUE 1071 RETURN 1072C ----------------------------------------------------------------- 1073C* 1.8 BULLETINS WITH 'TT' = 'SH'. 1074C --------------------------- 1075 180 CONTINUE 1076 RETURN 1077C ----------------------------------------------------------------- 1078C* 1.9 BULLETINS WITH 'TT' = 'SI'. SYNOP INTERMED.HOURS. 1079C 1080 190 CONTINUE 1081 CALL BULLSI( IERR ) 1082 RETURN 1083C ----------------------------------------------------------------- 1084C* 2.0 BULLETINS WITH 'TT' = 'SJ'. 1085C --------------------------- 1086 200 CONTINUE 1087 RETURN 1088C ----------------------------------------------------------------- 1089C* 2.1 BULLETINS WITH 'TT' = 'SK'. 1090C --------------------------- 1091 210 CONTINUE 1092 RETURN 1093C ----------------------------------------------------------------- 1094C* 2.2 BULLETINS WITH 'TT' = 'SL'. 1095C --------------------------- 1096 220 CONTINUE 1097 RETURN 1098C ----------------------------------------------------------------- 1099C* 2.3 BULLETINS WITH 'TT' = 'SM'. SYNOP MAIN HOURS. 1100C --------------------------- 1101 230 CONTINUE 1102 CALL BULLSM( IERR ) 1103 RETURN 1104C ----------------------------------------------------------------- 1105C* 2.4 BULLETINS WITH 'TT' = 'SN'. NON-STANDARD HOUR. 1106C --------------------------- 1107 240 CONTINUE 1108 CALL BULLSN( IERR ) 1109 RETURN 1110C ----------------------------------------------------------------- 1111C* 2.5 BULLETINS WITH 'TT' = 'SO'. 1112C --------------------------- 1113 250 CONTINUE 1114 RETURN 1115C ----------------------------------------------------------------- 1116C* 2.6 BULLETINS WITH 'TT' = 'SP'. 1117C --------------------------- 1118 260 CONTINUE 1119 RETURN 1120C ----------------------------------------------------------------- 1121C* 2.7 BULLETINS WITH 'TT' = 'SQ'. 1122C --------------------------- 1123 270 CONTINUE 1124 RETURN 1125C ----------------------------------------------------------------- 1126C* 2.8 BULLETINS WITH 'TT' = 'SR'. 1127C --------------------------- 1128 280 CONTINUE 1129 RETURN 1130C ----------------------------------------------------------------- 1131C* 2.9 BULLETINS WITH 'TT' = 'SS'. 1132C --------------------------- 1133 290 CONTINUE 1134 RETURN 1135C ----------------------------------------------------------------- 1136C* 3.0 BULLETINS WITH 'TT' = 'ST'. 1137C --------------------------- 1138 300 CONTINUE 1139 RETURN 1140C ----------------------------------------------------------------- 1141C* 3.1 BULLETINS WITH 'TT' = 'SU'. 1142C 1143 310 CONTINUE 1144 RETURN 1145C ------------------------------------------------------------------ 1146C* 3.2 BULLETINS WITH 'TT' = 'SV'. 1147C 1148 320 CONTINUE 1149 RETURN 1150C ------------------------------------------------------------------ 1151C* 3.3 BULLETINS WITH 'TT' = 'SW'. 1152C 1153 330 CONTINUE 1154 RETURN 1155C ------------------------------------------------------------------ 1156C* 3.4 BULLETINS WITH 'TT' = 'SX'. 1157C 1158 340 CONTINUE 1159 RETURN 1160C ------------------------------------------------------------------ 1161C* 3.5 BULLETINS WITH 'TT' = 'SY'. 1162C 1163 350 CONTINUE 1164 RETURN 1165C ------------------------------------------------------------------ 1166C* 3.6 BULLETINS WITH 'TT' = 'SZ'. 1167C 1168 360 CONTINUE 1169 RETURN 1170C 1171 END 1172 SUBROUTINE BULLSM ( IERR ) 1173C 1174C 1175C**** *BULLSM* 1176C 1177C 1178C PURPOSE. 1179C -------- 1180C 1181C CONTROLLING ROUTINE FOR DECODING OF INDIVIDUAL 1182C REPORTS FROM BULLETINS OF SURFACE OBSERVATIONS. 1183C 1184C 1185C** INTERFACE. 1186C ---------- 1187C 1188C *CALL* *BULLSM(IERR)* 1189C 1190C INPUT : BULLETIN IN CCITT 5 CHARACTERS , 1 CHARACTER PER 1191C WORD IN 'KCHAR' . 1192C 1193C POINTERS TO BEGINNING AND END OF 'STARTING LINE' , 1194C 'ABBREVIATED HEADING','MIMIMJ LINE' AND END OF 1195C BULLETIN . 1196C 1197C IERR NOT USED. 1198C 1199C OUTPUT : DECODED REPORTS WRITTEN TO FILE AND ERROR 1200C REPORTS TO ERROR FILE. 1201C 1202C IERR = 1 , IF ANY FILE HANDLING ERROR . 1203C 1204C 1205C 1206C METHOD. 1207C ------- 1208C 1209C THIS ROUTINE HAS 3 ENTRY POINTS . SYNOP AND SHIP 1210C REPORTS FOR MAIN,INTERMEDIATE AND NON-STANDARD HOURS 1211C ARE DECODED BY THIS ROUTINE. 1212C 1213C THIS MAINTAINS SUBROUTINE NAMING CONVENTIONS. 1214C 1215C 1216C EXTERNALS. 1217C ---------- 1218C 1219C *CALL* *SMDEC(IHEAD,IERR)* 1220C *CALL* *SMINT(IHEAD,IERR)* 1221C 1222C REFERENCE. 1223C ---------- 1224C 1225C NONE. 1226C 1227C AUTHOR. 1228C ------- 1229C 1230C 1231C 1232C MODIFICATIONS. 1233C -------------- 1234C 1235C M. DRAGOSAVAC *ECMWF* AUG 1988. 1236C 1237C 1238C 1239 ENTRY BULLSI ( IERR ) 1240 ENTRY BULLSN ( IERR ) 1241C 1242 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 1243C 1244 INCLUDE 'parameter.h' 1245 INCLUDE 'comwork.h' 1246 INCLUDE 'comindx.h' 1247 INCLUDE 'comstat.h' 1248C ------------------------------------------------------------------ 1249C 1250C* 1. SET FLAGS AND WORKING POINTERS. 1251C ------------------------------- 1252 100 CONTINUE 1253C 1254C* SHIP REPORTS IN OLD CODE ARE NOT HANDLED BY THIS ROUTINE SO 1255C CHECK FOR MIMIMJMJ OF NNXX . 1256C 1257 IF ( KCHAR(IMI).EQ.78.AND.KCHAR(IMI+1).EQ.78) RETURN 1258C 1259C-----PRINT INPUT BULLETINS OF SURFACE REPORTS 1260C CALL PRTBULL (1,IGS) 1261C-----PRINT INPUT BULLETINS OF SURFACE REPORTS 1262C 1263C WORKING POINTER SET TO POINT TO FIRST LETTER OF MIMIMJMJ 1264C GROUP. 1265C 1266 IPT = IMI 1267C 1268C CLEAR FLAG WHICH INDICATES YYGGIW GROUP PRESENT. 1269C 1270 ISYYGG = 0 1271C 1272C CLEAR FLAG WHICH INDICATES BULLETIN HEADER ALREADY WRITTEN 1273C TO ERROR FILE. 1274C 1275 IHEAD = 0 1276C 1277C* HANDLE MIMIMJMJ LINE . SET DATA BASE REPORT TYPE INDICATORS 1278C IN DECODED REPORT HEADER AND LOCATE START OF FIRST REPORT . 1279C 1280C DATA BASE INDICATOR FOR LAND REPORTS IS 11 AND FOR SEA REPORTS 1281C 21 . THESE ARE MODIFIED LATER IF REDUCED SHIP , BUOY OR 1282C AUTOMATIC REPORT ENCOUNTERED. 1283C 1284C 1285C DISTINGUISH BETWEEN LAND ( TT = AA ) AND SEA ( TT = BB ) STATIONS. 1286C 'A' = 65 , 'B' = 66 . 1287C 1288C 1289C MIMIMJMJ OF A--- OR -A-- ACCEPTED AS LAND STATION BULLETIN. 1290C THE LINE LENGTH IS CHECKED IN CASE OF MISSING MIMIMJ LINE IN 1291C A BULLETIN OF SHIP REPORTS AND SHIP'S NAME INCLUDES -A OR A- . 1292C 1293 L = JMI - IMI 1294 IF ( KCHAR(IMI).EQ.65.OR.KCHAR(IMI+1).EQ.65.AND.L.LT.15 ) 1295 C THEN 1296C 1297C SET DATA BASE CODE TYPE INDICATOR AND YYGGIW FLAG. 1298C 1299 KDEC(4) = 11 1300 ISYYGG = 1 1301C 1302C LOCATE YYGGIW GROUP - NEXT FIGURE. 1303C 1304 CALL NEXTFIG ( IPT,JMI ) 1305C 1306 elseif(KCHAR(IMI).EQ.79.OR.KCHAR(IMI+1).EQ.79) then 1307c do not process mobile synop land in this stream 1308 RETURN 1309 ELSE 1310C 1311C IF MIMIMJ IS B--- OR -B-- BULLETIN IS OF SEA REPORTS 1312C 1313 IF ( KCHAR(IMI).EQ.66.OR.KCHAR(IMI+1).EQ.66 ) 1314 C THEN 1315C 1316C do not process synop ship in this stream 1317 1318 RETURN 1319 1320C SET DATA BASE CODE FIGURE FOR REPORT TYPE 1321C 1322C KDEC(4) = 21 1323C 1324C LOCATE D---D GROUP . THIS SHOULD BE THE NEXT 1325C CHARACTER AND ON A NEW LINE , BUT THERE ARE SOME 1326C COMMON VARIATIONS . 1327C 1328C (1) A YYGGIW OR YYGG GROUP IS ADDED AFTER BBXX , 1329C ON THE SAME LINE . 1330C (2) THE REPORT CONTINUES ON THE SAME LINE AS BBXX. 1331C 1332C SET K1 TO POINT TO THE NEXT 'SPACE' CHARACTER (32) 1333C 1334C K1 = IPT 1335C CALL NEXTVAL ( K1,32,IGS ) 1336C 1337C SET K2 TO POINT TO THE NEXT 'CR' CHARACTER. 1338C 1339C K2 = IPT 1340C CALL NEXTEND ( K2,IGS ) 1341C 1342C IF A 'CR' CHARACTER IS ENCOUNTERED BEFORE 'SPACE' 1343C D---D IS ON THE NEXT LINE. 1344C 1345C IF ( K2.LT.K1 ) 1346C C THEN 1347C IPT = K2 1348C ELSE 1349C 1350C IF THE REST OF BBXX LINE CONSISTS OF ONLY 1351C 5 FIGURES IT IS CONSIDERED TO BE YYGGIW, 1352C AND D---D IS SOUGHT ON THE NEXT LINE. 1353C 1354C K = K2 - K1 1355C IF ( K.GT.6 ) THEN 1356C IPT = K1 1357C ELSE 1358C IPT = K2 1359C END IF 1360C END IF 1361C 1362C IPT NOW POINTS TO THE CHARACTER BEFORE D---D GROUP. 1363C 1364C CALL NEXTPRT ( IPT,IGS ) 1365C 1366 ELSE 1367C 1368C BULLETIN CANNOT BE IDENTIFIED FROM MIMIMJMJ , SO 1369C INSPECT AA OF ABBREVIATED HEADING. 1370C 1371C---- PRINT BULLETINS WITH ERROR IN MIMIMJMJ 1372C---- 1373C---- CALL PRTBULL (1,IGS) 1374C---- 1375C---- PRINT BULLETINS WITH ERROR IN MIMIMJMJ 1376C 1377C 1378C IF A1 IS V OR W AND A2 IS A,B,C,D,E,F,J OR X 1379C THEN BULLETIN IS OF SEA REPORTS. 1380C 1381 IF ( (KCHAR(IAH+2).EQ.86.OR.KCHAR(IAH+2).EQ.87). 1382 C AND.(KCHAR(IAH+3).EQ.65.OR.KCHAR(IAH+3). 1383 C EQ.66.OR.KCHAR(IAH+3).EQ.67.OR.KCHAR(IAH+3). 1384 C EQ.68.OR.KCHAR(IAH+3).EQ.69.OR.KCHAR(IAH+3). 1385 C EQ.70.OR.KCHAR(IAH+3).EQ.74.OR.KCHAR(IAH+3). 1386 C EQ.88) ) 1387 C THEN 1388C 1389C SEA STATION 1390C 1391C SET DATA BASE CODE FIGURE 1392C 1393 KDEC(4) = 21 1394C 1395C CHECK MIMIMJ LINE LENGTH TO DECIDE 1396C WHETHER LINE IS MISSING OR MIMIMJMJ 1397C IS CORRUPT. 1398C 1399 IF ( (JMI-IMI).LT.11 ) 1400 1401 C THEN 1402C 1403C CORRUPT MIMIMJ 1404C 1405 CALL NEXTEND ( IPT,IGS ) 1406 CALL NEXTPRT ( IPT,IGS ) 1407 ELSE 1408C 1409C MISSING MIMIMJMJ LINE 1410C 1411 IPT = IMI 1412 END IF 1413C 1414 ELSE 1415C 1416C LAND STATION BULLETIN 1417C 1418C SET DATA BASE CODE FIGURE 1419C 1420 KDEC(4) = 11 1421C 1422C CHECK MIMIMJMJ LINE LENGTH TO DECIDE 1423C WHETHER GROUP IS CORRUPT OR LINE IS 1424C MISSING. 1425C 1426 IF ( (JMI-IMI).LT.11 ) 1427 C THEN 1428C 1429C CORRUPT MIMIMJMJ 1430C 1431 CALL NEXTEND (IPT,IGS) 1432 IPT =IPT - 5 1433C 1434C SET YYGGIW FLAG 1435C 1436 ISYYGG = 1 1437 ELSE 1438C 1439C MISSING LINE 1440C 1441 IPT = IMI 1442C 1443C SET WORDS FOR YY GG IW 1444C TO MISSING DATA VALUE. 1445C 1446 KINT(1) = MINDIC 1447 KINT(2) = MINDIC 1448 KINT(3) = MINDIC 1449C 1450 END IF 1451 END IF 1452 END IF 1453 END IF 1454C 1455C 1456C 1457C 1458C 1459C 1460C 1461C IF LAND STATION REPORT EXTRACT 'YYGGIW' FROM 'MIMIMJMJ' LINE. 1462C 1463C 1464 101 IF ( KDEC(4).EQ.11.AND.ISYYGG.EQ.1 ) 1465 C THEN 1466 CALL NEXTPRT ( IPT,IGS ) 1467 CALL EXTGRP ( IPT,2,2,1,0,0,1,IRET) 1468 CALL NEXTPRT ( IPT,IGS ) 1469 ISYYGG = 0 1470C 1471C CHECK VALUES OF YY,GG AND IW . IF ANY ERROR IS 1472C FOUND DECODED VALUE IS CHANGED TO MISSING DATA VALUE 1473C AND GROUP FLAGGED AS BEING IN ERROR . ERRORS IN THIS 1474C GROUP ARE NOT FATAL AS YYGG FROM HEADING AND IW FROM 1475C WMO STATIONS MASTER FILE ARE SUBSTITUTED LATER , IF 1476C NECESSARY. 1477C 1478 I = 0 1479 IF (KINT(1).LT.1.OR.KINT(1).GT.31) 1480 C THEN 1481 I = 1 1482 KINT(1) = MINDIC 1483 END IF 1484C 1485 IF ( KINT(2).LT.0.OR.KINT(2).GT.23) 1486 C THEN 1487 I = 1 1488 KINT(2) = MINDIC 1489 END IF 1490C 1491 IF ( KINT(3).EQ.2.OR.KINT(3).LT.0.OR.KINT(3).GT.4) 1492 C THEN 1493 I = 1 1494 KINT(3) = MINDIC 1495 END IF 1496C 1497 IF ( I.NE.0 ) 1498 C THEN 1499 KCHAR(IPT-1) = IOR(KCHAR(IPT-1),128) 1500 NOER(1,3)=NOER(1,3)+1 1501 END IF 1502 END IF 1503C 1504C 1505C*** 1506C* LOCATE END OF REPORT ( = ) AND INCREMENT COUNTER. 1507C*** 1508C 1509 IEQ = IPT 1510 CALL NEXTEQ ( IEQ,IGS ) 1511C 1512C 1513 NUMREP(1) = NUMREP(1) + 1 1514C 1515C 1516C 1517C*** 1518C* DECODE REPORT . 1519C*** 1520C 1521C CONVERT REPORT TO INTERMEDIATE FORMAT. 1522C 1523 CALL SMINT( IHEAD,IERR ) 1524C 1525C 1526C "NIL" REPORTS (KERR=1) WILL NOT BE DECODED FOR 1527C DATA MONITORING PURPOSES 1528C 1529C IF(KERR .NE. 0) GO TO 200 1530C 1531C 1532C CONVERT INTERMEDIATE TO DECODED FORMAT AND WRITE 1533C TO FILE. 1534C 1535 CALL SMDEC ( IHEAD,IERR ) 1536C 1537 IF ( KERR.NE.0 ) GO TO 200 1538C 1539C 1540C 1541C 1542C*** 1543C* LOCATE START OF NEXT REPORT. 1544C*** 1545C 1546200 IPT = IEQ + 1 1547 CALL NEXTPRT ( IPT,IGS ) 1548C 1549C*** 1550C* CHECK FOR END OF BULLETIN. 1551C*** 1552C 1553 IF ( IPT.GT.IGS ) THEN 1554C 1555C END OF BULLETIN , SO IF ANY REPORT HAS 1556C BEEN WRITTEN TO ERROR FILE , ADD 'GS' 1557C CHARACTER BEFORE RETURNING. 1558C 1559 IF (IHEAD.EQ.0) THEN 1560C Create BUFR 1561 olast=.true. 1562 CALL SYNEXP1(olast,IERR) 1563 RETURN 1564 else 1565C Create BUFR 1566 olast=.true. 1567 CALL SYNEXP1(olast,IERR) 1568 RETURN 1569 END IF 1570 IHEAD = 2 1571 CALL SAVREP ( IHEAD,IERR ) 1572C 1573C----- PRINT SURFACE DATA WRITTEN TO ERROR FILE 1574C----- 1575C----- CALL PRTBULL (1,IGS) 1576C----- 1577C----- PRINT SURFACE DATA WRITTEN TO ERROR FILE 1578C 1579 RETURN 1580 END IF 1581C 1582C 1583C*** 1584C* RESET LAND OR SEA STATION RDB CODE FIGURE. 1585C*** 1586C 1587 IF ( KDEC(4).GT.14 ) THEN 1588 KDEC(4) = 21 1589 ELSE 1590 KDEC(4) = 11 1591 END IF 1592C 1593C*** 1594C* IF LAND STATION REPORT IT IS POSSIBLE TO GET NEW 'MIMIMJMJ' 1595C* AND 'YYGGIW' GROUPS , SO CHECK . 1596C*** 1597C 1598 IF ( KDEC(4).EQ.11.AND.KCHAR(IPT).EQ.65 ) 1599 C THEN 1600C 1601C SET YYGGIW FLAG AND LOCATE START OF NEW 1602C YYGGIW GROUP. 1603C 1604 ISYYGG = 1 1605 CALL NEXTFIG ( IPT,IGS ) 1606 IF ( IPT.GE.IGS ) RETURN 1607 END IF 1608 GO TO 101 1609C 1610C 1611 END 1612 SUBROUTINE SMDEC ( IHEAD,IERR ) 1613C 1614C 1615C**** *SMDEC* 1616C 1617C 1618C PURPOSE. 1619C -------- 1620C 1621C DECODE SURFACE REPORT FROM INTERMEDIATE FORMAT 1622C TO DECODED SURFACE REPORT 1623C 1624C 1625C** INTERFACE. 1626C ---------- 1627C 1628C *CALL* *SMDEC(IHEAD,IERR)* 1629C 1630C INPUT : REPORT IN INTERMEDIATE FORMAT IN KINT 1631C 1632C OUTPUT : DECODED REPORT ON KDEC 1633C 1634C 1635C METHOD. 1636C ------- 1637C 1638C NONE. 1639C 1640C 1641C EXTERNALS. 1642C ---------- 1643C 1644C *CALL* *IC3333 ( )* FOR LATTITUDE AND LONGITUDE 1645C *CALL* *IT5TODC( )* CONVERSION FROM CITT5 TO DISPLAY CODE 1646C *CALL* *IC0877 ( )* WIND DIRECTION AND SPEED 1647C *CALL* *IC4377 ( )* HORIZONTAL VOISIBILITY 1648C *CALL* *IC3845 ( )* TEMPERATURE 1649C *CALL* *IC0264 ( )* INDICATOR OF ISOBARIC SURFACE (A3) 1650C *CALL* *IC3590 ( )* PRECIPITATION 1651C *CALL* *ICTRTR ( )* PERIOD FOR PRECIPITATION MEASUREMENT 1652C *CALL* *IC1677 ( )* HEIGHT OF BASE OF CLOUD (HH) 1653C *CALL* *IC0700 ( )* SHIP'S DIRECTION 1654C *CALL* *IC4451 ( )* SHIP'S SPEED 1655C *CALL* *ICPWPW ( )* PERIOD OF WAVES 1656C *CALL* *ICHWHW ( )* HEIGHT OF WAVES 1657C 1658C 1659C REFERENCE. 1660C ---------- 1661C 1662C NONE. 1663C 1664C AUTHOR. 1665C ------- 1666C *CALL* ( )* 1667C 1668C 1669C MODIFICATIONS. 1670C -------------- 1671C 1672C M. DRAGOSAVAC *ECMWF* AUG 1988. 1673C 1674C 1675 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 1676C 1677 INCLUDE 'parameter.h' 1678 INCLUDE 'comwork.h' 1679 INCLUDE 'comindx.h' 1680C 1681C ------------------------------------------------------------------ 1682C 1. IN THIS SUBROUTINE THE ONLY PARTS OF THE HEADER 1683C DECODED ARE IDENTIFIER , THE LENGTH OF REPORT , 1684C DAY OF THE MONTH AND TIME (HOUR & MIN) FROM REPORT 1685C AND IN CASE OF SHIP OR BUOY 1686C LAT, LONG, ALT=0 1687C 1688 100 CONTINUE 1689C 1690C 1691C CLEAR ERROR INDICATOR. 1692C 1693 IF(KERR.GT.1) RETURN 1694C 1695 KERR = 0 1696 IERR = 0 1697C 1698C* SET DECODED REPORT TO MISSING DATA VALUE 1699C 1700 DO 1 I=25,200 1701 KDEC(I)=MINDIC 1702 1 CONTINUE 1703C 1704C 1705C 1706C* CHECK IF SHIP OR BUOY 1707C 1708 IF(KDEC(4) .LT. 21 ) GO TO 101 1709C 1710C 1711C 1712C* LAT & LONG 1713C 1714C 1715 CALL IC3333(KINT(7),KINT(6),KINT(8),MINDIC,KDEC(5),KDEC(6)) 1716C 1717C 1718C 1719C 1720C* ALTIT FOR SEA STATION=0 1721C 1722C 1723 KDEC(8)=0 1724C 1725C 1726C 1727C 1728101 CONTINUE 1729C 1730C* IDENT STATION OR BUOY IDENTIFICATION NUMBER 1731C OR SHIP CALL SIGN 1732C KINT(12) - KINT(16) CONTAIN ID. 1733C 1734 KDEC(7)=88 1735C 1736C 1737C* DAY AND TIME 1738C 1739C CHECK IF DAY AND HOUR ARE MISSING. IN THAT CASE USE 1740C DATE FROM ABBREVIATED HEADER. 1741C 1742 KDEC(1)=KINT(1) 1743 KDEC(2)=KINT(2) 1744C 1745 IF(KINT(1).EQ.MINDIC) THEN 1746 KDEC(1)=KDEC(10) 1747 IF(KDEC(10).EQ.MINDIC) RETURN 1748 END IF 1749C 1750 IF(KINT(2).EQ.MINDIC) THEN 1751 KDEC(2)=KDEC(11) 1752 IF(KDEC(11).EQ.MINDIC) RETURN 1753 END IF 1754C 1755 KDEC(9)=0 1756C 1757C 1758C* REPORT LENGTH 1759C 1760C 1761 KDEC(24)=120 1762C 1763C 1764 IF(KDEC(20).EQ.1) THEN 1765C NILL report 1766 GO TO 950 1767 END IF 1768 1769C 1770C 1771C* SECTION 1 1772C 1773C 1774C* DD & FF WIND DIRECTION AND SPEED 1775C 1776C 1777 K=MINDIC 1778 IF(KDEC(4) .GE. 21) GO TO 120 1779 K=KDEC(17)*1000 + KDEC(16) 1780120 CONTINUE 1781C 1782 if(kint(255).eq.0.and.kint(256).ne.mindic) then 1783 CALL IC0877(KINT(19),KINT(256),KINT(3),K,MINDIC,KDEC(25), 1784 1 KDEC(26)) 1785 else 1786 CALL IC0877(KINT(19),KINT(20),KINT(3),K,MINDIC,KDEC(25), 1787 1 KDEC(26)) 1788 end if 1789C 1790C 1791C* VV HORIZONTAL VISIBILITY 1792C 1793C 1794 CALL IC4377(KINT(17),MINDIC,KDEC(27)) 1795C 1796C 1797C 1798C 1799C* WW, W1, W2 PRESENT AND PAST WEATHER 1800C 1801C 1802 IF(KINT(38) .EQ. MINDIC .AND. (KINT(15) .EQ. 2 .OR. 1803 * KINT(15) .EQ. 5)) 1804 * THEN 1805 KDEC(28)=2 1806 KDEC(29)=1 1807 KDEC(30)=1 1808 GO TO 210 1809 END IF 1810C 1811C 1812 DO 200 I=39,41 1813 IF(KINT(I) .EQ. MINDIC) GO TO 200 1814 KDEC(I-11)=KINT(I) 1815200 CONTINUE 1816C 1817210 CONTINUE 1818C 1819C 1820C* TTT AIR TEMPERATURE IN TENTHS OF DEGREE CELSIUS 1821C 1822C 1823C 1824 CALL IC3845(KINT(23),KINT(22),KDEC(16),KDEC(17),MINDIC,KDEC(31)) 1825C 1826C 1827C 1828C* TDTDTD DEW POINT TEMPERATURE IN TENTHS OF DEGREE 1829C 1830C 1831C 1832 IF(KINT(26) .EQ. MINDIC) GO TO 320 1833 CALL IC3845(KINT(26),KINT(25),KDEC(16),KDEC(17),MINDIC,KDEC(32)) 1834C 1835C 1836C 1837C*** UUU RELATIVE HUMIDITY 1838C 1839C 1840C IF (KINT(25) .EQ. 9) THEN DEW POINT TEMP IS NOT AVAILABLE 1841C AND RELATIVE HUMIDITY IS MEASURED INSTEAD 1842C 1843 IF(KINT(25) .EQ. 9) KDEC(33)=KINT(26) 1844C 1845C CHECK RANGE 1846C 1847 IF ( KDEC(33).GT.100 ) KDEC(33) = MINDIC 1848C 1849320 CONTINUE 1850C 1851C 1852C 1853C* P0P0P0 PRESSURE AT STATION LEVEL IN TENTHS OF HECTOPASCAL 1854C 1855C 1856 IF(KINT(28) .EQ. MINDIC) GO TO 340 1857 KDEC(34)=KINT(28) 1858 KK = KINT(28) / 1000 1859 IF ( KK.EQ.0 ) KDEC(34) = KDEC(34) + 10000 1860340 CONTINUE 1861C 1862C 1863C CHECK IF THERE IS SEA LEVEL PRESSURE OR GEOPOTENTIAL IN THIS 1864C THIS REPORT (IF A3 (=KINT(30)) .NE. 0 AND .NE. 9, THEN GEOPOT 1865C 1866C 1867 IF(KINT(30).EQ.MINDIC.OR.KINT(31).EQ.MINDIC ) GO TO 370 1868 IF(KINT(30) .NE. 0 .AND. KINT(30) .NE. 9) GO TO 350 1869C 1870C 1871C 1872C* PRESSURE AT SEA LEVEL IN TENTHS OF HECTOPASCAL 1873C 1874C 1875 KDEC(35)=KINT(31) + 1000*KINT(30) 1876 IF(KINT(30) .EQ. 0) KDEC(35)=KINT(31) + 10000 1877 GO TO 370 1878C 1879C 1880C 1881350 CONTINUE 1882C 1883C 1884C*** A3 INDICATOR OF STANDARD ISOBARIC SURFACE (CODE 264) 1885C 1886C 1887C 1888 CALL IC0264(KINT(30),MINDIC,KDEC(36)) 1889C 1890C 1891C* HHH GEOPOTENTIAL AT AN AGREED ISOBARIC SURF, GIVEN BY A3 1892C 1893C 1894 KDEC(37)=KINT(31) 1895C 1896C ADD 1000 IF 850 HPA LEVEL 1897C 1898 IF (KINT(30).EQ.8) KDEC(37)=KDEC(37) + 1000 1899C 1900C ADD 2000 OR 3000 IF 700 HPA LEVEL 1901C 1902 IF (KINT(30).EQ.7) THEN 1903 IF (KINT(31).LT.500)KDEC(37)=KDEC(37)+3000 1904 IF (KINT(31).GE.500)KDEC(37)=KDEC(37)+2000 1905 END IF 1906C 1907C ADD 5000 IF 500 HPA LEVEL 1908C 1909 IF (KINT(30).EQ.5) KDEC(37) = KDEC(37) + 5000 1910C 1911C 1912C 1913370 CONTINUE 1914C 1915C* A CHARACTERISTIC OF PRESSURE TENDENCY DURING 3 HOURS 1916C 1917C 1918 IF(KINT(33) .NE. MINDIC .AND. KINT(33).NE.9) THEN 1919 KDEC(38)=KINT(33) 1920 ELSE 1921 KDEC(38)=MINDIC 1922 END IF 1923C 1924C 1925C 1926C* PPP AMOUNT OF PRESSURE TENDENCY IN TENTHS OF HECTOPASCAL 1927C 1928C 1929 IF ( KINT(34).NE.MINDIC.AND.KINT(33).NE.9 ) 1930 C THEN 1931 KDEC(39)=KINT(34) 1932C 1933C VALUE IS NEGATIVE IF CHARACTERISTIC ( A ) IS 5 - 8. 1934C 1935 IF (KDEC(38).GE.5.AND.KDEC(38).LE.8) KDEC(39) = -KDEC(39) 1936C 1937 END IF 1938C 1939C 1940C* TEST IF PRESSURE TENDENCY IS FOR 24 HOUR PERIOD 1941C INDICATED BY KINT(104) 1942C 1943c IF(KINT(104) .EQ. 8 .OR. KINT(104) .EQ. 9) 1944c 1 THEN 1945c KDEC(38)=9 1946c KDEC(39)=KINT(105) 1947c END IF 1948C 1949c IF(KINT(104) .EQ. 9 .AND. KINT(105) .NE. MINDIC) 1950c 1 KDEC(39)=-KDEC(39) 1951C 1952C 1953C 1954C*** RRR AMOUNT OF PRECIPITATION TENTHS OF MILLIMETRES 1955C 1956C 1957 CALL IC3590(KINT(36),KINT(14),MINDIC,KDEC(40)) 1958C 1959C DURATION NOT DECODED IF RAINFALL VALUE IS MISSING. 1960C 1961 IF (KDEC(40).EQ.MINDIC) GO TO 415 1962C 1963C 1964C 1965C 1966C*** TR DURATION OF PERIOD OF REFERENCE FOR PRECIP.(HOURS) 1967C 1968 IHOURS=KDEC(2) 1969 IF(IHOURS .EQ. MINDIC) IHOURS=KDEC(11) 1970 IF(IHOURS .LT. 0 .OR. IHOURS .GT. 24) IHOURS=MINDIC 1971 IF(IHOURS .EQ. MINDIC) GO TO 415 1972C 1973 CALL ICTRTR (KDEC(16),KDEC(17),KINT(37),IHOURS,MINDIC,KDEC(41)) 1974C 1975C 1976415 CONTINUE 1977C 1978C 1979C*** N TOTAL CLOUD COVER 1980C 1981C 1982 IF(KINT(18) .EQ. MINDIC) THEN 1983 KDEC(42)=MINDIC 1984 ELSE 1985 KDEC(42)=KINT(18) 1986 END IF 1987C 1988C 1989C 1990C*** H HEIGHT OF THE BASE OF LOWEST CLOUD 1991C 1992C 1993 IF(KINT(16) .EQ. MINDIC) THEN 1994 IF (KDEC(4).NE.23) 1995 C KDEC(43)=16382 1996 GO TO 430 1997 END IF 1998C 1999 IF(KINT(18) .EQ. 0) THEN 2000 KDEC(43)=16381 2001 GO TO 430 2002 END IF 2003C 2004 LOWEST=MINDIC 2005C 2006C loop for different cloud types 2007C 2008 DO 425 I=46,44,-1 2009 IF(KINT(I) .EQ. MINDIC) GO TO 425 2010 IF (KINT(I).EQ.0) GO TO 425 2011 LOWEST=I-44 2012425 CONTINUE 2013C 2014C 2015C 2016 CALL IC1600(KINT(16),LOWEST,MINDIC,KDEC(43)) 2017C 2018430 CONTINUE 2019C 2020C 2021C 2022C*** NH TOTAL LOW CLOUDS 2023C 2024C 2025 IF(KINT(42) .EQ. MINDIC) GO TO 451 2026 KDEC(44)=KINT(43) 2027C 2028C 2029C 2030C*** CL, CM, CH TYPE LOW MEDIUM AND HIGH CLOUDS 2031C 2032C 2033 DO 450 I=45,47 2034 KDEC(I)=KINT(I-1) 2035 IF(KINT(I-1) .EQ. MINDIC) KDEC(I)=14 2036450 CONTINUE 2037C 2038451 CONTINUE 2039C 2040C*** HH HEIGHT OF THE BASE OF THE LOWEST CLOUD 2041C 2042C IF(KINT(48) .EQ. MINDIC) GO TO 455 2043C 2044C CALL IC1677(KINT(48),MINDIC,KDEC(43)) 2045C 2046455 CONTINUE 2047C 2048C 2049C*** 2050C* 2051C* SECTION 2 2052C* 2053C* CHECK IF THERE IS SECTION 2 IN THIS REPORT 2054C*** 2055C 2056 IF(KINT(50) .EQ. MINDIC) GO TO 690 2057C 2058C 2059C*** DS DIRECTION OF THE SHIP 2060C 2061C 2062 CALL IC0700(KINT(51),MINDIC,KDEC(49)) 2063C 2064C 2065C 2066C*** VS SHIP"S SPEED 2067C 2068C 2069 CALL IC4451(KINT(52),MINDIC,KDEC(50)) 2070C 2071C 2072C 2073C*** TWTWTW SEA-SURFACE TEMPERATURE 2074C 2075C 2076 IF(KINT(53) .EQ. MINDIC) GO TO 510 2077 IF(KINT(54) .EQ. 0) KDEC(51)=KINT(55) 2078 IF(KINT(54) .EQ. 1) KDEC(51)=-1*KINT(55) 2079510 CONTINUE 2080C 2081C 2082C 2083C*** PWAPWA PERIOD OF WAVES IN SECONDS 2084C 2085C 2086 CALL ICPWPW(KINT(57),MINDIC,KDEC(52)) 2087C 2088C 2089C 2090C*** HWAHWA HEIGHT OF WAVES IN DECIMETERS 2091C 2092C 2093 CALL ICHWHW(KINT(58),MINDIC,KDEC(53)) 2094C 2095C CHECK IF HIGHT WITH .1 M REPORTED. 2096C 2097 IF(KINT(250).EQ.70) THEN 2098 IF(KINT(251).NE.MINDIC) KDEC(53)=KINT(251) 2099 END IF 2100C 2101C 2102C 2103C*** PWPW PERIOD OF WIND WAVES IN SECONDS 2104C 2105C 2106 CALL ICPWPW(KINT(60),MINDIC,KDEC(54)) 2107C 2108C 2109C 2110C 2111C*** HWHW HEIGHT OF WIND WAVES IN DECIMETERS 2112C 2113C 2114 CALL ICHWHW(KINT(61),MINDIC,KDEC(55)) 2115C 2116C 2117C 2118C*** DW1DW1 & DW2DW2 DIRECTION FROM WHICH WAVES ARE COMING 2119C 2120C 2121 DO 560 I=56,57 2122 IF(KINT(I+7) .EQ. MINDIC) GO TO 560 2123 KDEC(I)=KINT(I+7)*10 2124 IF(KINT(I+7) .EQ. 99) KDEC(I)=0 2125560 CONTINUE 2126C 2127C 2128C 2129C*** PW1PW1, HW1HW1 PERIOD AND HEIGHT OF 2130C*** PW2PW2, HW2HW2 SWELL WAVES 2131C 2132C 2133 CALL ICPWPW(KINT(66),MINDIC,KDEC(58)) 2134 CALL ICHWHW(KINT(67),MINDIC,KDEC(59)) 2135C 2136 CALL ICPWPW(KINT(69),MINDIC,KDEC(60)) 2137 CALL ICHWHW(KINT(70),MINDIC,KDEC(61)) 2138C 2139C 2140C 2141C 2142C*** IS TYPE OF ICE 2143C*** ESES ICE THICKNESS IN DECIMETERS 2144C*** RS RATE OF ICING 2145C 2146C 2147 DO 620 I=72,74 2148 IF(KINT(I) .EQ. MINDIC) GO TO 620 2149 KDEC(I-10)=KINT(I) 2150620 CONTINUE 2151C 2152 IF(KDEC(63) .NE. MINDIC) KDEC(63)= (KDEC(63) + 5) / 10 2153C 2154C 2155C*** CI CONCENTRATION OR ARRANGEMENT OF SEA ICE 2156C*** SI STAGE OF DEVELOPMENT 2157C*** BI LAND ICE 2158C*** DI BEARING OF ICE 2159C*** ZI TREND 2160C 2161C 2162 DO 650 I=76,80 2163 IF(KINT(I) .EQ. MINDIC) GO TO 650 2164 KDEC(I-11)=KINT(I) 2165650 CONTINUE 2166C 2167 IF(KDEC(68) .EQ. 99) KDEC(68)=0 2168C 2169C*** Wet bulb temperature (from 2.11.1993) 2170C 2171 if(kint(252).ne.mindic.and.kint(253).ne.mindic.and. 2172 1 kint(254).ne.mindic) then 2173 iwtsign=1 2174 if(kint(253).eq.0) iwtsign=1 2175 if(kint(253).eq.1) iwtsign=-1 2176 if(kint(253).eq.2) iwtsign=-1 2177 if(kint(253).eq.5) iwtsign=1 2178 if(kint(253).eq.6) iwtsign=-1 2179 if(kint(253).eq.7) iwtsign=-1 2180 kdec(120)=iwtsign*kint(254) 2181 end if 2182c 2183690 CONTINUE 2184C 2185C*** 2186C* 2187C* SECTION 3 2188C* 2189C* THIS IS THE REGIONAL PART AND THERE ARE DIFFERENCIES 2190C* IN DIFFERENT REGIONS. REGION NUMBER IS KDEC(17). 2191C*** 2192C 2193C*** 2194C* TEST IF THERE ARE ANY REGIONAL DATA 2195C*** 2196C 2197 IF(KDEC(17) .EQ. MINDIC) GO TO 950 2198 IF(KINT(81) .EQ. MINDIC) GO TO 950 2199C 2200C 2201C*** TGTG GROUND MIN TEMPERATURE IN TENTHS OF DEGREE 2202C ONLY REGION I 2203C 2204C 2205C 2206C THE FIRST GROUP IS 0TGTGRCRT AT 0600Z OR 0//RCRT 2207C AT 0000 OR 1200. ONLY TGTG IS DECODED. TIME IS KDEC(11). 2208C 2209 IF(KDEC(11) .NE. 6) GO TO 700 2210 IF(KINT(83) .EQ. MINDIC) GO TO 700 2211 IF(KDEC(17) .NE. 1) GO TO 700 2212C 2213 KDEC(70)=KINT(83)*10 2214 IF(KDEC(70) .GT. 500) KDEC(70)=500-KDEC(70) 2215C 2216700 CONTINUE 2217C Ground minimum Temperature 2218 IF(KDEC(17) .NE. 1) THEN 2219 IF(KINT(96).NE.MINDIC) then 2220 KDEC(70)=KINT(96) 2221 IF(KINT(95).EQ.1) KDEC(70)=-KDEC(70) 2222 END IF 2223 END IF 2224C 2225C 2226C*** TXTXTX MAX AIR TEMPERATURE IN TENTHS OF DEGREE 2227C THE PERIOD FOR MAX IS DIFFERENT FOR 2228C DIFFERENT REGIONS 2229C 2230C 2231C FOR REGION IV AT 1200Z THE MAX TEMP IS DEFINED FOR THE PERIOD 2232C OF CALENDAR DAY, AND IT WILL NOT BE DECODED. 2233C FOR REGION III DAYTIME TEMPERATURE IS USED, AND IT WILL 2234C NOT BE DECODED EITHER. 2235C 2236 IF(KDEC(17) .EQ. 4 .AND. KDEC(11) .EQ. 12) GO TO 720 2237 IF(KDEC(17) .EQ. 3) GO TO 720 2238C 2239C 2240 IF(KINT(87) .EQ. MINDIC) GO TO 720 2241 CALL IC3845(KINT(89),KINT(88),KDEC(16),KDEC(17),MINDIC,KDEC(71)) 2242C 2243C 2244C*** TX-PERIOD LENGTH OF THE PERIOD FOR MAX TEMPERATURE (HOURS) 2245C IT VARIES FROM REGION TO REGION 2246C REGION I 12 HOURS (AT 1800) 2247C REGION II 12 HOURS (AT 1800) 2248C REGION III DAYTIME TEMPERATURE (MINDIC) 2249C REGION IV 12 HOURS (AT 0000 & 1800) 2250C 24 HOURS (AT 0600) 2251C CALENDAR DAY (AT 1200) (MINDIC) 2252C REGION V 24 HOURS (AT 1200) 2253C REGION VI 12 HOURS (AT 1800) 2254C 2255 IF(KDEC(17) .EQ. 1 .OR. KDEC(17) .EQ. 2 .OR. KDEC(17) .EQ. 6) 2256 1 THEN 2257 KDEC(72)=12 2258 GO TO 720 2259 END IF 2260C 2261C 2262 IF(KDEC(17) .EQ. 4) 2263 1 THEN 2264 IF(IHOURS .EQ. 12) GO TO 720 2265 IF(IHOURS .EQ. 0 .OR. IHOURS .EQ. 18) 2266 1 THEN 2267 KDEC(72)=12 2268 GO TO 720 2269 END IF 2270 IF(IHOURS .EQ. 6) 2271 1 THEN 2272 KDEC(72)=24 2273 GO TO 720 2274 END IF 2275 END IF 2276C 2277 IF(KDEC(17) .EQ. 5) KDEC(72)=24 2278C 2279720 CONTINUE 2280C 2281C 2282C*** TNTNTN MIN AIR TEMPERATURE IN TENTHS OF DEGREE, 2283C THE PERIOD FOR MIN VARIES FROM REGION TO REGION 2284C 2285C FOR REGION III MIN TEMP IS DEFINED AT NIGHT TIME, 2286C AND IT WILL NOT BE DECODED 2287C 2288 IF(KDEC(17) .EQ. 3) GO TO 740 2289C 2290C 2291 IF(KINT(90) .EQ. MINDIC) GO TO 740 2292 CALL IC3845(KINT(92),KINT(91),KDEC(16),KDEC(17),MINDIC,KDEC(73)) 2293C 2294C 2295C 2296C*** TN-PERIOD LENGHT OF THE PERIOD FOR MIN TEMPERATURE 2297C REGION I 12 HOURS (AT 0600) 2298C II 12 HOURS (AT 0600) 2299C III NIGHT TIME (MINDIC) 2300C IV 18 HOURS (AT 0000) 2301C V 24 HOURS (AT 0000) 2302C VI 12 HOURS (AT 0600) 2303C 2304 IF(KDEC(17) .EQ. 1 .OR. KDEC(17) .EQ. 2 .OR. 2305 1 KDEC(17) .EQ. 6) THEN 2306 KDEC(74)=12 2307 GO TO 740 2308 END IF 2309C 2310 IF(KDEC(17) .EQ. 4) THEN 2311 IF(IHOURS .EQ. 0) 2312 1 THEN 2313 KDEC(74)=18 2314 GO TO 740 2315 END IF 2316 IF(IHOURS .EQ. 6 .OR. IHOURS .EQ. 2317 1 18) THEN 2318 KDEC(74)=24 2319 GO TO 740 2320 END IF 2321 IF(IHOURS .EQ. 12) 2322 1 THEN 2323 KDEC(74)=12 2324 GO TO 740 2325 END IF 2326 END IF 2327C 2328 IF(KDEC(17) .EQ. 5) KDEC(74)=24 2329C 2330740 CONTINUE 2331C 2332C*** RRR AMOUNT OF PRECIPITATION 1/10THS OF MM 2333C 2334C DECODE RAINFALL IF NOT ALREADY DECODED FROM SECTION 1. 2335C 2336C IF (KDEC(40).NE.MINDIC) GO TO 750 2337C 2338 CALL IC3590 (KINT(114),KINT(14),MINDIC,KDEC(140)) 2339C 2340C DURATION NOT DECODED IF RAINFALL VALUE IS MISSING. 2341C 2342C IF (KDEC(40).EQ.MINDIC) GO TO 750 2343C 2344C 2345C***DURATION OF RRR 2346 IHOURS = KDEC(2) 2347 IF (IHOURS.EQ.MINDIC) IHOURS=KDEC(11) 2348 IF (IHOURS.LT.0.OR.IHOURS.GT.24) IHOURS=MINDIC 2349 IF (IHOURS.EQ.MINDIC) GO TO 750 2350C 2351C 2352 CALL ICTRTR (KDEC(16),KDEC(17),KINT(115),IHOURS,MINDIC,KDEC(141)) 2353C 2354C 2355 750 CONTINUE 2356C 2357C*** NS AMOUNT OF CLOUD (CODE FIGURE) 2358C C TYPE OF CLOUD 2359C HSHS HEIGHT OF BASE OF CLOUD LAYER 2360C 2361C 2362 DO 800 I=75,84,3 2363 J=(I - 75)/3 + I 2364 IF(KINT(J+46) .EQ. MINDIC) GO TO 810 2365 KDEC(I)=KINT(J+47) 2366 KDEC(I+1)=KINT(J+48) 2367 CALL IC1677(KINT(J+49),MINDIC,KDEC(I+2)) 2368800 CONTINUE 2369C 2370810 CONTINUE 2371C 2372C 2373C KDEC(87) -- KDEC(94) SPSP SPSP SPECIAL PHENOMENA 2374C (CODE FIGURES) 2375C 2376 DO 900 I=87,94 2377 J=(I-87)/2 + I 2378 IF(KINT(J+50) .EQ. MINDIC) GO TO 910 2379 KDEC(I)=KINT(J+51) 2380 KDEC(I+1)=KINT(J+52) 2381900 CONTINUE 2382C 2383910 CONTINUE 2384C 2385C 2386C*** E STATE OF GROUND, NO SNOW OR ICE 2387C 2388 IF(KINT(93) .NE. MINDIC) KDEC(97)=KINT(94) 2389C 2390C 2391C*** E' STATE OF GROUND WITH SNOW OR ICE 2392C 2393C 2394 IF(KINT(98) .NE. MINDIC) 2395 * THEN 2396 KDEC(98)=KINT(99) 2397 KDEC(99)=KINT(100) 2398 IF(KDEC(99) .EQ. 997) KDEC(99)=0 2399 IF(KDEC(99) .GE. 998) KDEC(99)=MINDIC 2400 IF(KDEC(99) .GE. 999) KDEC(99)=MINDIC 2401 END IF 2402C 2403C 2404C 2405C FROM CHINA SNOW INFORMATION IS IN SPECIAL PHENOMENA. 9 SPSP SPSP 2406C IN FORM 93 SPSPSP, WHERE SPSPSP = SNOW DEPTH IN CM. 2407C 2408 IF( KDEC(16) .EQ. 250 ) 2409 C THEN 2410 IF(KINT(137) .EQ. 9) 2411 C THEN 2412 INDSNOW = KINT(138) / 10 2413 IF(INDSNOW .EQ. 3) 2414 C THEN 2415 KDEC(99) = 100 * (KINT(138) - 30) + KINT(139) 2416 KDEC(98) = 1 2417 END IF 2418 END IF 2419 END IF 2420C 2421C 2422C 2423C IF E' IS MISSING AND E IS AVAILABLE IT MEANS THAT SNOWDEPTH=0 2424C 2425 IF((KDEC(98) .EQ. MINDIC) .AND. (KDEC(97) .NE. MINDIC)) 2426 1 KDEC(99)=0 2427C 2428C J1J2J3J4J5 GROUP 2429C 2430C EEE EVAPORATION/EVAPOTRANSPIRATION 2431C 2432 IF(KINT(181).NE.MINDIC) THEN 2433C KG/M**2 2434 IF(KINT(182).NE.MINDIC) KDEC(110)=KINT(182)/10. 2435 END IF 2436C 2437C SSS DURATION OF SUNSHINE 2438C 2439 IF(KINT(189).NE.MINDIC) THEN 2440 IF(KINT(191).NE.MINDIC) THEN 2441 IH=KINT(191)/10 2442 IMM=(KINT(191)-IH*10)*6 2443 KDEC(111)=IH*60+IMM 2444 END IF 2445 END IF 2446C 2447C NET RADIATION OVER 24 HOUR PERIOD 2448C 2449C (OTHER RADIATION DATA ARE NOT PASSED)!!!! 2450C 2451 IF(KINT(192).NE.MINDIC.AND.KINT(193).NE.MINDIC) THEN 2452 KDEC(112)=KINT(193) 2453 END IF 2454 IF(KINT(194).NE.MINDIC.AND.KINT(195).NE.MINDIC) THEN 2455 KDEC(112)=-KINT(195) 2456 END IF 2457C 2458950 CONTINUE 2459C 2460C 2461C CALL PRTKINT(KINT,1,300,MINDIC) 2462C CALL PRTKDEC(KDEC,1,KDEC(24),MINDIC) 2463C 2464 olast=.false. 2465 CALL SYNEXP1(olast, IERR ) 2466C CALL QCSYNOP( 1,KDEC(4),KDEC(23),IERR ) 2467C 2468C CALL SYNEXP2( IERR ) 2469C CALL QCSYNOP( 2,KDEC(4),KDEC(23),IERR ) 2470C 2471C 2472C---- PRINT OF INTERMEDIATE AND DECODED FORM OF REPORTS 2473 RETURN 2474C 2475C 2476 END 2477 SUBROUTINE SMINT (IHEAD,IERR) 2478C 2479C 2480C**** *SMINT* 2481C 2482C 2483C PURPOSE. 2484C -------- 2485C 2486C CONVERT SURFACE REPORTS FROM CCITT. NO.5 CHARACTER 2487C FORMAT TO INTERMEDIATE ( INTEGER ) FORMAT. 2488C 2489C 2490C 2491C 2492C** INTERFACE. 2493C ---------- 2494C 2495C *CALL* *SMINT(IHEAD,IERR)* 2496C 2497C INPUT : REPORT IN KCHAR(IPT) - KCHAR(IEQ) , IN CCITT 5 , 2498C 1 CHARACTER PER WORD. 2499C 2500C IHEAD = 0 INDICATES BULLETIN HEADER NOT ALREADY 2501C WRITTEN TO ERROR FILE. 2502C = 1 MEANS HEADER ALREADY WRITTEN TO ERROR FILE. 2503C 2504C IERR IS NOT USED ON INPUT. 2505C 2506C 2507C OUTPUT : REPORT IN INTEGER FORMAT IN ARRAY 'KINT' IN 2508C DESIRED FORMAT ( SEE SEPARATE DOCUMENTATION ) 2509C 2510C IERR = 1 IF ANY FILE HANDLING ERROR ENCOUNTERED. 2511C 2512C 2513C METHOD. 2514C ------- 2515C 2516C NONE. 2517C 2518C 2519C EXTERNALS. 2520C ---------- 2521C 2522C *CALL* *XXXXXXX(XXXX)* 2523C 2524C REFERENCE. 2525C ---------- 2526C 2527C NONE. 2528C 2529C AUTHOR. 2530C ------- 2531C 2532C 2533C 2534C MODIFICATIONS. 2535C -------------- 2536C 2537C M. DRAGOSAVAC *ECMWF* AUG 1988. 2538C 2539C 2540 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 2541C 2542 INCLUDE 'parameter.h' 2543 INCLUDE 'comwork.h' 2544 INCLUDE 'comindx.h' 2545 INCLUDE 'comstat.h' 2546c 2547 character*21 CTSTAMP 2548 character*4 CSTREAM 2549 character*256 cf 2550C 2551C ------------------------------------------------------------------ 2552C* 1. CLEAR FLAGS AND ERROR INDICATOR.KEEP POINTER 2553C TO FIRST CHARACTER OF REPORT. 2554C 2555 100 CONTINUE 2556C 2557C POINTER TO FIRST CHARACTER. 2558C 2559 KEEP = IPT 2560C 2561C FLAG INDICATING FIRST DECODING ATTEMPT ON REPORT. 2562C 2563 IFIRST = 0 2564C 2565C ERROR INDICATOR. 2566C 2567 10 KERR = 0 2568C 2569C 2570C*** 2571C* CHECK FOR 'NIL' REPORT. 2572C*** 2573C 2574 LEN = IEQ - IPT 2575C 2576C RETURN IF REPORT SHORTER THAN 5 CHARS, FLAG ERROR = 2 2577C SO IT WONT BE DECODED AT ALL (EVEN AS 'NIL') 2578C 2579 IF(LEN .LT. 5) 2580 C THEN 2581 KERR = 2 2582 RETURN 2583 END IF 2584C 2585 NIL = 0 2586C 2587 IF (KDEC(4).LE.14.AND.LEN.LE.17) NIL = 1 2588 IF (KDEC(4).GE.21.AND.LEN.LE.28) NIL = 1 2589C 2590 IF (NIL.EQ.1) THEN 2591 KERR = 1 2592 NOER(1,1) = NOER(1,1) + 1 2593C 2594C----- PRINT 'NIL' SURFACE REPORTS 2595C----- 2596C----- CALL PRTBULL (IPT,IEQ) 2597C----- 2598C----- PRINT 'NIL' SURFACE REPORTS 2599C 2600 END IF 2601C 2602C 2603C*** 2604C* SET AREA FOR DECODED REPORT TO MISSING DATA VALUE. 2605C* START IS IN WORD 4 AS YY GG IW FOR LAND STATIONS MAY ALREADY 2606C* HAVE BEEN INSERTED . 2607C*** 2608C 2609 DO 101 I=4,300 2610 KINT(I) = MINDIC 2611 101 CONTINUE 2612C 2613C 2614C WORDS 9-13 SET TO CCITT.5 'XXX ' ( 'X' = 88, 'SPACE' = 32 ) 2615C STATION/SHIP IDENTIFIER RETAINED IN THESE WORDS IN CCITT 5 CHARS. 2616C 2617 DO 200 I=9,11 2618 KINT(I) = 88 2619 200 CONTINUE 2620C 2621 KINT(12) = 32 2622 KINT(13) = 32 2623C 2624C*** 2625C* CLEAR DATA FOR PREVIOUS REPORT FROM DECODED REPORT HEADER AREA. 2626C*** 2627C 2628 DO 300 I=1,3 2629 KDEC(I) = MINDIC 2630 300 CONTINUE 2631C 2632 DO 400 I=5,9 2633 KDEC(I) = MINDIC 2634 400 CONTINUE 2635C 2636C CLEAR FLAG FIELDS , RETAINING 'COR' FLAG. 2637C 2638 KDEC(13) = 0 2639C 2640 KDEC(15) = IAND(KDEC(15),4) 2641C 2642 DO 500 I=16,17 2643 KDEC(I) = MINDIC 2644 500 CONTINUE 2645C 2646 KDEC(20)=0 2647C 2648 DO 600 I=22,23 2649 KDEC(I) = MINDIC 2650 600 CONTINUE 2651C 2652C 2653C*** 2654C* CONVERT SECTION 0 , WHICH IS DIFFERENT FOR LAND AND SEA 2655C* STATIONS. 2656C*** 2657C 2658 700 IF ( KDEC(4).EQ.11.OR.KDEC(4).EQ.14) 2659 C THEN 2660C 2661C LAND STATION . 2662C 2663C 2664C RETAIN POINTER TO STATION IDENTIFIER . 2665C 2666C IIIII 2667C 2668 KPT = IPT 2669 ID = 5 2670C 2671 CALL EXTINT ( IPT,5,4 ) 2672 CALL LOCSTAT (IWIND,IRET) 2673C 2674 IF ( IRET.EQ.1 ) THEN 2675C 2676C STATION NUMBER IN RANGE BUT NO MASTER FILE ENTRY 2677C ,SO REPORT IS IGNORED. 2678C 2679 KERR=2 2680 NOER(1,2)=NOER(1,2)+1 2681C 2682C-- PRINT IIIII WITH NO MASTER FILE ENTRY 2683C-- 2684c cf=' ' 2685c cf='/home/ma/maa/feed/err/unknown_synop_station.dat' 2686c icf=index(cf,' ') 2687c icf=icf-1 2688c 2689c OPEN(UNIT=55, 2690c 1 FILE=cf(1:icf), 2691c 2 ACCESS='APPEND', 2692c 4 FORM='FORMATTED', 2693c 5 STATUS='UNKNOWN' ) 2694C 2695c WRITE (55,9901) KINT(4) 2696c CLOSE(55) 2697 WRITE (*,9901) KINT(4) 2698 9901 FORMAT (1H ,'NO MASTER FILE ENTRY - ',I5.5) 2699C----- 2700C----- PRINT IIIII WITH NO MASTER FILE ENTRY 2701C 2702 RETURN 2703 END IF 2704C 2705 IF (IRET.EQ.2 ) 2706 C THEN 2707C 2708C CORRUPT NUMBER - FATAL ERROR. 2709C 2710 KPT=IABS(KPT) 2711 KCHAR(KPT+5)=IOR(KCHAR(KPT+5),128) 2712 KERR = 2 2713 IF ( IFIRST.EQ.0 ) NOER(1,2)=NOER(1,2) + 1 2714C 2715C RETURN IF REPORT TOO SHORT TO CONTAIN IDENT 2716C 2717 IF( (KPT+5) .GE. IEQ) RETURN 2718C 2719 GO TO 4000 2720 END IF 2721C 2722 IF (IRET.EQ.3) RETURN 2723C 2724C 2725C 2726C FOR "NIL" REPORTS ONLY THE HEADER WILL BE DECODED 2727C 2728 IF(NIL .EQ. 1) THEN 2729 KDEC(20)=1 2730 GO TO 790 2731 END IF 2732C 2733C 2734C IF WIND INDICATOR IW IS MISSING USE THE MASTER FILE 2735C INDICATOR TO REPLACE IW. REPLACEMENT IW INDICATES 2736C WIND MEASURED AND UNITS KNOTS OR METRES PER SECOND. 2737C 2738 IF ( KINT(3).EQ.MINDIC ) 2739 C THEN 2740C 2741C KNOTS 2742C 2743 IF ( IWIND.EQ.0 ) KINT(3)=4 2744C 2745C METRES PER SECOND 2746C 2747 IF ( IWIND.EQ.1 ) KINT(3)=1 2748 END IF 2749C 2750 ELSE 2751C 2752C SEA STATION 2753C 2754C RETAIN POINTER TO STATION IDENTIFIER . 2755C 2756 KPT=IPT 2757C 2758C CHECK WHETHER BUOY REPORT OR SHIP,RIG OR PLATFORM. 2759C BUOUY REPORTS HAVE D---D OF 5 FIGURES. 2760C 2761 IBUOY = 0 2762 K = IPT 2763 J = K + 4 2764C 2765 DO 750 I=K,J 2766 IF ( KCHAR(I).GE.65.AND.KCHAR(I).LE.90 ) IBUOY=1 2767 750 CONTINUE 2768C 2769C IF A 5 FIGURE GROUP IS FOUND CHECK FOLLOWING GROUP. 2770C IF THE FOLLOWING GROUP STARTS WITH A 9 THE SHIP CALL 2771C SIGN GROUP IS PRESUMED MISSING. 2772C 2773 CALL NEXTPRT (I,IEQ) 2774 IF ( IBUOY.EQ.0 ) 2775 C THEN 2776 IF (KCHAR(I).EQ.57) IBUOY = 2 2777 END IF 2778C 2779 IF ( IBUOY.NE.0 ) 2780 C THEN 2781C 2782C SHIP,RIG OR PLATFORM. IDENTIFIER NO. SET TO 0 2783C 2784 KINT(4) = 0 2785C 2786 IF (IBUOY.EQ.1) 2787 C THEN 2788C 2789C MOVE POINTER PAST CALL SIGN . THE FIRST 2790C FIGURE AFTER START OF THE NEXT GROUP IS 2791C LOCATED AS SOME SHIPS USE THE FULL NAME 2792C ( WHICH CAN CONSIST OF 2 WORDS ) INSTEAD 2793C OF CALL SIGN. 2794C 2795 CALL NEXTVAL (IPT,32,IEQ) 2796 CALL NEXTFIG (IPT,IEQ) 2797C 2798 ID = IPT-KPT-1 2799C 2800 ELSE 2801C 2802C D---D MISSING , SO SET LENGTH OF CALL 2803C SIGN TO 0. 2804C 2805 ID = 0 2806C 2807 END IF 2808C 2809 ELSE 2810C 2811C BUOY- A1 BW NBNBNB 2812C 2813 CALL EXTINT ( IPT,5,4 ) 2814C 2815C ALTER RDB REPORT TYPE FIGURE 2816C 2817 KDEC(4) = 24 2818 ID = 5 2819C 2820 END IF 2821C 2822C YY GG IW 2823C 2824 CALL NEXTPRT ( IPT,IEQ ) 2825C 2826C IF FIRST OF FIGURE OF GROUP IS NOT 0-3 , YYGGIW 2827C GROUP IS MISSING. 2828C 2829 IF (KCHAR(IPT).GE.48.AND.KCHAR(IPT).LE.51) 2830 C CALL EXTGRP ( IPT,2,2,1,0,0,1,IRET ) 2831 JPT = IPT 2832C 2833C 99 LALALA 2834C 2835 CALL NEXTPRT ( IPT,IEQ ) 2836 CALL EXTGRP ( IPT,2,3,0,0,0,5,IRET ) 2837C 2838C CHECK VALIDITY OF LALALA 2839C 2840 IF (KINT(6).LT.0.OR.KINT(6).GT.900) 2841 C THEN 2842 IPT =IABS(IPT) 2843 KCHAR(IPT)=IOR(KCHAR(IPT),128) 2844 KERR = 4 2845 IF (IFIRST.EQ.0) 2846 C NOER(1,4) = NOER(1,4) + 1 2847 GO TO 4000 2848 END IF 2849C 2850C QC LOLOLOLO 2851C 2852 CALL NEXTPRT ( IPT,IEQ ) 2853 CALL EXTGRP ( IPT,1,4,0,0,0,7,IRET ) 2854C 2855C CHECK VALIDITY OF LOLOLOLO 2856C 2857 IF (KINT(7).NE.1.AND.KINT(7).NE.3.AND. 2858 C KINT(7).NE.5.AND.KINT(7).NE.7) IRET=1 2859 IF (KINT(8).LT.0.OR.KINT(8).GT.1800)IRET=1 2860 IF (IRET.NE.0) 2861 C THEN 2862 IPT= IABS(IPT) 2863 KCHAR(IPT)=IOR(KCHAR(IPT),128) 2864 KERR=4 2865 IF ( IFIRST.EQ.0 ) 2866 C NOER(1,4)=NOER(1,4) + 1 2867 GO TO 4000 2868 END IF 2869C 2870 END IF 2871790 CONTINUE 2872C 2873C RETAIN STATION IDENTIFIER IN CHARACTER FORM ( IF ANY EXISTS ) 2874C 2875 IF ( ID.NE.0 ) 2876 C THEN 2877 IF (ID.GT.5) ID = 5 2878 J = KPT 2879 K = 9 + ID -1 2880 DO 800 I=9,K 2881C 2882C IF LETTER ENCOUNTERED FOR LAND STATION CONVERT 2883C IT TO FIGURE (NOT FOR SHIP'S CALL SIGN) 2884C 2885 IF(KDEC(4) .LE. 14) CALL LETFIG(KCHAR(J)) 2886 KINT(I) = KCHAR(J) 2887 J = J + 1 2888 800 CONTINUE 2889 END IF 2890C 2891C 2892 IF(NIL .EQ. 1) RETURN 2893C 2894C 2895C 2896C CHECK VALUES OF YY GG IW FOR SHIP REPORTS. IF AN ERROR 2897C IS FOUND IN YY OR GG THE ERROR IS FATAL AS SHIP REPORTS 2898C FREQUENTLY HAVE DIFFERENT TIMES FROM BULLETIN HEADER TIMES. 2899C IF THERE IS AN ERROR IN IW THE WIND CANNOT BE DECODED . 2900C 2901 IF ( KDEC(4).GT.14 ) 2902 C THEN 2903 IRET = 0 2904 IF (KINT(1).LT.1.OR.KINT(1).GT.31) 2905 C THEN 2906 IRET = 2 2907 KINT(1) = MINDIC 2908 END IF 2909 IF (KINT(2).LT.0.OR.KINT(2).GT.23) 2910 C THEN 2911 IRET = 2 2912 KINT(2) = MINDIC 2913 END IF 2914 IF (KINT(3).EQ.2.OR.KINT(3).LT.0.OR.KINT(3).GT.4) 2915 C THEN 2916 IF (IRET.EQ.0) IRET = 1 2917 KINT(3) = MINDIC 2918 END IF 2919C 2920 IF (IRET.NE.0) 2921 C THEN 2922 JPT=IABS(JPT) 2923 KCHAR(JPT)=IOR(KCHAR(JPT),128) 2924 IF ( IFIRST.EQ.0 ) 2925 C NOER(1,3) = NOER(1,3) + 1 2926 IF ( IRET.EQ.2 ) 2927 C THEN 2928 KERR = 3 2929 GO TO 4000 2930 END IF 2931C 2932 END IF 2933 END IF 2934C 2935C 2936C*** 2937C* CONVERT SECTION 1 . 2938C*** 2939C 2940C IR IX H VV 2941C 2942 CALL NEXTPRT ( IPT,IEQ ) 2943 CALL EXTGRP ( IPT,1,1,1,2,0,14,IRET ) 2944C 2945C CHECK RANGES OF VALUES. 2946C 2947C IR 0 - 4 OR / 2948C 2949C 2950 IF (KINT(14).LT.0.OR.KINT(14).GT.4.AND. 2951 C KINT(14).NE.MINDIC) IRET = 1 2952C 2953C IX 1 - 7 OR / 2954C 2955 IF (KINT(15).LT.1.OR.KINT(15).GT.7.AND. 2956 C KINT(15).NE.MINDIC) IRET = 1 2957C 2958 IF (IRET.NE.0 ) 2959 C THEN 2960 IPT = IABS(IPT) 2961 KCHAR(IPT) = IOR(KCHAR(IPT),128) 2962 KERR = 5 2963 IF (IFIRST.EQ.0) NOER(1,5) = NOER(1,5) + 1 2964 END IF 2965C 2966C 2967C IF AUTO REPORT ALTER RDB CODE FIGURE . 2968C 2969 IF ( KINT(15).GE.4.AND.KINT(15).LE.7) 2970 C THEN 2971 IF (KDEC(4).EQ.11) KDEC(4) =14 2972 IF (KDEC(4).EQ.21) KDEC(4) =24 2973 END IF 2974C 2975C 2976C N DD FF 2977C 2978 CALL NEXTPRT ( IPT,IEQ ) 2979 CALL EXTGRP ( IPT,1,2,2,0,0,18,IRET ) 2980C 2981C CHECK RANGE OF VALUES. 2982C 2983 IF (KINT(19).LT.0) IRET = 1 2984 IF (KINT(19).GT.86.AND.KINT(19).NE.99) IRET = 1 2985 IF (KINT(19).GT.36.AND.KINT(19).LT.51) IRET = 1 2986 IF (KINT(19).EQ.0.AND.KINT(20).NE.0) IRET = 1 2987C 2988C IF GROUP IS ///// , N//FF OR N//// IT IS ACCEPTED. 2989C 2990 IF (KINT(19).EQ.MINDIC) IRET = 0 2991C 2992C check if ff = 99 2993C 2994 if(kint(20).eq.99) then 2995c 2996C LOCATE NEXT GROUP . 2997C 2998 CALL NEXTPRT ( IPT,IEQ ) 2999 IF (IPT.GE.IEQ) GO TO 3000 3000 if(kchar(ipt).eq.48.and.kchar(ipt+1).eq.48) then 3001 CALL EXTGRP ( IPT,2,3,0,0,0,255,IRET ) 3002 end if 3003 end if 3004C 3005 IF (IRET.NE.0) THEN 3006 IPT = IABS(IPT) 3007 KCHAR(IPT) = IOR(KCHAR(IPT),128) 3008 KERR = 6 3009 IF (IFIRST.EQ.0) NOER(1,6) = NOER(1,6)+1 3010 END IF 3011C 3012C 3013C 3014C LOCATE NEXT GROUP . 3015C 3016 CALL NEXTPRT ( IPT,IEQ ) 3017 IF (IPT.GE.IEQ) GO TO 3000 3018C 3019C CONVERT IF GROUP IDENTIFYING FIGURE IS 1 ( '1' = 49 ) . 3020C 3021 IF ( KCHAR(IPT).EQ.49 ) 3022 C THEN 3023C 3024C 1 SN TTT 3025C 3026C SHIP REPORTS IN REDUCED FORM USE TT/ , SO 3027C REPLACE / BY '0' . 3028C 3029C MODIFY RDB CODE FIGURE AS WELL. 3030C 3031 IF ( KCHAR(IPT+4).EQ.47 ) 3032 C THEN 3033 KCHAR(IPT+4) = 48 3034 IF(KDEC(4).GT.14) KDEC(4) = 23 3035 END IF 3036C 3037 CALL EXTGRP( IPT,1,1,3,0,0,21,IRET ) 3038C 3039 IF (KINT(22).LT.0.OR.KINT(22).GT.1) IRET = 1 3040C 3041C IF SN = / , GROUP IS TREATED AS 1//// 3042C 3043 IF (KINT(22).EQ.MINDIC) IRET = 0 3044C 3045 IF ( IRET.NE.0 ) 3046 C THEN 3047 IPT = IABS(IPT) 3048 KCHAR(IPT)=IOR(KCHAR(IPT),128) 3049 KERR = 7 3050 IF (IFIRST.EQ.0) NOER(1,7) =NOER(1,7) + 1 3051 END IF 3052C 3053 CALL NEXTPRT ( IPT,IEQ ) 3054 END IF 3055C 3056C CONVERT IF GROUP IDENTIFYING FIGURE IS 2 ( '2' = 50 ) 3057C FIRST CHECK THAT IT IS NOT START OF SECTION 2. 3058C 3059 IF (IPT.GE.IEQ) GO TO 3000 3060 IF ( KCHAR(IPT).EQ.50.AND.KCHAR(IPT+1).NE.50 ) 3061 C THEN 3062C 3063C 2 SN TDTDTD OR 2 9 UUU 3064C 3065C IF TDTDTD IS IN THE FORM TDTD/ , REPLACE / BY 0 . 3066C 3067 IF (KCHAR(IPT+4).EQ.47 ) KCHAR(IPT+4) = 48 3068C 3069 CALL EXTGRP ( IPT,1,1,3,0,0,24,IRET ) 3070C 3071 IF (KINT(25).LT.0.OR.KINT(25).GT.9)IRET=1 3072 IF (KINT(25).GT.1.AND.KINT(25).LT.9) IRET = 1 3073C 3074C IF SN = / , GROUP IS TREATED AS 2//// 3075C 3076 IF (KINT(25).EQ.MINDIC) IRET = 0 3077C 3078 IF (IRET.NE.0) 3079 C THEN 3080 IPT = IABS(IPT) 3081 KCHAR(IPT) = IOR(KCHAR(IPT),128) 3082 IF (IFIRST.EQ.0) NOER(1,8) = NOER(1,8)+1 3083 KERR = 8 3084 END IF 3085 CALL NEXTPRT ( IPT,IEQ ) 3086 END IF 3087C 3088C CONVERT IF GROUP IDENTIFYING FIGURE IS 3 ( '3' = 51 ) 3089C FIRST CHECK THAT IT IS NOT START OF SECTION 3. 3090C 3091 IF (IPT.GE.IEQ) GO TO 3000 3092 IF ( KCHAR(IPT).EQ.51.AND.KCHAR(IPT+1).NE.51 ) 3093 C THEN 3094C 3095C 3 POPOPOPO 3096C 3097C IF POPOPOPO IS OF THE FORM POPOPO/ , REPLACE / BY 0. 3098C 3099 IF (KCHAR(IPT+4).EQ.47) KCHAR(IPT+4) = 48 3100C 3101 CALL EXTGRP( IPT,1,4,0,0,0,27,IRET ) 3102C 3103 IF (IRET.NE.0) 3104 C THEN 3105 IPT = IABS(IPT) 3106 KCHAR(IPT)=IOR(KCHAR(IPT),128) 3107 KERR = 9 3108 IF (IFIRST.EQ.0) NOER(1,9) = NOER(1,9)+1 3109 END IF 3110C 3111 CALL NEXTPRT ( IPT,IEQ ) 3112 END IF 3113C 3114C CONVERT IF GROUP IDENTIFYING FIGURE IS 4 ( '4' = 52 ) 3115C FIRST CHECK THAT IT IS NOT START OF SECTION 4. 3116C 3117 IF (IPT.GE.IEQ) GO TO 3000 3118 IF ( KCHAR (IPT).EQ.52.AND.KCHAR(IPT+1).NE.52 ) 3119 C THEN 3120C 3121C 4 P PPP OR 4 A3 HHH 3122C 3123C SHIP REPORTS IN REDUCED FORM USE PPP/ , 3124C SO REPLACE '/' BY '0' . 3125C 3126C MODIFY RDB CODE FIGURE AS WELL. 3127C 3128 IF ( KCHAR(IPT+4).EQ.47 ) 3129 C THEN 3130 KCHAR(IPT+4) = 48 3131 IF(KDEC(4).GT.14) KDEC(4) = 23 3132 END IF 3133C 3134 CALL EXTGRP( IPT,1,1,3,0,0,29,IRET ) 3135C 3136 IF ( IRET.NE.0 ) 3137 C THEN 3138 IPT = IABS(IPT) 3139 KCHAR(IPT) = IOR(KCHAR(IPT),128) 3140 IF (IFIRST.EQ.0) NOER(1,10)=NOER(1,10)+1 3141 KERR = 10 3142 END IF 3143C 3144 CALL NEXTPRT ( IPT,IEQ ) 3145 END IF 3146C 3147C CONVERT IF GROUP IDENTIFYING FIGURE IS 5 ( '5' = 53 ) 3148C FIRST CHECK THAT IT IS NOT START OF SECTION 5. 3149C 3150 IF (IPT.GE.IEQ) GO TO 3000 3151 IF ( KCHAR(IPT).EQ.53.AND.KCHAR(IPT+3).NE.32) 3152 C THEN 3153C 3154C 5 A PPP 3155C 3156 CALL EXTGRP ( IPT,1,1,3,0,0,32,IRET ) 3157 CALL NEXTPRT ( IPT,IEQ ) 3158 END IF 3159C 3160C CONVERT IF GROUP IDENTIFYING FIGURE IS 6 ( '6' = 54 ) 3161C 3162 IF (IPT.GE.IEQ) GO TO 3000 3163 IF ( KCHAR(IPT).EQ.54 ) 3164 C THEN 3165C 3166C 6 RRR TR 3167C 3168 CALL EXTGRP ( IPT,1,3,1,0,0,35,IRET ) 3169 CALL NEXTPRT ( IPT,IEQ ) 3170 END IF 3171C 3172C CONVERT IF GROUP IDENTIFYING FIGURE IS 7 ( '7' = 55 ) 3173C 3174 IF (IPT.GE.IEQ) GO TO 3000 3175 IF ( KCHAR(IPT).EQ.55 ) 3176 C THEN 3177C 3178C 7 WW W1 W2 3179C 3180 CALL EXTGRP ( IPT,1,2,1,1,0,38,IRET ) 3181 CALL NEXTPRT ( IPT,IEQ ) 3182 END IF 3183C 3184C CONVERT IF GROUP IDENTIFYING FIGURE IS 8 . ( '8' = 56 ) 3185C 3186 IF (IPT.GE.IEQ) GO TO 3000 3187 IF ( KCHAR(IPT).EQ.56 ) 3188 C THEN 3189C 3190C 8 NH CL CM CH 3191C 3192 CALL EXTGRP ( IPT,1,1,1,1,1,42,IRET ) 3193 CALL NEXTPRT ( IPT,IEQ ) 3194 END IF 3195C 3196C 3197C CONVERT IF GROUP IDENTIFYING FIGURE IS 9 . ( '9' = 57 ) 3198C 3199 IF (IPT.GE.IEQ) GO TO 3000 3200 IF ( KCHAR(IPT).EQ.57 ) 3201 C THEN 3202C 3203C 9 GGgg 3204C 3205 CALL EXTGRP ( IPT,1,2,2,0,0,47,IRET ) 3206 CALL NEXTPRT ( IPT,IEQ ) 3207 END IF 3208C 3209C 3210C 3211C*** 3212C* CONVERT SECTION 2 . 3213C*** 3214C 3215C CONVERT 222 GROUP .( '2' = 50 ) 3216C 3217 900 IF (IPT.GE.IEQ) GO TO 3000 3218 IF (KCHAR(IPT).NE.50 ) 3219 C THEN 3220C 3221C NOT SECTION 2 3222C 3223 GO TO 1000 3224 ELSE 3225C 3226C 222 DS VS 3227C 3228 CALL EXTGRP ( IPT,3,1,1,0,0,50,IRET ) 3229 CALL NEXTPRT ( IPT,IEQ ) 3230C 3231C ALTER RDB CODE FIGURE IF ABBREVIATED 3232C REPORT ( DSVS = // ) 3233C 3234 IF ( KDEC(4).EQ.21.AND.KINT(51).EQ.MINDIC. 3235 C AND.KINT(52).EQ.MINDIC ) KDEC(4) =22 3236 END IF 3237C 3238C 3239C CONVERT IF GROUP IDENTIFYING FIGURE IS 0 ( '0' = 48 ) 3240C 3241 IF (IPT.GE.IEQ) GO TO 3000 3242 IF ( KCHAR(IPT).EQ.48 ) 3243 C THEN 3244C 3245C 0 SN TWTWTW 3246C 3247 CALL EXTGRP (IPT,1,1,3,0,0,53,IRET ) 3248 CALL NEXTPRT ( IPT,IEQ ) 3249 END IF 3250C 3251C CONVERT IF GROUP IDENTIFYING FIGURE IS 1 ( '1' = 49 ) 3252C 3253 IF (IPT.GE.IEQ) GO TO 3000 3254 IF ( KCHAR(IPT).EQ.49 ) 3255 C THEN 3256C 3257C 1 PWAPWA HWAHWA 3258C 3259 CALL EXTGRP( IPT,1,2,2,0,0,56,IRET ) 3260 CALL NEXTPRT ( IPT,IEQ ) 3261 END IF 3262C 3263C CONVERT IF GROUP IDENTIFYING FIGURE IS 2 ( '2' = 50 ) 3264C 3265 IF (IPT.GE.IEQ) GO TO 3000 3266 IF ( KCHAR(IPT).EQ.50 ) 3267 C THEN 3268C 3269C 2 PWPW HWHW 3270C 3271 CALL EXTGRP( IPT,1,2,2,0,0,59,IRET ) 3272 CALL NEXTPRT ( IPT,IEQ ) 3273 END IF 3274C 3275C CONVERT IF GROUP IDENTIFYING FIGURE IS 3 ( '3' = 51 ) 3276C FIRST CHECK IF START OF SECTION 3 . 3277C 3278 IF (IPT.GE.IEQ) GO TO 3000 3279 IF ( KCHAR(IPT).EQ.51.AND.KCHAR(IPT+3).NE.32) 3280 C THEN 3281C 3282C 3 DW1DW1 DW2DW2 3283C 3284 CALL EXTGRP ( IPT,1,2,2,0,0,62,IRET) 3285 CALL NEXTPRT ( IPT,IEQ ) 3286 END IF 3287C 3288C 3289C CONVERT IF GROUP IDENTIFYING FIGURE IS 4 ( '4' = 52 ) 3290C FIRST CHECK IF START OF SECTION 4 . 3291C 3292 IF (IPT.GE.IEQ) GO TO 3000 3293 IF ( KCHAR(IPT).EQ.52.AND.KCHAR(IPT+3).NE.32) 3294 C THEN 3295C 3296C 4 PW1PW1 HW1HW1 3297C 3298 CALL EXTGRP ( IPT,1,2,2,0,0,65,IRET ) 3299 CALL NEXTPRT ( IPT,IEQ ) 3300 END IF 3301C 3302C CONVERT IF GROUP IDENTIFYING FIGURE IS 5 ( '5' = 53 ) 3303C FIRST CHECK IF START OF SECTION 5 . 3304C 3305 IF (IPT.GE.IEQ) GO TO 3000 3306 IF ( KCHAR(IPT).EQ.53.AND.KCHAR(IPT+3).NE.32) 3307 C THEN 3308C 3309C 5 PW2PW2 HW2HW2 3310C 3311 CALL EXTGRP ( IPT,1,2,2,0,0,68,IRET ) 3312 CALL NEXTPRT ( IPT,IEQ ) 3313 END IF 3314C 3315C CONVERT IF GROUP IDENTIFYING FIGURE IS 6 ( '6' = 54 ) 3316C 3317 IF (IPT.GE.IEQ) GO TO 3000 3318 IF ( KCHAR(IPT).EQ.54 ) 3319 C THEN 3320C 3321C 6 IS ESES RS 3322C 3323 CALL EXTGRP ( IPT,1,1,2,1,0,71,IRET ) 3324 CALL NEXTPRT ( IPT,IEQ ) 3325 END IF 3326C 3327C CONVERT IF GROUP IDENTIFYING FIGURE IS 70 ( '7' = 55 ) 3328C 3329 IF (IPT.GE.IEQ) GO TO 3000 3330 IF ( KCHAR(IPT).EQ.55.AND.KCHAR(IPT+1).EQ.48 ) THEN 3331C 3332C 70HwaHwaHwa 3333C 3334C 3335 CALL EXTGRP(IPT,2,3,0,0,0,250,IRET) 3336 CALL NEXTPRT ( IPT,IEQ ) 3337 END IF 3338C 3339C CONVERT IF GROUP IDENTIFYING FIGURE IS 8 ( '8' = 56 ) 3340C 3341 IF (IPT.GE.IEQ) GO TO 3000 3342 IF ( KCHAR(IPT).EQ.56) THEN 3343C 3344C 8swTbTbTb 3345C 3346C 3347 CALL EXTGRP(IPT,1,1,3,0,0,252,IRET) 3348 CALL NEXTPRT ( IPT,IEQ ) 3349 END IF 3350C 3351C CHECK FOR 'ICE' INDICATOR. 3352C 3353 IF (IPT.GE.IEQ) GO TO 3000 3354 IF ( KCHAR(IPT).EQ.73 ) 3355 C THEN 3356C 3357C ICE , SO SET FLAG. 3358C 3359 KINT(75) = 1 3360 IPT =IPT + 3 3361 CALL NEXTPRT( IPT,IEQ ) 3362C 3363C CI SI BI DI ZI 3364C 3365 CALL EXTGRP ( IPT,1,1,1,1,1,76,IRET ) 3366 CALL NEXTPRT (IPT,IEQ) 3367 END IF 3368C 3369C* CONVERT SECTION 3. 3370C*** 3371C 3372 1000 IF (IPT.GE.IEQ) GO TO 3000 3373 IF (KCHAR(IPT).NE.51) 3374 C THEN 3375C 3376C NOT SECTION 3 3377C 3378 GO TO 2000 3379 ELSE 3380C 3381C 333 GROUP 3382C 3383 CALL EXTGRP ( IPT,3,0,0,0,0,81,IRET ) 3384 CALL NEXTPRT ( IPT,IEQ ) 3385 END IF 3386C 3387C 3388C CONVERT IF GROUP IDENTIFYING FIGURE IS 0 ( '0' = 48 ) 3389C 3390 IF (IPT.GE.IEQ) GO TO 3000 3391 IF ( KCHAR(IPT).EQ.48 ) 3392 C THEN 3393C 3394 IF ( KDEC(17).EQ.1 ) 3395 C THEN 3396C 3397C REGION 1 3398C 3399C O TGTG RC RT 3400C 3401 CALL EXTGRP 3402 C (IPT,1,2,1,1,0,82,IRET) 3403 CALL NEXTPRT(IPT,IEQ) 3404 ELSE 3405C 3406C REGION 4 3407C 3408C 0 CS DL DM DH 3409C 3410 CALL EXTGRP 3411 C (IPT,1,1,1,1,1,82,IRET) 3412 CALL NEXTPRT(IPT,IEQ) 3413 END IF 3414 END IF 3415C 3416C 3417C 3418C 3419C CONVERT IF GROUP IDENTIFYING FIGURE IS 1 ( '1' = 49 ) 3420C 3421 IF (IPT.GE.IEQ) GO TO 3000 3422 IF ( KCHAR(IPT).EQ.49 ) 3423 C THEN 3424C 3425C 1 SN TXTXTX 3426C 3427 CALL EXTGRP ( IPT,1,1,3,0,0,87,IRET ) 3428 CALL NEXTPRT( IPT,IEQ ) 3429 END IF 3430C 3431C CONVERT IF GROUP IDENTIFYING FIGURE IS 2 ( '2' = 50 ) 3432C 3433 IF (IPT.GE.IEQ) GO TO 3000 3434 IF ( KCHAR(IPT).EQ.50 ) 3435 C THEN 3436C 3437C 2 SN TNTNTN 3438C 3439 CALL EXTGRP ( IPT,1,1,3,0,0,90,IRET ) 3440 CALL NEXTPRT ( IPT,IEQ ) 3441 END IF 3442C 3443C CONVERT IF GROUP IDENTIFYING FIGURE IS 3 ( '3' = 51 ) 3444C 3445 IF (IPT.GE.IEQ) GO TO 3000 3446 IF ( KCHAR(IPT).EQ.51 ) 3447 C THEN 3448C 3449C 3 E SN TGTG 3450C 3451 CALL EXTGRP ( IPT,1,1,1,2,0,93,IRET ) 3452 CALL NEXTPRT ( IPT,IEQ ) 3453 END IF 3454C 3455C 3456C CONVERT IF GROUP IDENTIFYING FIGURE IS 4 ( '4' = 52 ) 3457C FIRST CHECK IF START OF SECTION 4 . 3458C 3459 IF (IPT.GE.IEQ) GO TO 3000 3460 IF ( KCHAR(IPT).EQ.52.AND.KCHAR(IPT+3).NE.32) 3461 C THEN 3462C 3463C 4 E' SSS 3464C 3465 CALL EXTGRP (IPT,1,1,3,0,0,98,IRET) 3466 CALL NEXTPRT (IPT,IEQ) 3467 END IF 3468C 3469C CONVERT IF GROUP IDENTIFYING FIGURE IS 5 ( '5' = 53 ) 3470C FIRST CHECK IF START OF SECTION 5 . 3471C 3472 1050 IF (IPT.GE.IEQ) GO TO 3000 3473 IF (KCHAR(IPT).EQ.53.AND.KCHAR(IPT+3).NE.32) THEN 3474C 3475C 5 ? 3476C 3477 CALL EXTINT (IPT,1,101) 3478 CALL EXTINT (IPT,1,102) 3479 IF(IPT.LT.0) THEN 3480 IPT=IABS(IPT) 3481C 3482C SKIP PROBLEM GROUP 3483C 3484 CALL NEXTPRT(IPT,IEQ) 3485 CALL NEXTSEP(IPT,IEQ) 3486 GO TO 1050 3487 END IF 3488 CALL EXTINT (IPT,1,103) 3489 IF(IPT.LT.0) THEN 3490 IPT=IABS(IPT) 3491C 3492C SKIP PROBLEM GROUP 3493C 3494 CALL NEXTPRT(IPT,IEQ) 3495 CALL NEXTSEP(IPT,IEQ) 3496 GO TO 1050 3497 END IF 3498 IPT = IABS(IPT) 3499 IPT = IPT-3 3500 IC1=KINT(101) 3501 IC2=KINT(102) 3502 IC3=KINT(103) 3503C 3504C IF ? IS 8 OR9 P24P24P24 3505C 3506 IF (IC2.EQ.8) THEN 3507 CALL EXTGRP (IPT,1,1,3,0,0,233,IRET) 3508 CALL NEXTPRT (IPT,IEQ) 3509 END IF 3510 IF (IC2.EQ.9) THEN 3511 CALL EXTGRP (IPT,1,1,3,0,0,236,IRET) 3512 CALL NEXTPRT (IPT,IEQ) 3513 END IF 3514C 3515C IF ? IS 4 , 6 OR 7 THEN PARAMS ARE 3516C GO SN DT , DL DM DH OR C DA EC . USE 3517C DEPENDS ON REGION. 3518C 3519C 54 g0 Sn dT (TEMPERATURE CHANGE DATA IN PERIOD COV. BY W1W2 3520C 3521 IF (IC2.EQ.4) THEN 3522 CALL EXTGRP(IPT,1,1,1,1,1,184,IRET) 3523 CALL NEXTPRT (IPT,IEQ) 3524 END IF 3525C 3526C 56 DL DM DH DIRECTION ON CLOUD DRIFT 3527C 3528 IF (IC2.EQ.6) THEN 3529 CALL EXTGRP(IPT,1,1,1,1,1,223,IRET) 3530 CALL NEXTPRT (IPT,IEQ) 3531 END IF 3532C 3533C 57 C Da eC DIRECTION AND ELEVATION OF CLOUD 3534C 3535 IF (IC2.EQ.7) THEN 3536 CALL EXTGRP(IPT,1,1,1,1,1,228,IRET) 3537 CALL NEXTPRT (IPT,IEQ) 3538 END IF 3539C 3540C IF ? IS 5 SSS (SUNSHINE) 3541C 3542 IF (IC2.EQ.5.AND.IC3.NE.3) THEN 3543 CALL EXTGRP(IPT,1,1,3,0,0,189,IRET) 3544 CALL NEXTPRT (IPT,IEQ) 3545C 3546C RADIATION DATA 3547C 3548 IF(KCHAR(IPT).EQ.48) THEN 3549C 3550C POSITIVE NET RADIATION DURING THE PRECEDING 24 H 3551C 3552 CALL EXTGRP(IPT,1,4,0,0,0,192,IRET) 3553 CALL NEXTPRT (IPT,IEQ) 3554 END IF 3555 IF(KCHAR(IPT).EQ.49) THEN 3556C 3557C NEGATIVE NET RADIATION DURING THE PRECEDING 24 H 3558C 3559 CALL EXTGRP(IPT,1,4,0,0,0,194,IRET) 3560 CALL NEXTPRT (IPT,IEQ) 3561 END IF 3562 IF(KCHAR(IPT).EQ.50) THEN 3563C 3564C GLOBAL SOLAR RADIATION DURING THE PRECEDING 24 H 3565C 3566 CALL EXTGRP(IPT,1,4,0,0,0,196,IRET) 3567 CALL NEXTPRT (IPT,IEQ) 3568 END IF 3569 IF(KCHAR(IPT).EQ.51) THEN 3570C 3571C DIFFUSED SOLAR RADIATION DURING PRECEDING 24 H 3572C 3573 CALL EXTGRP(IPT,1,4,0,0,0,198,IRET) 3574 CALL NEXTPRT (IPT,IEQ) 3575 END IF 3576 IF(KCHAR(IPT).EQ.52) THEN 3577C 3578C DOWNWARD LONG WAVE RADIATION DURING PRECEDING 24 H 3579C 3580 CALL EXTGRP(IPT,1,4,0,0,0,200,IRET) 3581 CALL NEXTPRT (IPT,IEQ) 3582 END IF 3583 IF(KCHAR(IPT).EQ.53) THEN 3584C 3585C UPWARD LONG WAVE RADIATION DURING PRECEDING 24 H 3586C 3587 CALL EXTGRP(IPT,1,4,0,0,0,202,IRET) 3588 CALL NEXTPRT (IPT,IEQ) 3589 END IF 3590 IF(KCHAR(IPT).EQ.54) THEN 3591C 3592C SHORT WAVE RADIATION DURING PRECEDING 24 H 3593C 3594C It is not unambiguous if radiation or precipitation 3595C group follow. Check if there are 2 6???? groups 3596 ippt=ipt 3597 call nextsep(ippt,ieq) 3598 call nextprt(ippt,ieq) 3599 if(kchar(ippt).eq.54) then 3600 CALL EXTGRP(IPT,1,4,0,0,0,204,IRET) 3601 CALL NEXTPRT (IPT,IEQ) 3602 end if 3603 END IF 3604 END IF 3605 IF (IC2.EQ.5.AND.IC3.EQ.3) THEN 3606 CALL EXTGRP(IPT,1,2,2,0,0,206,IRET) 3607 CALL NEXTPRT (IPT,IEQ) 3608C 3609C RADIATION DATA 3610C 3611 IF(KCHAR(IPT).EQ.48) THEN 3612C 3613C POSITIVE NET RADIATION DURING THE PREVIOUS HOUR 3614C 3615 CALL EXTGRP(IPT,1,4,0,0,0,209,IRET) 3616 CALL NEXTPRT (IPT,IEQ) 3617 END IF 3618 IF(KCHAR(IPT).EQ.49) THEN 3619C 3620C NEGATIVE NET RADIATION DURING THE PREVIOUS HOUR 3621C 3622 CALL EXTGRP(IPT,1,4,0,0,0,211,IRET) 3623 CALL NEXTPRT (IPT,IEQ) 3624 END IF 3625 IF(KCHAR(IPT).EQ.50) THEN 3626C 3627C GLOBAL SOLAR RADIATION DURING THE PREVIOUS HOUR 3628C 3629 CALL EXTGRP(IPT,1,4,0,0,0,213,IRET) 3630 CALL NEXTPRT (IPT,IEQ) 3631 END IF 3632 IF(KCHAR(IPT).EQ.51) THEN 3633C 3634C DIFFUSED SOLAR RADIATION DURING THE PREVIOUS HOUR 3635C 3636 CALL EXTGRP(IPT,1,4,0,0,0,215,IRET) 3637 CALL NEXTPRT (IPT,IEQ) 3638 END IF 3639 IF(KCHAR(IPT).EQ.52) THEN 3640C 3641C DOWNWARD LONG WAVE RADIATION DURING THE PREVIOUS HOUR 3642C 3643 CALL EXTGRP(IPT,1,4,0,0,0,217,IRET) 3644 CALL NEXTPRT (IPT,IEQ) 3645 END IF 3646 IF(KCHAR(IPT).EQ.53) THEN 3647C 3648C UPWARD LONG WAVE RADIATION DURING THE PREVIOUS HOUR 3649C 3650 CALL EXTGRP(IPT,1,4,0,0,0,219,IRET) 3651 CALL NEXTPRT (IPT,IEQ) 3652 END IF 3653 IF(KCHAR(IPT).EQ.54) THEN 3654C 3655C SHORT WAVE RADIATION DURING THE PREVIOUS HOUR 3656C 3657 CALL EXTGRP(IPT,1,4,0,0,0,221,IRET) 3658 CALL NEXTPRT (IPT,IEQ) 3659 END IF 3660 END IF 3661C 3662C IF ? IS 0,1,2,3 OR EEEIE (EVAPOTRANSPIRATION) 3663C 3664 IF(IC2.GE.0.AND.IC2.LE.3.OR.IC2.EQ.MINDIC) THEN 3665 CALL EXTGRP(IPT,1,3,1,0,0,181,IRET) 3666 CALL NEXTPRT (IPT,IEQ) 3667 END IF 3668C 3669C SKIP GROUP IF SECOND CHARACTER INVALID. 3670C 3671 IF(IC2.LT.0.OR.IC2.GT.9.AND.IC2.NE.MINDIC) THEN 3672 IPT = IPT + 5 3673 CALL NEXTPRT (IPT,IEQ) 3674 END IF 3675C 3676C INTERMEDIATE FORMAT ACCOMMODATES ONLY 1 3677C 5-GROUP . OVERWRITE IF A SECOND GROUP. 3678C 3679 IF ( KCHAR(IPT).EQ.53 ) GO TO 1050 3680C 3681 END IF 3682C 3683C 3684C CONVERT IF GROUP IDENTIFYING FIGURE IS 6 ( '6' = 54 ) 3685C 3686 IF (IPT.GE.IEQ) GO TO 3000 3687 IF ( KCHAR(IPT).EQ.54 ) 3688 C THEN 3689C 3690C 6 RRR TR 3691C 3692 CALL EXTGRP ( IPT,1,3,1,0,0,113,IRET ) 3693 CALL NEXTPRT ( IPT,IEQ ) 3694 END IF 3695C 3696C 3697C CONVERT IF GROUP IDENTIFYING FIGURE IS 7 ( '7' = 55 ) 3698C 3699 IF (IPT.GE.IEQ) GO TO 3000 3700 IF ( KCHAR(IPT).EQ.55 ) 3701 C THEN 3702C 3703C 7 R24R24R24R24 3704C 3705 CALL EXTGRP ( IPT,1,4,0,0,0,116,IRET ) 3706 CALL NEXTPRT ( IPT,IEQ ) 3707 END IF 3708C 3709C CONVERT IF GROUP IDENTIFYING FIGURE IS 8 ( '8' = 56 ) 3710C CAN ACCEPT UP TO 4 SUCH GROUPS. 3711C 3712 N = 121 3713 DO 1100 I=1,4 3714 IF (IPT.GE.IEQ) GO TO 3000 3715 IF ( KCHAR(IPT).EQ.56 ) 3716 C THEN 3717C 3718C 8 NS C HSHS 3719C 3720 CALL EXTGRP (IPT,1,1,1,2,0,N,IRET) 3721 N = N + 4 3722 CALL NEXTPRT (IPT,IEQ) 3723 END IF 3724 1100 CONTINUE 3725C 3726C 3727C CONVERT IF GROUP IDENTIFYING FIGURE IS 9 ( '9' = 57 ) 3728C CAN BE UP TO 4 SUCH GROUPS. 3729C 3730 N = 137 3731 DO 1200 I=1,4 3732 IF (IPT.GE.IEQ) GO TO 3000 3733 IF ( KCHAR(IPT).EQ.57 ) 3734 C THEN 3735C 3736C 9 SPSP SPSP 3737C 3738 CALL EXTGRP ( IPT,1,2,2,0,0,N,IRET ) 3739 N = N + 3 3740 CALL NEXTPRT ( IPT,IEQ ) 3741 END IF 3742 1200 CONTINUE 3743C 3744C 3745C 3746C 3747C*** 3748C* CONVERT SECTION 4. 3749C*** 3750C 3751 2000 IF (IPT.GE.IEQ) GO TO 3000 3752 IF (KCHAR(IPT).NE.52) 3753 C THEN 3754C 3755C NOT SECTION 4 3756C 3757 GO TO 3000 3758 ELSE 3759C 3760C 444 N' C' H'H' Ct 3761C 3762 CALL EXTINT (IPT,3,149) 3763 CALL NEXTPRT ( IPT,IEQ ) 3764 CALL EXTGRP (IPT,1,1,2,1,0,150,IRET) 3765 CALL NEXTPRT ( IPT,IEQ ) 3766 END IF 3767C 3768C 3769C*** 3770C* SECTION 5 . NATIONAL GROUPS NOT USED. 3771C*** 3772C 3773C ERROR IF NOT SECTION 5 AND NOT END OF REPORT. 3774C 3775 3000 IF (KCHAR(IPT).NE.53.AND.IPT.LT.IEQ) 3776 C THEN 3777 KERR = 0 3778 KCHAR(IEQ) = IOR(KCHAR(IEQ),128) 3779 IF (IFIRST.EQ.0) NOER(1,60) = NOER(1,60) + 1 3780 END IF 3781C 3782C 3783C*** 3784C* ERROR CHECKING AND HANDLING. 3785C*** 3786C 3787C RETURN IF NO ERROR IN REPORT. 3788C 3789 4000 IF ( KERR.EQ.0 ) RETURN 3790C 3791C IF FIRST DECODING ATTEMPT , TRY TO CORRECT ERROR AND DECODE 3792C AGAIN. 3793C 3794 IF ( IFIRST.EQ.0 ) THEN 3795 IPT = KEEP 3796 CALL FIXSM 3797 IFIRST = 1 3798 GO TO 10 3799 ELSE 3800 CALL SAVREP( IHEAD,IERR ) 3801C 3802C 3803C CLEAR PARITY BIT AFTER SAVING ERROR FILE 3804C 3805 DO 4100 I=KEEP,IGS 3806 KCHAR(I) = IAND(KCHAR(I) , 127) 38074100 CONTINUE 3808C 3809C ONLY REPORTS WITH ERROR IN DATE/TIME OR 3810C LAT/LONG ARE NOT PROCESSED FURTHER. 3811C 3812 IF (KERR.GT.4) KERR = 0 3813 RETURN 3814 END IF 3815C 3816 END 3817 SUBROUTINE FIXSM 3818C 3819C 3820C**** *FIXSM* 3821C 3822C 3823C PURPOSE. 3824C -------- 3825C 3826C 3827C *CALL* *FIXSM* 3828C 3829C METHOD. 3830C ------- 3831C 3832C NONE. 3833C 3834C 3835C EXTERNALS. 3836C ---------- 3837C 3838C NONE. 3839C 3840C REFERENCE. 3841C ---------- 3842C 3843C NONE. 3844C 3845C AUTHOR. 3846C ------- 3847C 3848C 3849C 3850C MODIFICATIONS. 3851C -------------- 3852C 3853C M. DRAGOSAVAC *ECMWF* AUG 1988. 3854C 3855C 3856 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 3857C 3858 INCLUDE 'parameter.h' 3859 INCLUDE 'comwork.h' 3860 INCLUDE 'comindx.h' 3861C 3862C ------------------------------------------------------------------ 3863C* 1. CLEAR PARITY BITS. 3864C ----------------- 3865 100 CONTINUE 3866C 3867 DO 101 I=IPT,IGS 3868 KCHAR(I) = IAND(KCHAR(I),127) 3869 101 CONTINUE 3870C 3871 ICOR = 0 3872C 3873 CALL REMEEE 3874C 3875C* TEST IF SEA STATION REPORT. 3876C 3877 IF ( KDEC(4).GT.14 ) GO TO 5000 3878C 3879C* CLEAR SPURIOUS SM CHARACTERS FROM KWBC REPORTS 3880C 3881C 3882 K = IPT + 10 3883 DO 200 I=IPT,K 3884 IF ( KCHAR(I).EQ.32.AND.KCHAR(I+1).EQ.83.AND.KCHAR(I+2). 3885 C EQ.77.AND.KCHAR(I+3).EQ.32) 3886 C THEN 3887C--- WRITE (*,9901) ICOR 3888C--- CALL PRTBULL (IPT,IEQ) 3889 KCHAR(I+1) = 32 3890 KCHAR(I+2) = 32 3891 ICOR = 1 3892 END IF 3893C 3894 200 CONTINUE 3895C 3896C 3897C* SOME CENTRES USE '333' GROUP IN THE FORM '333//' 3898C 3899C 3900 DO 250 I=IPT,IEQ 3901 IF ( KCHAR(I).EQ.51.AND.KCHAR(I+1).EQ.51.AND.KCHAR(I+2). 3902 C EQ.51.AND.KCHAR(I+3).EQ.47.AND.KCHAR(I+4).EQ.47) 3903 C THEN 3904C--- WRITE (*,9901) ICOR 3905C--- CALL PRTBULL (IPT,IEQ) 3906 KCHAR(I+3) = 32 3907 KCHAR(I+4) = 32 3908 ICOR = 1 3909 END IF 3910 250 CONTINUE 3911C 3912C 3913C* FIXUP COMMON ERRORS IN IIIII GROUP FROM LAND STATIONS. 3914C 3915C 3916C REMOVE EXTRA CHARACTER PRECEDING IIIII IN REPORTS FROM 3917C MXKF,AMMC,NZKL AND EESA. 3918C 3919 K = IPT+5 3920 DO 300 I=IPT,K 3921 IF ( KCHAR(I).GE.48.AND.KCHAR(I).LE.57) GO TO 350 3922 IF ( KCHAR(I).GE.65.AND.KCHAR(I).LE.90) GO TO 350 3923 IF (KCHAR(I).EQ.32) GO TO 300 3924C-- WRITE (*,9901) ICOR 3925C-- CALL PRTBULL (IPT,IEQ) 3926 ICOR = 2 3927 KCHAR(I) = 32 3928 300 CONTINUE 3929 350 IF (ICOR.EQ.2) CALL NEXTPRT (IPT,IEQ) 3930C 3931C ADD II OF 03 TO U.K. REPORTS FROM CENTRES OTHER THAN EGRR. 3932C 3933 K = IAH + 4 3934 CALL NEXTLET (K,JAH) 3935 IF (KCHAR(K).EQ.69.AND.KCHAR(K+1).EQ.71) 3936 C THEN 3937 IF (KCHAR(K+2).EQ.82.AND.KCHAR(K+3).EQ.82) 3938 C THEN 3939C---- WRITE (*,9901) ICOR 3940C---- CALL PRTBULL (IPT,IEQ) 3941 IPT = IPT - 2 3942 KCHAR(IPT) = 48 3943 KCHAR(IPT+1) = 51 3944 ICOR = 3 3945 END IF 3946 END IF 3947C 3948C 3949C REMOVE ANY EXTRA SHORT GROUPS BEFORE IIIII 3950C 3951 K = IPT 3952 CALL NEXTVAL (K,32,IEQ) 3953 K = K - IPT 3954 IF (K.LE.3) THEN 3955C-- WRITE (*,9901) ICOR 3956C-- CALL PRTBULL (IPT,IEQ) 3957 IPT = K+ IPT 3958 CALL NEXTPRT (IPT,IEQ) 3959 ICOR = 4 3960 END IF 3961C 3962C 3963C*** 3964C* COMMON FORMAT ERRORS IN REPORTS FROM SOUTH AMERICA 3965C AND AFRICA 3966C 3967C 3968 DO 400 K=IPT,IEQ 3969C 3970C $,],:,*,V OR ? INSTEAD OF = AT END OF REPORT 3971C IF ANY OF THESE CHARACTERS IS FOLLOWED BY LF IT IS 3972C REPLACED BY = . 3973C 3974 IF (KCHAR(K).EQ.36.OR.KCHAR(K).EQ.93.OR.KCHAR(K) 3975 C .EQ.58.OR.KCHAR(K).EQ.42.OR.KCHAR(K).EQ.86 3976 C .OR.KCHAR(K).EQ.63.AND.KCHAR(K+1).EQ.13) 3977 C THEN 3978C-- WRITE (*,9901) ICOR 3979C-- CALL PRTBULL (IPT,IEQ) 3980 KCHAR(K) = 61 3981 ICOR = 5 3982 END IF 3983C 3984C = SIGN MISSING AT END OF NIL REPORTS 3985C 3986 IF (KCHAR(K).EQ.76.AND.KCHAR(K+1).EQ.13) 3987 C THEN 3988C-- WRITE (*,9901) ICOR 3989C-- CALL PRTBULL (IPT,IEQ) 3990 KCHAR(K) = 61 3991 ICOR = 6 3992 END IF 3993C 3994C - INSTEAD OF SPACE 3995C 3996 IF (KCHAR(K).EQ.45) 3997 C THEN 3998C-- WRITE (*,9901) ICOR 3999C-- CALL PRTBULL (IPT,IEQ) 4000 KCHAR(K) = 32 4001 ICOR = 7 4002 END IF 4003C 4004C $ INSTEAD OF = 4005C 4006 IF (KCHAR(K).EQ.36) 4007 C THEN 4008C-- WRITE (*,9901) ICOR 4009C-- CALL PRTBULL (IPT,IEQ) 4010 KCHAR(K) = 61 4011 ICOR = 8 4012 END IF 4013C 4014C 4015 400 CONTINUE 4016C 4017C RESET POINTER TO END OF REPORT 4018C 4019 IEQ = IPT 4020 CALL NEXTEQ (IEQ,IGS) 4021C 4022C 4023C IF NO END OF REPORT HAS BEEN FOUND INSERT = AT END OF 4024C LINE . THIS ENSURES THAT AT LEAST SECTION 1 OF REPORTS IS 4025C DECODED. 4026C 4027C IF THE REPORT IS LONGER THAN 144 CHARACTERS = IS ALSO 4028C PRESUMED MISSING. 4029C 4030 LEN = IEQ - IABS(IPT) 4031C 4032 IF (IEQ.GE.IGS.OR.LEN.GE.144) 4033 C THEN 4034C-- WRITE (*,9901) ICOR 4035C-- CALL PRTBULL (IPT,IEQ) 4036 K = IPT 4037 CALL NEXTEND (K,IGS) 4038 IEQ = K 4039 KCHAR(K) = 61 4040 ICOR = 9 4041C 4042 END IF 4043C 4044C 4045C 4046C 4047 5000 CONTINUE 4048 IF (ICOR.EQ.0) RETURN 4049 IF (ICOR.EQ.3) RETURN 4050C-- CALL PRTBULL (IPT,IEQ) 4051C-- WRITE (*,9901)ICOR 4052C 4053 9901 FORMAT (1H ,'***************',I3,' *********************') 4054C 4055C 4056C 4057 RETURN 4058 END 4059 SUBROUTINE ICHWHW(IN,MINDIC,OUT) 4060C 4061C 4062C**** 4063C* 4064C* NAME : ICHWHW 4065C* 4066C* FUNCTION : DECODE THE HEIGHT OF WAVES IN DECIMETERS. 4067C* 4068C* INPUT : IN - CODE FIGURE FOR THE HEIGHT 4069C* : MINDIC - MISSING DATA VALUE 4070C* 4071C* OUTPUT : OUT - DECODED HEIGHT 4072C* 4073C* OUT IS SET TO MISSING VALUE 4074C* IF ANY ERRORS FOUND IN IN 4075C* 4076C**** 4077C 4078 INTEGER OUT 4079C 4080C*** SET MISSING VALUE 4081C 4082 OUT=MINDIC 4083C 4084 IF(IN .EQ. MINDIC) RETURN 4085C 4086 OUT=IN*5 4087C 4088 RETURN 4089 END 4090 SUBROUTINE IC2700(ICODE,ICOVER) 4091C 4092C 4093C**** *IC2700* 4094C 4095C 4096C PURPOSE. 4097C -------- 4098C TO CONVERT CODE TABLE 2700 INTO PERCENTAGE CLOUD COVERAGE. 4099C 4100C** INTERFACE. 4101C ---------- 4102C 4103C *CALL* *IC2700(ICODE,ICOVER)* 4104C 4105C METHOD. 4106C ------- 4107C 4108C NONE. 4109C 4110C 4111C EXTERNALS. 4112C ---------- 4113C 4114C NONE. 4115C 4116C REFERENCE. 4117C ---------- 4118C 4119C NONE. 4120C 4121C AUTHOR. 4122C ------- 4123C 4124C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 4125C 4126C 4127C MODIFICATIONS. 4128C -------------- 4129C 4130C NONE. 4131C 4132C 4133 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 4134C 4135 DIMENSION ICT(10),IPR(10) 4136 DATA ICT/ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9/ 4137 DATA IPR/ 0,10,25,40,50,60,75,90,100,113/ 4138C 4139C ------------------------------------------------------------------ 4140C* 1. CONVERT CLOUD COVERAGE IN OKTAS INTO PERCENTAGE. 4141C ------------------------------------------------ 4142 100 CONTINUE 4143C 4144 DO 101 I=1,10 4145C 4146 IF(ICODE.EQ.ICT(I)) THEN 4147 ICOVER=IPR(I) 4148 GO TO 200 4149 END IF 4150 101 CONTINUE 4151C 4152 ICOVER=999999 4153C 4154 200 CONTINUE 4155C 4156 RETURN 4157 END 4158 SUBROUTINE IC1751(ICODE,ICOVER) 4159C 4160C 4161C**** *IC1751* 4162C 4163C 4164C PURPOSE. 4165C -------- 4166C TO CONVERT CODE TABLE 1751 INTO BUFR TABLE 20033. 4167C 4168C** INTERFACE. 4169C ---------- 4170C 4171C *CALL* *IC1751(ICODE,ICOVER)* 4172C 4173C METHOD. 4174C ------- 4175C 4176C NONE. 4177C 4178C 4179C EXTERNALS. 4180C ---------- 4181C 4182C NONE. 4183C 4184C REFERENCE. 4185C ---------- 4186C 4187C NONE. 4188C 4189C AUTHOR. 4190C ------- 4191C 4192C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 4193C 4194C 4195C MODIFICATIONS. 4196C -------------- 4197C 4198C NONE. 4199C 4200C 4201 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 4202C 4203 DIMENSION ICT(5),IPR(5) 4204 DATA ICT/ 1, 2, 3, 4, 5/ 4205 DATA IPR/ 1, 2, 3, 4, 5/ 4206C 4207C ------------------------------------------------------------------ 4208C* 1. CONVERT CLOUD COVERAGE IN OKTAS INTO PERCENTAGE. 4209C ------------------------------------------------ 4210 100 CONTINUE 4211C 4212 DO 101 I=1,5 4213C 4214 IF(ICODE.EQ.ICT(I)) THEN 4215 ICOVER=IPR(I) 4216 GO TO 200 4217 END IF 4218 101 CONTINUE 4219C 4220 ICOVER=999999 4221C 4222 200 CONTINUE 4223C 4224 RETURN 4225 END 4226 SUBROUTINE IC3551(ICODE,ICOVER) 4227C 4228C 4229C**** *IC3551* 4230C 4231C 4232C PURPOSE. 4233C -------- 4234C TO CONVERT CODE TABLE 3551 INTO BUFR TABLE 20032. 4235C 4236C** INTERFACE. 4237C ---------- 4238C 4239C *CALL* *IC3551(ICODE,ICOVER)* 4240C 4241C METHOD. 4242C ------- 4243C 4244C NONE. 4245C 4246C 4247C EXTERNALS. 4248C ---------- 4249C 4250C NONE. 4251C 4252C REFERENCE. 4253C ---------- 4254C 4255C NONE. 4256C 4257C AUTHOR. 4258C ------- 4259C 4260C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 4261C 4262C 4263C MODIFICATIONS. 4264C -------------- 4265C 4266C NONE. 4267C 4268C 4269 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 4270C 4271 DIMENSION ICT( 5),IPR( 5) 4272 DATA ICT/ 0, 1, 2, 3, 4/ 4273 DATA IPR/ 0, 1, 2, 3, 4/ 4274C 4275C ------------------------------------------------------------------ 4276C* 1. CONVERT CLOUD COVERAGE IN OKTAS INTO PERCENTAGE. 4277C ------------------------------------------------ 4278 100 CONTINUE 4279C 4280 DO 101 I=1,5 4281C 4282 IF(ICODE.EQ.ICT(I)) THEN 4283 ICOVER=IPR(I) 4284 GO TO 200 4285 END IF 4286 101 CONTINUE 4287C 4288 ICOVER=999999 4289C 4290 200 CONTINUE 4291C 4292 RETURN 4293 END 4294 SUBROUTINE IC639(ICODE,ICOVER) 4295C 4296C 4297C**** *IC639* 4298C 4299C 4300C PURPOSE. 4301C -------- 4302C TO CONVERT CODE TABLE 639 INTO BUFR TABLE 20034. 4303C 4304C** INTERFACE. 4305C ---------- 4306C 4307C *CALL* *IC639(ICODE,ICOVER)* 4308C 4309C METHOD. 4310C ------- 4311C 4312C NONE. 4313C 4314C 4315C EXTERNALS. 4316C ---------- 4317C 4318C NONE. 4319C 4320C REFERENCE. 4321C ---------- 4322C 4323C NONE. 4324C 4325C AUTHOR. 4326C ------- 4327C 4328C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 4329C 4330C 4331C MODIFICATIONS. 4332C -------------- 4333C 4334C NONE. 4335C 4336C 4337 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 4338C 4339 DIMENSION ICT(10),IPR(10) 4340 DATA ICT/ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9/ 4341 DATA IPR/ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9/ 4342C 4343C ------------------------------------------------------------------ 4344C* 1. CONVERT CLOUD COVERAGE IN OKTAS INTO PERCENTAGE. 4345C ------------------------------------------------ 4346 100 CONTINUE 4347C 4348 DO 101 I=1,10 4349C 4350 IF(ICODE.EQ.ICT(I)) THEN 4351 ICOVER=IPR(I) 4352 GO TO 200 4353 END IF 4354 101 CONTINUE 4355C 4356 ICOVER=999999 4357C 4358 200 CONTINUE 4359C 4360 RETURN 4361 END 4362 SUBROUTINE ICPWPW(IN,MINDIC,OUT) 4363C 4364C 4365C**** 4366C* 4367C* NAME : ICPWPW 4368C* 4369C* FUNCTION : DECODE THE PERIOD OF WAVES IN SEC 4370C* 4371C* INPUT : IN - CODE FIGURE FOR THE PERIOD 4372C* : MINDIC - MISSING DATA VALUE 4373C* 4374C* OUTPUT : OUT - THE DECODED PERIOD 4375C* 4376C* OUT IS SET TO MISSING VALUE 4377C* IF ANY ERRORS FOUND IN IN 4378C* 4379C**** 4380C 4381 INTEGER OUT 4382C 4383C*** SET MISSING VALUE 4384C 4385 OUT=MINDIC 4386C 4387 IF(IN .EQ. MINDIC) RETURN 4388C 4389 OUT= IN 4390 IF(IN .EQ. 99) OUT=126 4391C 4392 RETURN 4393 END 4394 SUBROUTINE ICTRTR (ICOUNT,IREG,KTR,IHOURS,MINDIC,ITR) 4395C 4396C**** 4397C* 4398C* NAME : ICTRTR 4399C* 4400C* FUNCTION : DETERMINE DURATION OF RAINFALL . REGIONAL AND 4401C* NATIONAL PRACTICES ARE HANDLED. 4402C* 4403C* INPUT : IREG : WMO REGION NUMBER 4404C* ICOUNT : WMO COUNTRY NUMBER 4405C* KTR : CODE FIGURE FOR 'TR' 4406C* IHOURS : REPORT TIME (HOURS) 4407C* MINDIC : MISSING DATA VALUE 4408C* 4409C* OUTPUT : ITR : MEASUREMENT PERIOD FOR RAINFALL (HOURS) 4410C* 4411C* ITR IS SET TO MISSING VALUE 4412C* IF ANY ERRORS IN IREG OR IHOURS 4413C* 4414C*** 4415C 4416 DIMENSION IDURAT(28) 4417C 4418 DATA IDURAT / 6, 24, 6, 12, 12, -9, 12, -9, 4419 * 6, 6, 24, 6, 6, 6, 6, 6, 4420 C 24, 6, 6, 6, 6, 12, 6, 12, 4421 C 24, 6, 12, 18 / 4422C 4423C 4424C 4425C*** SET MISSING VALUE 4426C 4427 ITR=MINDIC 4428C 4429C 4430 IF (IREG.LT.1.OR.IREG.GT.7) RETURN 4431 IF(IHOURS .LT. 0 .OR. IHOURS .GT. 24) RETURN 4432C 4433C*** 4434C* VALID 'TR' CODE FIGURE REPORTED. 4435C*** 4436C 4437c IF (KTR.NE.MINDIC) THEN 4438c ITR = KTR * 6 4439c RETURN 4440c END IF 4441C 4442 if (ktr.ne.mindic) then 4443 if(ktr.ge.1.and.ktr.le.4) then 4444 ITR = KTR * 6 4445 RETURN 4446 elseif(ktr.eq.5) then 4447 itr=1 4448 elseif(ktr.eq.6) then 4449 itr=2 4450 elseif(ktr.eq.7) then 4451 itr=3 4452 elseif(ktr.eq.8) then 4453 itr=9 4454 elseif(ktr.eq.9) then 4455 itr=15 4456 elseif(ktr.eq.0) then 4457 itr=mindic 4458 else 4459 itr=mindic 4460 end if 4461 return 4462 end if 4463C 4464C*** 4465C* NO 'TR' FIGURE . GROUP MAY HAVE BEEN OMITTED BECAUSE RRR = 0 4466C* OR BECAUSE NATIONAL PRACTICE IS TO CODE A / . 4467C*** 4468C 4469C ARRAY IDURAT IS USED TO DEFINE THE PERIOD FOR 4470C DIFFERENT REGIONS AND DIFFERENT REPORT TIMES 4471C 4472C 4473C REGION I 00 & 12 Z 6 4474C 18 Z 12 4475C 06 Z 24 4476C REGION II 00 & 12 Z 12 4477C 06 & 18 Z MINDIC 4478C REGION III 00&06&12 Z 6 4479C 12 Z 24 4480C REGION IV ALL 6 4481C REGION V 00 Z 24 4482C 06&12&18 Z 6 4483C REGION VI 00 & 12 Z 6 4484C 06 & 18 Z 12 4485C 4486C 4487C SOME OBSERVATIONS ARE MADE + OR - 1 HOUR FROM STANDARD 4488C MAIN HOURS. 4489C 4490 K = IHOURS 4491 IF ( K.EQ.1.OR.K.EQ.23 ) K = 0 4492 IF ( K.EQ.7.OR.K.EQ.5 ) K = 6 4493 IF ( K.EQ.13.OR.K.EQ.11) K = 12 4494 IF ( K.EQ.19.OR.K.EQ.17) K = 18 4495C 4496C IND IS THE INDEX TO DEFINE THE REGION AND REPORT TIME 4497C 4498 IND=(IREG-1)*4 + K/6 +1 4499C 4500C 4501C SOME COUNTRIES IN REGION 2 HAVE NATIONAL PRACTICES. 4502C 4503 IF ( IREG.NE.2 ) THEN 4504 ITR = IDURAT(IND) 4505 RETURN 4506 END IF 4507C 4508C*** 4509C* REGION 2 NATIONAL PRACTICES. 4510C*** 4511C 4512C SAUDI ARABIA . 'TR' ALWAYS REPORTED AS / . PERIOD IS 12 HOURS. 4513C COUNTRY NUMBER IS 020 ( REGION 2 ). 4514C 4515 IF ( ICOUNT.EQ.20 ) THEN 4516 ITR = 12 4517 RETURN 4518 END IF 4519C 4520C CHINA . PERIOD IS ALWAYS 6 HOURS. 4521C COUNTRY NUMBER IS 250 ( REGION 2 ). 4522C 4523 IF ( ICOUNT.EQ.250 ) THEN 4524 ITR = 6 4525 RETURN 4526 END IF 4527C 4528C INDIA AND SRI LANKA . PERIOD IS FROM 0300. 4529C COUNTRY NUMBERS FOR INDIA ARE 100 AND 110 AND FOR SRI LANKA 120. 4530C 4531 IF ( ICOUNT.GE.100.AND.ICOUNT.LE.120 ) 4532 C THEN 4533 ITR = IHOURS - 3 4534 IF (ITR.LE.0) ITR = ITR + 24 4535 RETURN 4536 END IF 4537C 4538C*** 4539C* REGION 2 REGIONAL PRACTICE. 4540C*** 4541C 4542 IF(IDURAT(IND) .EQ. -9) RETURN 4543 ITR=IDURAT(IND) 4544C 4545 RETURN 4546 END 4547 SUBROUTINE IC0264(INA3,MINDIC,OUTA3) 4548C 4549C**** 4550C* 4551C* NAME : IC0264 4552C* 4553C* FUNCTION : DECODE THE INDICATOR OF STANDARD ISOBARIC 4554C* SURFACE A3 IN HECTOPASCAL 4555C* 4556C* INPUT : INA3 - CODE FIGURE FOR A3 4557C* MINDIC - MISSING DATA VALUE 4558C* 4559C* OUTPUT : OUTA3 - DECODED A3 4560C* 4561C* OUTA3 IS SET TO MISSING VALUE 4562C* IF ANY ERRORS FOUND IN INA3 4563C* 4564C**** 4565C 4566 INTEGER OUTA3 4567C 4568C*** SET MISSING VALUE 4569C 4570 OUTA3=MINDIC 4571C 4572 IF(INA3 .EQ. MINDIC) RETURN 4573 IF(INA3 .LE. 0 .OR. INA3 .GE. 9) RETURN 4574C 4575 GO TO (100,900,1000,1000,500,900,700,850) INA3 4576C 4577100 OUTA3=1000 4578 RETURN 4579C 4580500 OUTA3=500 4581 RETURN 4582C 4583700 OUTA3=700 4584 RETURN 4585C 4586850 OUTA3=850 4587 RETURN 4588C 4589900 OUTA3=925 4590 RETURN 4591C 45921000 RETURN 4593C 4594 END 4595 SUBROUTINE IC0700(INDD,MINDIC,OUTDD) 4596C 4597C 4598C**** 4599C* 4600C* NAME : IC0700 4601C* 4602C* FUNCTION : DECODE THE DIRECTION FROM WHICH SURF. WIND IS 4603C* BLOWING, OR THE DIRECTION OF THE SHIP (D,DS,...) 4604C* 4605C* INPUT : INDD - DIRECTION CODE FIGURE 4606C* MINDIC - MISSING DATA VALUE 4607C* 4608C* OUTPUT : OUTDD - DECODED DIRECTION IN DEGREES 4609C* 4610C* OUTDD IS SET TO MISSING VALUE 4611C* IF ANY ERRORS FOUND IN INDD 4612C* 4613C**** 4614C 4615 INTEGER OUTDD 4616C 4617C 4618 DIMENSION IDIR(9) 4619C 4620 DATA IDIR/0,45,90,135,180,225,270,315,360/ 4621C 4622C*** SET MISSING VALUE 4623C 4624 OUTDD=MINDIC 4625C 4626 IF(INDD .LT. 0 .OR. INDD .GT. 8) RETURN 4627C 4628 OUTDD=IDIR(INDD+1) 4629C 4630 RETURN 4631 END 4632 SUBROUTINE IC0777(IDD,ITEMP,MINDIC,IDEWPT) 4633C 4634C 4635C**** 4636C* 4637C* NAME : IC0777 4638C* 4639C* FUNCTION : DECODE DEW-POINT TEMPERATURE IN TENS OF DEGREE 4640C* 4641C* INPUT : IDD - DEW-POINT EPRESSION 4642C* : ITEMP - TEMPERATURE 4643C* : MINDIC - MISSING DATA VALUE 4644C* 4645C* OUTPUT : IDEWPT - DECODED DEW-POINT TEMPERATURE 4646C* 4647C* IDEWPT IS SET TO MISSING VALUE IF 4648C* ANY ERRORS FOUND IN IDD 4649C* 4650C* A.HOLOPAINEN JAN.83 4651C* 4652C**** 4653C 4654C 4655C 4656C*** CHECK MISSING DATA INDICATOR 4657C 4658 IF(IDD .EQ. MINDIC) RETURN 4659C 4660 IF(ITEMP .EQ. MINDIC) RETURN 4661C 4662C CHECK THE RANGE OF IDD 4663C 4664 IF(IDD .LT. 0 .OR. IDD .GT. 99) RETURN 4665C 4666 IF(IDD .GT. 51 .AND. IDD .LE. 55) RETURN 4667C 4668C 4669 IDEW=IDD 4670 IF(IDD .GE. 56) IDEW=10 * (IDD - 50) 4671C 4672 IDEWPT=ITEMP - IDEW 4673C 4674 RETURN 4675 END 4676 SUBROUTINE IC0877(IDD,IFF,IWW,ICOUNT,MINDIC,IDIR,ISPEED) 4677C 4678C 4679C**** 4680C* 4681C* NAME : IC0877 4682C* 4683C* FUNCTION : DECODE WIND DIRECTION AND SPEED 4684C* 4685C* INPUT : IDD - WIND DIRECTION IN TENS OF DEGREE 4686C* : IFF - WIND SPEED 4687C* : IWW - WIND SPEED INDICATOR , CODE TABLE 1855 4688C* : ICOUNT - COUNTRY NUMBER 4689C* : MINDIC - MISSING DATA VALUE 4690C* 4691C* OUTPUT : IDIR - DECODED WIND DIRECTION 4692C* ISPEED - DECODED WIND SPEED 4693C* 4694C* IDIR AND ISPEED ARE SET TO MISSING VALUE IF 4695C* ANY ERRORS FOUND IN IDD, IFF OR IWW 4696C* 4697C**** 4698C 4699C*** SET MISSING VALUE 4700C 4701 IDIR=MINDIC 4702 ISPEED=MINDIC 4703C 4704C 4705C 4706C*** CHECK MISSING DATA INDICATOR 4707C 4708 IF(IWW .EQ. MINDIC .OR. IDD .EQ. MINDIC .OR. 4709 1 IFF .EQ. MINDIC) RETURN 4710C 4711C CHECK IF WIND INDICATOR IR IS CORRECT 4712C 4713 IF(IWW .NE. 0 .AND. IWW .NE. 1 .AND. IWW .NE. 3 4714 1 .AND. IWW .NE. 4) RETURN 4715C 4716C 4717C IW IS THE MODIFIED WIND SPEED INDICATOR TO MAKE 4718C IF-STATEMENTS SHORTER 4719C IW=0 FOR METER/SEC 4720C IW=1 FOR KNOTS 4721C 4722 IW=(IWW-1)/2 4723 ISPEED=IFF 4724 IDIR=IDD 4725C 4726C 4727C CHECK IF DD=99 .I.E. DIRECTION INDETERMINATE 4728C 4729C 4730C CHECK IF DD INDICATOR IS SENSIBLE 4731C 4732 IF(IDIR .GT. 36 .AND. IDIR .LT. 50) RETURN 4733 IF(IDIR .GT. 86 .AND. IDIR .NE. 99) RETURN 4734C 4735C CHECK IF SHIP OR BUOY, BECAUSE THEN THERE IS NO COUNT NUMBER 4736C 4737 IF(ICOUNT .EQ. MINDIC) 4738 * THEN 4739 IF(IDIR .GT. 50 .AND. IDIR .NE. 99) ISPEED=ISPEED+100 4740 GO TO 100 4741 END IF 4742C 4743C 4744C CHECK IF THE DATA IS FROM U.S.S.R. 4745C 4746 IF(ICOUNT .EQ. 6310 .OR. ICOUNT .EQ. 2010) 4747 1 THEN 4748 IF(ISPEED .EQ. 77) ISPEED=20 4749 IF(ISPEED .EQ. 88) ISPEED=40 4750 ELSE 4751 IF(IDIR .GT. 50 .AND. IDIR .NE. 99) ISPEED=ISPEED+100 4752 END IF 4753C 4754100 CONTINUE 4755C 4756C IF SPEED IN KNOTS MODIFY TO M/S 4757C 4758 IF(IW .EQ. 1) CALL KTOMPSI(ISPEED) 4759 IF(IDIR .GT. 50 .AND. IDIR .NE. 99) IDIR=IDIR-50 4760 IF(IDIR .EQ. 99) IDIR=0 4761C 4762 IDIR=IDIR*10 4763C 4764 RETURN 4765 END 4766 SUBROUTINE IC1600(INHEI,LOWEST,MINDIC,OUTHEI) 4767C 4768C 4769C**** 4770C* 4771C* NAME : IC1600 4772C* 4773C* FUNCTION : DECODE THE HEIGHT OF LOWEST CLOUDS 4774C* 4775C* INPUT : INHEI - CODE FIGURE FOR THE HEIGHT 4776C* LOWEST - INDICATOR FOR LOWEST CLOUD 4777C* 0 = LOW CLOUD 4778C* 1 = MEDIUM CLOUD 4779C* 2 = HIGH CLOUD 4780C* MINDIC - MISSING DATA VALUE 4781C* 4782C* OUTPUT : OUTHEI - DECODED HEIGHT OF LOWEST CLOUDS IN METRES 4783C* 4784C* OUTHEI SET TO MISSING VALUE 4785C* IF ANY ERRORS FOUND IN INHEI 4786C* 4787C**** 4788C 4789 INTEGER OUTHEI 4790C 4791 DIMENSION IHEIGHT(12) 4792C 4793 DATA IHEIGHT/25,75,150,250,450,800,1250,1750,2250,2600,3500,8000/ 4794C 4795C*** SET MISSING VALUE 4796C 4797 OUTHEI=MINDIC 4798C 4799C*** TEST THE VALIDITY OF THE CODE FIGURE 4800C 4801 IF(INHEI .EQ. MINDIC .OR. LOWEST .EQ. MINDIC) RETURN 4802C 4803 IF(INHEI .LT. 0 .OR. INHEI .GT. 9) RETURN 4804C 4805C 4806C FOR N = 9 DEFAULT HEIGHTS ARE ALLOCATED DEPENDING ON 4807C WHETHER LOWEST CLOUD IS LOW, MEDIUM OR HIGH. 4808C 4809 IF ( INHEI.NE.9 ) LOWEST = 0 4810C 4811 IND=INHEI + 1 + LOWEST 4812 OUTHEI=IHEIGHT(IND) 4813 RETURN 4814 END 4815 SUBROUTINE IC1677(ICODE,MINDIC,IHEIGHT) 4816C 4817C 4818C**** 4819C* NAME : IC677 4820C* 4821C* FUNCTION : DECODE THE HEIGHT OF THE BASE OF THE 4822C* LOWEST CLOUD HH OR HSHS 4823C* 4824C* INPUT : ICODE CODE NUMBER FOR THE HEIGHT 4825C* MINDIC MISSING DATA VALUE 4826C* 4827C* OUTPUT : IHEIGHT DECODED HEIGHT IN METRES 4828C* 4829C* IHEIGHT SET TO MISSING VALUE 4830C* IF ANY ERRORS FOUND IN ICODE 4831C* 4832C**** 4833C 4834 DIMENSION IHSHS(9) 4835C 4836 DATA IHSHS/25,75,150,250,450,800,1250,1750,2250/ 4837C 4838C 4839C*** SET MISSING VALUE 4840C 4841 IHEIGHT=MINDIC 4842C 4843 IF(ICODE .LT. 0 .OR. ICODE .GT. 98) RETURN 4844C 4845C 4846C 4847 IF(ICODE .EQ. 89) THEN 4848 IHEIGHT=22000 4849 RETURN 4850 END IF 4851C 4852 IF(ICODE .LE. 50) THEN 4853 IHEIGHT=ICODE*30 4854 IF(IHEIGHT .LT. 0) IHEIGHT=0 4855 RETURN 4856 END IF 4857C 4858 IF(ICODE .GE. 56 .AND. ICODE .LE. 80) THEN 4859 IHEIGHT=(ICODE-50)*300 4860 RETURN 4861 END IF 4862C 4863 IF(ICODE .GE. 81 .AND. ICODE .LE. 88) THEN 4864 IHEIGHT=(ICODE-80)*1500+ 9000 4865 RETURN 4866 END IF 4867C 4868C CODE VALUE 99 IS NOT USED FOR HH, ONLY FOR HSHS 4869C AND FOR TIME BEING 99 IS NOT DECODED AT ALL. 4870C 4871 IF(ICODE .GE. 90) THEN 4872 IND=ICODE-89 4873 IHEIGHT=IHSHS(IND) 4874 RETURN 4875 END IF 4876C 4877C 4878 END 4879 SUBROUTINE IC3590(INPRE,NILPRE,MINDIC,OUTPRE) 4880C 4881C 4882C**** 4883C* 4884C* NAME : IC3590 4885C* 4886C* FUNCTION : DECODE THE AMOUNT OF PRECIPITATION 4887C* 4888C* INPUT : INPRE - PRECIPITATION CODE FIGURE 4889C* NILPRE - INDICATOR FOR 'NIL' PRECIPITATION 4890C* MINDIC - MISSING DATA VALUE 4891C* 4892C* OUTPUT : OUTPRE - DECODED PRECIPITATION IN TENTHS OF MM 4893C* 4894C* OUTPRE SET TO MISSING VALUE 4895C* IF ANY ERRORS FOUND IN INPRE 4896C* 4897C**** 4898C 4899 INTEGER OUTPRE 4900C 4901C*** SET MISSING VALUE 4902C 4903 OUTPRE=MINDIC 4904C 4905C*** 4906C* TEST IF 'NILPRE' ( IR , CODE TABLE 1819 ) INDICATES THAT 4907C* PRECIPATION GROUP IS OMITTED BECAUSE RRR = 0 . 4908C*** 4909C 4910 IF ( NILPRE.EQ.3 ) OUTPRE = 0 4911C 4912C IR IS FREQUENTLY MISCODED SO AMOUNT OF RRR REPORTED IS ALSO 4913C EXAMINED BEFORE RETURNING. 4914C 4915 IF ( INPRE.EQ.MINDIC ) RETURN 4916C 4917C 4918 IF(INPRE .LE. 989) THEN 4919 OUTPRE=INPRE*10 4920 RETURN 4921 END IF 4922C 4923 IF(INPRE .GE. 990 .AND. INPRE .LE. 999) THEN 4924 OUTPRE=INPRE-990 4925C 4926C Check if trace of rain 26/08/1998 4927C 4928 IF(OUTPRE.EQ.0) OUTPRE=-1 4929 RETURN 4930 END IF 4931C 4932 RETURN 4933 END 4934 SUBROUTINE IC3845(INTEMP,ISIGN,ICOUNT,IREG,MINDIC,OUTTEMP) 4935C 4936C**** 4937C* 4938C* NAME : IC3845 4939C* 4940C* FUNCTION : DECODE THE TEMPERATURE 4941C* 4942C* INPUT : INTEMP TEMPERATURE VALUE 4943C* ISIGN SIGN INDICATOR FOR TEMPERATURE 4944C* 0 = NOT NEGATIVE, 1 = NEGATIVE 4945C* ICOUNT COUNTRY NUMBER. 4946C* IREG REGION NUMBER. 4947C* MINDIC MISSING DATA VALUE 4948C* 4949C* OUTPUT : OUTTEMP OUTPUT TEMPERATURE WITH CORRECT SIGN 4950C* 4951C* OUTTEMP IS SET TO MISSING VALUE 4952C* IF ANY ERRORS FOUND IN INTEMP 4953C* 4954C**** 4955C 4956 INTEGER OUTTEMP 4957C 4958C*** SET MISSING VALUE 4959C 4960 OUTTEMP=MINDIC 4961C 4962C 4963C TEST FOR MISSING DATA AND VALIDITY OF SIGN 4964C 4965 IF(INTEMP .EQ. MINDIC .OR. ISIGN .EQ. MINDIC) RETURN 4966 IF(ISIGN .LT. 0 .OR. ISIGN .GT. 1) RETURN 4967C 4968 OUTTEMP=INTEMP 4969 IF(ISIGN .EQ. 1) OUTTEMP = -1*OUTTEMP 4970C 4971 RETURN 4972C TEMPERATURE IS GIVEN IN FAHRENEIT IN CUBA,NICARAGUA AND PANAMA 4973C ( REGION 4 COUNTRY NUMBERS 70,170 AND 190 ) AND HAS TO BE 4974C CONVERTED TO CELSIUS. 4975C 4976C IF ( IREG.NE.4 ) RETURN 4977C IF ( ICOUNT.NE.70.AND.ICOUNT.NE.170.AND.ICOUNT.NE.190) RETURN 4978C CALL FTOC2 ( OUTTEMP ) 4979C 4980C 4981C RETURN 4982 END 4983 SUBROUTINE IC3931(ITA,ITT,MINDIC,ITEMP) 4984C 4985C 4986C**** 4987C* 4988C* NAME : IC3931 4989C* 4990C* FUNCTION : DECODE TEMPERARURE IN TENTHS OF DEGREE 4991C* 4992C* INPUT : ITA - APPROXIMATE TENTHS VALUE AND SIGN BIT 4993C* : ITT - TENS AND UNIT DIGITS OF TEMPERATURE 4994C* : MINDIC - MISSING DATA VALUE 4995C* 4996C* OUTPUT : ITEMP - DECODED TEMPERATURE 4997C* 4998C* 4999C* A.HOLOPAINEN JAN.83 5000C* 5001C**** 5002C 5003C 5004C 5005C*** CHECK MISSING VALUES 5006C 5007 IF(ITA .EQ. MINDIC .OR. ITT .EQ. MINDIC) RETURN 5008C 5009C CHECK THE RANGE OF ITA 5010C 5011 IF(ITA .LT. 0 .OR. ITA .GT. 9) RETURN 5012C 5013C POSITIVE TEMPERATURE 5014C 5015 IVA=2*(ITA/2) 5016 IF(IVA .EQ. ITA) THEN 5017 ITEMP = 10 * ITT + ITA 5018 RETURN 5019 END IF 5020C 5021C NEGATIVE TEMPERATURE 5022C 5023 ITEMP = -10 * ITT - ITA 5024 RETURN 5025 END 5026 SUBROUTINE IC4377(INVIS,MINDIC,OUTVIS) 5027C 5028C 5029C**** 5030C* 5031C* NAME : IC4377 5032C* 5033C* FUNCTION : DECODE HORIZONTAL VISIBILITY AT SURFACE VV 5034C* 5035C* INPUT : INVIS -VISIBILITY CODE FIGURE 5036C* MINDIC - MISSING DATA VALUE 5037C* 5038C* OUTPUT : OUTVIS -DECODED VISIBILITY IN METRES 5039C* 5040C* OUTVIS IS SET TO MISSING DATA VALUE 5041C* IF ANY ERRORS FOUND IN INVIS 5042C* 5043C**** 5044C 5045C 5046C 5047 INTEGER OUTVIS 5048 DIMENSION IVISIB(9) 5049C 5050 DATA IVISIB /50,200,500,1000,2000,4000,10000,20000,55000/ 5051C 5052C*** SET OUTVIS TO MISSING VALUE 5053C 5054 OUTVIS=MINDIC 5055C 5056 IF(INVIS .EQ. MINDIC) RETURN 5057 IF(INVIS .GE. 51 .AND. INVIS .LE. 55) RETURN 5058 IF(INVIS .LT. 0 .OR. INVIS .GT. 99) RETURN 5059C 5060 IF(INVIS .EQ. 89) THEN 5061 OUTVIS=75000 5062 RETURN 5063 END IF 5064C 5065 IF(INVIS .EQ. 90) THEN 5066 OUTVIS=25 5067 RETURN 5068 END IF 5069C 5070 IF(INVIS .EQ. 0) THEN 5071 OUTVIS=50 5072 RETURN 5073 END IF 5074C 5075C 5076 IF(INVIS .GE. 1 .AND. INVIS .LE. 50) 5077 1 THEN 5078 OUTVIS=100 * INVIS 5079 RETURN 5080 END IF 5081C 5082 IF(INVIS .GE. 56 .AND. INVIS .LE. 80) 5083 1 THEN 5084 OUTVIS=(INVIS - 50) * 1000 5085 RETURN 5086 END IF 5087C 5088 IF(INVIS .GE. 81 .AND. INVIS .LE. 88) 5089 1 THEN 5090 OUTVIS=(INVIS - 80) * 5000 + 30000 5091 RETURN 5092 END IF 5093C 5094 IF(INVIS .GE. 91 .AND. INVIS .LE. 99) 5095 1 THEN 5096 IND=INVIS-90 5097 OUTVIS=IVISIB(IND) 5098 RETURN 5099 END IF 5100C 5101C 5102 RETURN 5103 END 5104 SUBROUTINE IC4451(INVS,MINDIC,OUTVS) 5105C 5106C 5107C**** 5108C* 5109C* NAME : IC4451 5110C* 5111C* FUNCTION : DECODE SHIPS AVERAGE SPEED VS 5112C* 5113C* INPUT : INVS - SPEED CODE FIGURE 5114C* MINDIC - MISSING DATA VALUE 5115C* 5116C* OUTPUT : OUTVS - DECODED SPEED M/S 5117C* 5118C* 5119C* IF ANY ERRORS FOUND IN INVS 5120C* 5121C**** 5122C 5123 INTEGER OUTVS 5124C 5125 DIMENSION ISPEED(10) 5126C 5127 DATA ISPEED/0,1,4,7,9,12,14,17,20,22/ 5128C 5129C*** SET MISSING VALUE 5130C 5131 OUTVIS = MINDIC 5132C 5133 IF(INVS .LT. 0 .OR. INVS .GT. 9) RETURN 5134C 5135 OUTVS=ISPEED(INVS+1) 5136C 5137 RETURN 5138 END 5139 SUBROUTINE MARDSEN(LAT,LONG,M,IERROR) 5140C 5141C 5142C**** *MARDSEN* 5143C 5144C 5145C PURPOSE. 5146C -------- 5147C 5148C CHECK THE LAT&LONG AGAINST MARDSEN SQUARE 5149C 5150C 5151C 5152C** INTERFACE. 5153C ---------- 5154C 5155C *CALL* *MARDSEN(LAT,LONG,M,IERROR)* 5156C 5157C INPUT : LATITUDE IN HUNDREDTH'S OF DEGREE 5158C LONGITUDE IN HUNDREDTH'S OF DEGREE 5159C M - MARDSEN SQUARE VALUE GIVEN IN REPORT 5160C 5161C OUTPUT : IERROR - ERROR INDICATOR 5162C 5163C 5164C 5165C 5166C METHOD. 5167C ------- 5168C 5169C NONE. 5170C 5171C 5172C EXTERNALS. 5173C ---------- 5174C 5175C *XXXX* *XXXXXXX(XXXX)* 5176C 5177C REFERENCE. 5178C ---------- 5179C 5180C NONE. 5181C 5182C AUTHOR. 5183C ------- 5184C 5185C A. HOLOPAINEN JUNE -84 5186C 5187C 5188C MODIFICATIONS. 5189C -------------- 5190C 5191C M. DRAGOSAVAC *ECMWF* AUG 1988. 5192C 5193C 5194 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 5195C 5196C 5197C 5198C ------------------------------------------------------------------ 5199C 5200C* 1. CHECK POSITION. 5201C --------------- 5202 100 CONTINUE 5203C 5204C 5205 IERROR = 0 5206 LOLO = LONG 5207C 5208C DON'T CHECK IF POSITION ON THE LINE BETWEEN TWO (OR FOUR) SQUARES 5209C 5210 LAA = 1000*(LAT/1000) 5211 LOO = 1000*(LONG/1000) 5212C 5213 IF(LAA .EQ. LAT) RETURN 5214 IF(LOO .EQ. LONG) RETURN 5215C 5216 LAT = LAT /10 5217 LONG= LONG/10 5218C 5219C 5220 IF(LAT .GE. 0) 5221 C THEN 5222 LO = IABS(LONG/100)+1 5223 IF(LOLO .GE. 0) LO = 37 - LO 5224C 5225 IF( LAT .LT. 800 ) 5226 C THEN 5227 MMM = (LAT/100)*36 + LO 5228 ELSE 5229 MMM = 900 + LO 5230 END IF 5231 END IF 5232C 5233C 5234 IF(LAT .LT. 0) 5235 C THEN 5236 LO = IABS( LONG/100 ) 5237 IF(LOLO .GE. 0) LO = 35 - LO 5238 MMM = 300 + IABS( LAT/100 )*36 +LO 5239 END IF 5240C 5241 IF(MMM .NE. M) IERROR = 1 5242C 5243 RETURN 5244C 5245 END 5246 SUBROUTINE IC3333(IQUADR,LAT,LONG,MINDIC,LAT2,LONG2) 5247C 5248C 5249C**** 5250C* 5251C* NAME : IC3333 5252C* 5253C* FUNCTION : DECODE LATITUDE AND LONGITUDE GIVEN IN THE FORM 5254C* 99LALALA QCL0L0L0L0 5255C* 5256C* INPUT : IQUADR THE QUADRANT OF THE GLOBE (QC) 5257C* : LAT LATITUDE IN TENTHS OF DEGREE 5258C* : LONG LONGITUDE IN TENTHS OF DEGREE 5259C* : MINDIC MISSING DATA VALUE 5260C* 5261C* 5262C* OUTPUT : LAT2 LATITUDE IN HUNDREDTHS OF DEGREE 5263C* SOUTHERN LATITUDE NEGATIVE 5264C* : LONG2: LONGITUDE IN HUNDREDTHS OF DEGREE 5265C* WESTERN LONGITUDE NEGATIVE 5266C* 5267C* LAT2 AND LONG2 ARE SET TO MISSING DATA VALUE IF 5268C* ANY ERRORS FOUND IN LAT,LONG OR QUADRANT 5269C* 5270C**** 5271C 5272C 5273 DIMENSION LATSIGN(4),LONSIGN(4) 5274C 5275 DATA LATSIGN/ 1,-1,-1, 1/ 5276 DATA LONSIGN/ 1, 1,-1,-1/ 5277C 5278C*** SET LAT2 AND LONG2 TO MISSING DATA VALUE 5279C 5280 LAT2=MINDIC 5281 LONG2=MINDIC 5282C 5283C 5284C THE ARRAYS LATSIGN AND LONSIGN ARE USED TO DETERMINE IF 5285C LAT. AND LONG. ARE NEGATIVE OR POSITIVE 5286C 5287C CHECK THAT THE QUADRANT IS CORRECT 5288C 5289 IF(IQUADR .NE. 1 .AND. IQUADR .NE. 3 .AND. IQUADR .NE. 5290 1 5 .AND. IQUADR .NE. 7) RETURN 5291C 5292C CHECK THAT THE LATITUDE AND LONGITUDE ARE SENSIBLE 5293C 5294 IF(LAT .LT. 0 .OR. LAT .GT. 900) RETURN 5295C 5296 IF(LONG .LT. 0 .OR. LONG .GT. 1800) RETURN 5297C 5298C 5299 IQ=(IQUADR+1)/2 5300C 5301 LAT2=10*LAT*LATSIGN(IQ) 5302 LONG2=10*LONG*LONSIGN(IQ) 5303C 5304 RETURN 5305C 5306C 5307 END 5308 SUBROUTINE STATION(IERR) 5309 5310C 5311C**** *STATION* 5312C 5313C 5314C PURPOSE. 5315C -------- 5316C READ IN STATION LIST AND MAKE LIST OF IMPORTANT STATIONS. 5317C ( WMO VOLUMEN A - LIST OF OBSERVING STATIONS) 5318C 5319C** INTERFACE. 5320C ---------- 5321C 5322C *CALL* *STATION(IERR)* 5323C 5324C METHOD. 5325C ------- 5326C 5327C NONE. 5328C 5329C 5330C EXTERNALS. 5331C ---------- 5332C 5333C *CALL* *IMPSTAT* 5334C 5335C REFERENCE. 5336C ---------- 5337C 5338C NONE. 5339C 5340C AUTHOR. 5341C ------- 5342C 5343C M. DRAGOSAVAC *ECMWF* AUG 1988. 5344C 5345C 5346C MODIFICATIONS. 5347C -------------- 5348C 5349C NONE. 5350C 5351C 5352 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 5353C 5354 INCLUDE 'combuff.h' 5355 include 'combase.h' 5356 character*256 cf 5357C 5358C ------------------------------------------------------------------ 5359C* 1. READ IN STATION LIST. 5360C --------------------- 5361 100 CONTINUE 5362C 5363 i=index(cppbase,' ') 5364 i=i-1 5365 5366 cf=' ' 5367 cf=cppbase(1:i)//'/dat/station_list.dat' 5368 i=index(cf,' ') 5369 i=i-1 5370c 5371 OPEN(UNIT=4,IOSTAT=IOS,ERR=300, 5372 1 FILE=cf(1:i), 5373 1 STATUS='OLD', 5374 1 FORM='UNFORMATTED') 5375C 5376C 5377 READ(4) IPARAMS,IPOINTS 5378C 5379 CLOSE(4) 5380C 5381C 5382C* 2. FIND IMPORTANT STATIONS. 5383C ------------------------ 5384 200 CONTINUE 5385C 5386 CALL IMPSTAT 5387C 5388 RETURN 5389C 5390 300 CONTINUE 5391C 5392 WRITE(*,9901) IOS 5393 9901 FORMAT(1H ,' ERROR DURING OPENING STATION FILE , ERROR=',I5) 5394C 5395C 5396 RETURN 5397 END 5398 SUBROUTINE IMPSTAT 5399C 5400C 5401C**** *IMPSTAT* 5402C 5403C 5404C PURPOSE. 5405C -------- 5406C 5407C DEFINES FROM WMO MASTER FILE THE SATION NUMBERS 5408C FOR IMPORTANT STATIONS (ECMWF INTERNAL DEFINOTIONS) 5409C 5410C 5411C 5412C** INTERFACE. 5413C ---------- 5414C 5415C *CALL* *IMPSTAT* 5416C 5417C INPUT : IPARAMS STATION INFORMATION IN PACKED FORM 5418C IPOINTS NUMBER OF STATION / WMO BLOCK 5419C 5420C OUTPUT : IMPSTA THE NUMBERS OF IMPORTATNT SATIONS 5421C 5422C METHOD. 5423C ------- 5424C 5425C NONE. 5426C 5427C 5428C EXTERNALS. 5429C ---------- 5430C 5431C NONE. 5432C 5433C REFERENCE. 5434C ---------- 5435C 5436C NONE. 5437C 5438C AUTHOR. 5439C ------- 5440C 5441C 5442C 5443C MODIFICATIONS. 5444C -------------- 5445C 5446C M. DRAGOSAVAC *ECMWF* AUG 1988. 5447C 5448C 5449 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 5450C 5451 INCLUDE 'parameter.h' 5452 INCLUDE 'comwork.h' 5453 INCLUDE 'combuff.h' 5454C 5455C 5456C ------------------------------------------------------------------ 5457C* 1. FIND IMPORTANT STATIONS. 5458C ------------------------ 5459C 5460 J = 0 5461 K = 1 5462C 5463C 5464 DO 300 I = 1,26000,2 5465C 5466 IF(IPARAMS(I) .EQ. MINDIC) GO TO 400 5467 IF(I .LT. IPOINTS(K+1)) GO TO 200 5468C 5469100 K = K + 1 5470 IF(K .GE. 99) GO TO 400 5471 IF(IPOINTS(K) .EQ. IPOINTS(K+1)) GO TO 100 5472C 5473200 CONTINUE 5474C 5475 CALL GBYTE(IPARAMS(I+1),ITEMP,28,1) 5476 CALL GBYTE(IPARAMS(I+1),IBIT ,25,1) 5477C 5478 IF(ITEMP .EQ. 1 .AND. IBIT .EQ. 1) 5479 C THEN 5480 CALL GBYTE(IPARAMS(I),III,0,10) 5481 ISTA= 1000*K+ III 5482 IF(J .NE. 0) 5483 C THEN 5484 DO 250 N=1,J 5485 IF(ISTA .EQ. IMPSTA(N)) GO TO 300 5486250 CONTINUE 5487 END IF 5488 J = J + 1 5489 IF(J.GT.4000) THEN 5490 PRINT*,'DIMENSION IF IMPSTA TOO SMALL' 5491 GO TO 400 5492 END IF 5493C 5494 IMPSTA(J) = ISTA 5495 END IF 5496C 5497300 CONTINUE 5498C 5499C 5500400 CONTINUE 5501C 5502500 CONTINUE 5503C 5504 RETURN 5505 END 5506 5507 SUBROUTINE LOCSTAT(IWIND,IRC) 5508C 5509C**** *LOCSTAT* 5510C 5511C 5512C PURPOSE. 5513C -------- 5514C 5515C EXTRACT PARTICULARS OF WMO OBSERVING STATIONS AND 5516C PUT IN DECODED REPORT HEADER. 5517C 5518C 5519C 5520C** INTERFACE. 5521C ---------- 5522C 5523C *CALL* *LOCSTAT(IWIND,IRC)* 5524C 5525C INPUT : ARGUMENTS NOT USED ON INPUT . 5526C 5527C KINT(4) - WMO STATION NUMBER IN INTEGER. 5528C KDEC(4) - INTEGER DENOTING OBSERVATION TYPE. 5529C 5530C OUTPUT : KDEC(5) - LATITUDE IN HUNDREDTHS OF DEGREES , 5531C NORTH + , SOUTH - . 5532C KDEC(6) - LONGITUDE IN HUNDREDTHS OF DEGREES , 5533C EAST + , WEST - . 5534C KDEC(8) - STATION PRESSURE ELEVATION (H/P) OR IF 5535C NONE EXISTS STATION GROUND ELEVATION (H/A). 5536C IF NEITHER EXIST MINDIC IS RETURNED . VALUE 5537C IS INTEGER IN METRES. 5538C 5539C KDEC(15) - IMPORTANT STATION OR GOOD QUALITY STATION 5540C FLAG BITS SET IN THIS WORD. 5541C 5542C KDEC(16) - WMO COUNTRY NUMBER , EXCLUDING FIRST 2 5543C DIGITS ( REGION NUMBER ) . INTEGER. 5544C KDEC(17) - WMO REGION NUMBER , INTEGER. 5545C 5546C KDEC(23) - PRESSURE LEVEL INDICATOR , INTEGER. 5547C 0 = SEA LEVEL 5548C 1 = STATION LEVEL 5549C 2 = 850 HPA 5550C 3 = 700 HPA 5551C 4 = 500 HPA 5552C 5 = 1000 GPM 5553C 6 = 2000 GPM 5554C 7 = 3000 GPM 5555C 8 = 4000 GPM 5556C 9 = 900 HPA 5557C 5558C IRC - INTEGER RETURN CODE 5559C 0 = NO ERROR 5560C 1 = STATION NUMBER NOT IN DIRECTORY 5561C 2 = INVALID STATION NUMBER 5562C 3 = INVALID OBSERVATION TYPE 5563C 5564C 5565C METHOD. 5566C ------- 5567C 5568C NONE. 5569C 5570C 5571C EXTERNALS. 5572C ---------- 5573C 5574C *CALL* *GBYTE(KS,KD,KBPT,KSI)* 5575C 5576C REFERENCE. 5577C ---------- 5578C 5579C NONE. 5580C 5581C AUTHOR. 5582C ------- 5583C 5584C M. DRAGOSAVAC 5585C 5586C MODIFICATIONS. 5587C -------------- 5588C 5589C 5590C 5591 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 5592C 5593 INCLUDE 'parameter.h' 5594 INCLUDE 'comwork.h' 5595 INCLUDE 'combuff.h' 5596C 5597C ------------------------------------------------------------------ 5598C* 1. LOCATE STATION. . 5599C --------------- 5600 100 CONTINUE 5601C 5602C CLEAR ERROR RETURN INDICATOR 5603C 5604 IRC = 0 5605C 5606C INITIALIZE TYPE OF STATION 5607C 5608 ITYPE = 0 5609C 5610C 'ITYPE' IS SET TO 4 FOR SYNOP , 2 FOR PILOT AND 1 FOR TEMP. 5611C 5612 IF ( KDEC(4).EQ.11.OR.KDEC(4).EQ.14 ) ITYPE = 4 5613 IF ( KDEC(4).EQ.32 ) ITYPE = 2 5614 IF ( KDEC(4).EQ.35 ) ITYPE = 1 5615C 5616 IF ( ITYPE.EQ.0 ) THEN 5617 IRC = 3 5618 RETURN 5619 END IF 5620C 5621C CHECK VALIDITY OF STATION NUMBER 5622C 5623 IF ( KINT(4).LE.1000.OR.KINT(4).GT.99999 ) 5624 C THEN 5625 IRC = 2 5626 RETURN 5627 END IF 5628C 5629C 5630C LOCATE STARTING POINT IN ARRAY 'IPARAMS' OF THE WMO BLOCK 5631C OF THE STATION. 5632C 5633C EXTRACT WMO BLOCK NUMBER 5634C 5635 II = KINT(4) / 1000 5636C 5637C WORD 'II' OF 'IPOINTS' SHOWS WHERE THE ENTRIES FOR BLOCK 'II' 5638C START IN 'IPARAMS'. 5639C 5640 IND1 = IPOINTS(II) 5641 IND2 = IPOINTS(II+1)-3 5642C 5643C STARTING AT THIS WORD A SEQUENTIAL SEARCH IS MADE FOR AN ENTRY 5644C FOR THE REQUIRED STATION NUMBER ( III ) > 5645C 5646 III = KINT(4) - ( II * 1000 ) 5647c 5648 if(ii.eq.12.and.iii.eq.851) then 5649 jjjj=5 5650 end if 5651C 5652C FOR ONE STATION ENTRY 3 WORDS ARE USED 5653C 5654 DO 101 I=IND1,IND2,3 5655 CALL GBYTE(IPARAMS(I),ISTN,0,10) 5656 IF(ISTN.EQ.III) GO TO 200 5657 101 CONTINUE 5658C 5659C STATION NUMBER NOT FOUND 5660C 5661 IRC = 1 5662 RETURN 5663C 5664C 5665C ----------------------------------------------------------------- 5666C* 2. EXTRACT REQUIRED PARAMETERS FROM 1ST WORD ENTRY. 5667C ----------------------------------------------- 5668 200 CONTINUE 5669C 5670C PRESSURE LEVEL CODE FIGURE 5671C 5672 IF(ITYPE .EQ. 4) 5673 C CALL GBYTE(IPARAMS(I),KDEC(23),16,4) 5674c print*,ii,iii,kdec(23) 5675C 5676C 5677C WIND SPEED UNIT INDICATOR 5678C 5679 CALL GBYTE(IPARAMS(I),IWIND,20,1) 5680C 5681C 5682C STATION ELEVATION 5683C 5684 CALL GBYTE(IPARAMS(I),KDEC(8),24,14) 5685 IF ( KDEC(8).GT.9999 ) KDEC(8) = KDEC(8)-16383 5686 IF ( KDEC(8).EQ.9999 ) KDEC(8) = MINDIC 5687 CALL GBYTE(IPARAMS(I+1),ISGN,6,2) 5688 IF(KDEC(8).NE.MINDIC.AND.ISGN.EQ.1) KDEC(8)=-KDEC(8) 5689C 5690C LONGITUDE 5691C 5692 CALL GBYTE(IPARAMS(I+1),KDEC(6),8,16) 5693 IF ( KDEC(6).EQ.65535 ) KDEC(6) = MINDIC 5694 IF ( KDEC(6).NE.MINDIC.AND.KDEC(6).GT.18000) 5695 C KDEC(6) = KDEC(6) - 36000 5696 5697C 5698C 5699C LATITUDE 5700C 5701 CALL GBYTE(IPARAMS(I+1),KDEC(5),24,14) 5702 IF ( KDEC(5).EQ.16383 ) KDEC(5) = MINDIC 5703 CALL GBYTE(IPARAMS(I+2),ISGN,6,1) 5704 IF(ISGN.EQ.1.AND.KDEC(5).NE.MINDIC) 5705 C KDEC(5) = - KDEC(5) 5706 5707C 5708C 5709C WMO REGION NUMBER 5710C 5711 CALL GBYTE(IPARAMS(I+2),KDEC(17),8,3) 5712 IF ( KDEC(17).EQ.0 ) KDEC(17) = 8 5713C 5714C 5715C WMO COUNTRY NUMBER ( LAST 3 DIGITS ) 5716C 5717 CALL GBYTE(IPARAMS(I+2),KDEC(16),11,10) 5718C 5719C 5720C IMPORTANT STATION AND GOOD QUALITY FLAGS. 5721C 5722 CALL GBYTE(IPARAMS(I+2),ISGQ,24,2) 5723 KDEC(15) = IOR(KDEC(15),ISGQ) 5724C 5725C 5726C CHECK THAT PARAMETERS ARE VALID FOR OBSERVATION TYPE REQUESTED. 5727C SOME STATIONS HAVE MORE THAN 1 ENTRY , DEPENDING ON TYPE OF 5728C OBSERVATION. 5729C 5730 IF(ITYPE.EQ.1) ISKIP=26 5731 IF(ITYPE.EQ.2) ISKIP=27 5732 IF(ITYPE.EQ.4) ISKIP=28 5733C 5734 CALL GBYTE(IPARAMS(I+2),ITP,ISKIP,1) 5735 IF ( ITP.NE.0 ) RETURN 5736C 5737C PARAMETERS NOT CORRECT FOR CODE TYPE , SO USE NEXT ENTRY 5738C IF IT EXIST 5739C 5740 I = I + 3 5741C 5742 CALL GBYTE(IPARAMS(I),ISTN,0,10) 5743 IF(ISTN.EQ.III) GO TO 200 5744C 5745C RETAIN ALREADY EXTRACTED PARAMETERS 5746C THAT MEAN THAT STATION TYPE DOES NOT CORRESPOND TO THE MESSAGE 5747C RECEIVED. 5748C 5749 RETURN 5750C 5751C 5752 END 5753 SUBROUTINE EXTVAL ( I,N,IVAL) 5754C 5755C 5756C**** *EXTVAL* 5757C 5758C 5759C PURPOSE. 5760C -------- 5761C 5762C EXTRACTS N FIGURES FROM ARRAY 'KCHAR' , STARTING AT 5763C WORD I , CONVERTS CHARACTERS TO INTEGER AND PLACES 5764C IN IVAL 5765C 5766C 5767C** INTERFACE. 5768C ---------- 5769C 5770C *CALL* *EXTVAL(I,N,IVAL)* 5771C 5772C INPUT : I - POINTS TO FIRST CHARACTER TO BE EXTRACTED. 5773C N - NUMBER OF CCITT NO. 5 CHARACTERS TO BE EXTRACTE 5774C 5775C OUTPUT : IVAL - INTEGER VALUE 5776C 5777C METHOD. 5778C ------- 5779C 5780C NONE. 5781C 5782C 5783C EXTERNALS. 5784C ---------- 5785C 5786C NONE. 5787C 5788C REFERENCE. 5789C ---------- 5790C 5791C NONE. 5792C 5793C AUTHOR. 5794C ------- 5795C 5796C 5797C 5798C MODIFICATIONS. 5799C -------------- 5800C 5801C M. DRAGOSAVAC *ECMWF* AUG 1988. 5802C 5803C 5804 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 5805C 5806 INCLUDE 'parameter.h' 5807 INCLUDE 'comwork.h' 5808C 5809 DIMENSION ILET(11),IFIG(11) 5810C 5811 DATA (ILET(J),J=1,11) / 5812C E O, P, Q, R, T, U, W, X, Y, I. 5813 C 69, 79, 80, 81, 82, 84, 85, 87, 88, 89, 73 / 5814C 5815 DATA (IFIG(J),J=1,11) / 5816C 3 9, 0, 1, 4, 5, 7, 2, /, 6, 8. 5817 C 51, 57, 48, 49, 52, 53, 55, 50, 47, 54, 56 / 5818C 5819C ------------------------------------------------------------------ 5820C 5821C* 1. EXTRACT N FIGURES FROM KCHAR ARRAY. 5822C ----------------------------------- 5823 100 CONTINUE 5824C 5825 IAC = 0 5826 IA = IABS(I) 5827 IB = IA + N - 1 5828C 5829 DO 101 J=IA,IB 5830C 5831C 5832C STORE KCHAR(J) SO THAT IT WONT BE ALTERED IN THE SUBROUTINE 5833C 5834 KTEMP=KCHAR(J) 5835 KAR = IAND(KCHAR(J) , 127) 5836C 5837C CHECK FOR SPACE CHARACTER . 5838C 5839 IF ( KAR.EQ.32 ) THEN 5840 IVAL = MINDIC 5841 RETURN 5842 END IF 5843C 5844C CHECK FOR / CHARACTER . 5845C 5846 IF ( KAR.EQ.47 ) THEN 5847 IVAL = MINDIC 5848 RETURN 5849 END IF 5850C 5851C IF LETTER ENCOUNTERED CONVERT TO FIGURE USING THE 5852C CCITT NO.2 LETTER/FIGURE RELATIONSHIP. 5853C 5854 IF ( KAR.LT.48.OR.KAR.GT.57 ) 5855 C THEN 5856 DO 102 JA=1,11 5857 IF ( KAR.EQ.ILET(JA)) 5858 C KAR = IFIG(JA) 5859 102 CONTINUE 5860 END IF 5861C 5862 IF ( KAR.GE.48.AND.KAR.LE.57 ) 5863 C THEN 5864 IAC = (IAC + (IAND(KAR,15)))*10 5865 ELSE 5866 IVAL = MINDIC 5867 RETURN 5868 END IF 5869C 5870C 5871C 5872 KCHAR(J)=KTEMP 5873C 5874 101 CONTINUE 5875C 5876 IVAL = IAC / 10 5877C 5878C 5879 RETURN 5880 END 5881 SUBROUTINE PRESEP ( I,J,*) 5882C 5883C 5884C 5885C***** 5886C* 5887C* NAME : LETFIG 5888C* 5889C* FUNCTION : IF K IS NOT FIGURE CONVERT IT USING THE 5890C* CCITT NO.2 LETTER/FIGURE RELATION SHIP. 5891C* 5892C* INPUT : K - KHARACTER VALUE TO BE CONVERTED 5893C* 5894C* OUTPUT : K - CONVERTED TO FIGURE IF IT WAS EITHER 5895C* E,O,P,Q,R,T,U,W,X,Y OR I, OTHERWISE 5896C* K REMAINS UNCHANGED. 5897C* 5898C***** 5899C 5900C 5901C 5902 DIMENSION ILET(11),IFIG(11) 5903C 5904 DATA (ILET(J),J=1,11) / 5905C E O, P, Q, R, T, U, W, X, Y, I. 5906 C 69, 79, 80, 81, 82, 84, 85, 87, 88, 89, 73 / 5907C 5908 DATA (IFIG(J),J=1,11) / 5909C 3 9, 0, 1, 4, 5, 7, 2, /, 6, 8. 5910 C 51, 57, 48, 49, 52, 53, 55, 50, 47, 54, 56 / 5911C 5912C 5913C 5914C IF LETTER ENCOUNTERED CONVERT TO FIGURE USING THE 5915C CCITT NO.2 LETTER/FIGURE RELATIONSHIP. 5916C 5917 IF ( K.LT.48.OR.K.GT.57 ) 5918 C THEN 5919 DO 100 JA=1,11 5920 IF ( K.EQ.ILET(JA)) 5921 C K = IFIG(JA) 5922 100 CONTINUE 5923 END IF 5924C 5925C 5926 RETURN 5927 END 5928 SUBROUTINE DDFFF(IDD,IFF,IWW,ICOUNT,MINDIC,IDIR,ISPEED) 5929C 5930C 5931C**** *DDFFF* 5932C 5933C 5934C PURPOSE. 5935C 5936C 5937C DECODE WIND DIRECTION AND SPEED 5938C 5939C 5940C** INTERFACE. 5941C ---------- 5942C 5943C *CALL* *DDFFF(IDD,IFF,IWW,ICOUNT,MINDIC,IDIR,ISPEED)* 5944C 5945C INPUT : IDD - WIND DIRECTION IN TENS OF DEGREE 5946C : IFF - WIND SPEEDIN METERS/SEC OR KNOTS 5947C : IWW - WIND SPEED INDICATOR (1 FOR KNOTS) 5948C : ICOUNT - COUNTRY NUMBER 5949C : MINDIC - MISSING DATA VALUE 5950C 5951C OUTPUT : IDIR - DECODED WIND DIRECTION 5952C ISPEED - DECODED WIND SPEED 5953C 5954C IDIR AND ISPEED ARE SET TO MISSING VALUE IF 5955C ANY ERRORS FOUND IN IDD, IFF OR IWW 5956C 5957C 5958C METHOD. 5959C ------- 5960C 5961C NONE. 5962C 5963C 5964C EXTERNALS. 5965C ---------- 5966C 5967C *XXXX* *XXXXXXX(XXXX)* 5968C 5969C REFERENCE. 5970C ---------- 5971C 5972C NONE. 5973C 5974C AUTHOR. 5975C ------- 5976C 5977C A.HOLOPAINEN JAN.83 5978C 5979C 5980C 5981C 5982C MODIFICATIONS. 5983C -------------- 5984C 5985C M. DRAGOSAVAC *ECMWF* AUG 1988. 5986C 5987C 5988 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 5989C 5990C 5991C 5992C ------------------------------------------------------------------ 5993C* 1. DECODE WIND DIRECTION AND SPEED. 5994C -------------------------------- 5995 100 CONTINUE 5996C 5997C CHECK MISSING DATA INDICATOR 5998C 5999 IF(IDD .EQ. MINDIC .OR. IFF .EQ. MINDIC) RETURN 6000C 6001C CHECK IF IDD ID FEASABLE 6002C 6003 IF(IDD .LT. 0 .OR. IDD .GT. 36) RETURN 6004C 6005 ISPEED=IFF 6006 IDIR=IDD 6007C 6008C 6009C CHECK IF DD=99 .I.E. DIRECTION INDETERMINATE 6010C 6011C 6012C CHECK IF DD INDICATOR IS SENSIBLE 6013C 6014 IF(IDIR .GT. 36 .AND. IDIR .LT. 50) RETURN 6015 IF(IDIR .GT. 86 .AND. IDIR .NE. 99) RETURN 6016C 6017C 6018C 6019C 6020 IF(IDIR .GT. 50 .AND. IDIR .NE. 99) IDIR=IDIR-50 6021 IF(IDIR .EQ. 99) IDIR=0 6022C 6023 IDIR=IDIR*10 6024C 6025 IF(ISPEED .GE. 500) THEN 6026 ISPEED=ISPEED-500 6027 IDIR=IDIR+5 6028 END IF 6029C 6030C 6031C IF SPEED IN KNOTS MODIFY IT TO M/S 6032C 6033 IF(IWW .EQ. 1) CALL KTOMPSI(ISPEED) 6034C 6035 RETURN 6036 END 6037 SUBROUTINE PREPRT(I,J,*) 6038C 6039C 6040C**** *PREPRT* 6041C 6042C 6043C PURPOSE. 6044C -------- 6045C 6046C SCANS BULLETIN IN 'KCHAR' FOR PREVIOUS CHARACTER WHICH 6047C IS NOT 'SOH' , 'CR' , 'LF' , 'SPACE' OR 'GS' . 6048C 6049C 6050C** INTERFACE. 6051C ---------- 6052C 6053C *CALL* *PREPRT(I,J,*)* 6054C 6055C INPUT : I - SCAN STARTS AT WORD I. 6056C J - SCAN STOPS AT WORD J . 6057C 6058C OUTPUT : I - POSITION OF REQUIRED CHARACTER. 6059C IF CHARACTER NOT FOUND THE CONROL 6060C RETURNS TO ALTERNATIVE RETURN POINT * 6061C 6062C 6063C METHOD. 6064C ------- 6065C 6066C NONE. 6067C 6068C 6069C EXTERNALS. 6070C ---------- 6071C 6072C *XXXX* *XXXXXXX(XXXX)* 6073C 6074C REFERENCE. 6075C ---------- 6076C 6077C NONE. 6078C 6079C AUTHOR. 6080C ------- 6081C 6082C 6083C 6084C MODIFICATIONS. 6085C -------------- 6086C 6087C M. DRAGOSAVAC *ECMWF* AUG 1988. 6088C 6089C 6090 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6091C 6092 INCLUDE 'parameter.h' 6093 INCLUDE 'comwork.h' 6094C 6095C ------------------------------------------------------------------ 6096C* 1. SCAN BULLETIN. 6097C -------------- 6098 100 CONTINUE 6099C 6100C 'SOH' = 1 , 'LF' = 10 , 'CR' = 13 , SPACE = 32 , 'GS' = 29. 6101C 6102 I = IABS(I) 6103 K = I 6104 DO 101 I=K,J,-1 6105 IF(I .LE. J) RETURN 1 6106 KAR = IAND(KCHAR(I),127) 6107 IF ( KAR.NE.1.AND.KAR.NE.10.AND.KAR.NE.13. 6108 C AND.KAR.NE.32.AND.KAR.NE.29) RETURN 6109 101 CONTINUE 6110C 6111 RETURN 1 6112 END 6113 SUBROUTINE NEXSEP2 ( I,J,*) 6114C 6115C 6116C**** *NEXSEP2* 6117C 6118C 6119C PURPOSE. 6120C -------- 6121C 6122C LOCATE THE NEXT GROUP BY FINDING THE NEXT 6123C CHARACTER WHICH IS NOT 'CR' OR 'LF' OR 'SPACE'. 6124C 'CR' OR 'LF' OR 'SPACE' 6125C 6126C INPUT : I - SCAN STARTS AT WORD 'I' OF 'KCHAR' . 6127C J - SCAN ENDS AT WORD 'J' OF 'KCHAR' . 6128C 6129C OUTPUT : I - POSITION OF NEXT 'CR' OR 'LF' OR 'SPACE' CHARACTER 6130C IF NO CHARACTER FOUND THE CONTROL RETURN TO 6131C ALTERNATIVE RETURN POINT * 6132C 6133C** INTERFACE. 6134C ---------- 6135C 6136C *CALL* *NEXSEP2(I,J,*)* 6137C 6138C METHOD. 6139C ------- 6140C 6141C NONE. 6142C 6143C 6144C EXTERNALS. 6145C ---------- 6146C 6147C NONE. 6148C 6149C REFERENCE. 6150C ---------- 6151C 6152C NONE. 6153C 6154C AUTHOR. 6155C ------- 6156C 6157C M. DRAGOSAVAC *ECMWF* AUG 1988. 6158C 6159C 6160C MODIFICATIONS. 6161C -------------- 6162C 6163C NONE. 6164C 6165C 6166 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6167C 6168 INCLUDE 'parameter.h' 6169 INCLUDE 'comwork.h' 6170C 6171C ------------------------------------------------------------------ 6172C* 1. SCAN BULLETIN. . 6173C ------------- 6174 100 CONTINUE 6175C 6176C 6177C 'CR' = 13 , 'LF' = 10 , 'SPACE' = 32. 6178C 6179 I=IABS(I) 6180 K = I 6181 DO 101 I=K,J 6182 IF(I .GE. J) RETURN 1 6183 KAR = IAND(KCHAR(I), 127) 6184 IF(KAR .EQ. 13 .OR. KAR .EQ. 10 .OR. KAR .EQ. 32) RETURN 6185 101 CONTINUE 6186C 6187 RETURN 1 6188 END 6189 SUBROUTINE NEXPRT2(I,J,*) 6190C 6191C 6192C**** *NEXPRT2* 6193C 6194C 6195C PURPOSE. 6196C -------- 6197C 6198C SCANS BULLETIN IN 'KCHAR' FOR NEXT CHARACTER WHICH 6199C IS NOT 'SOH' , 'CR' , 'LF' , 'SPACE' OR 'GS' . 6200C 6201C INPUT : I - SCAN STARTS AT WORD I. 6202C J - SCAN STOPS AT WORD J . 6203C 6204C OUTPUT : I - POSITION OF REQUIRED CHARACTER. 6205C IF CHARACTER NOT FOUND THE CONROL 6206C RETURNS TO ALTERNATIVE RETURN POINT * 6207C 6208C** INTERFACE. 6209C ---------- 6210C 6211C *CALL* *NEXPRT2(I,J,*)* 6212C 6213C METHOD. 6214C ------- 6215C 6216C NONE. 6217C 6218C 6219C EXTERNALS. 6220C ---------- 6221C 6222C NONE. 6223C 6224C REFERENCE. 6225C ---------- 6226C 6227C NONE. 6228C 6229C AUTHOR. 6230C ------- 6231C 6232C M. DRAGOSAVAC *ECMWF* AUG 1988. 6233C 6234C 6235C MODIFICATIONS. 6236C -------------- 6237C 6238C NONE. 6239C 6240C 6241 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6242C 6243 INCLUDE 'parameter.h' 6244 INCLUDE 'comwork.h' 6245C 6246C ------------------------------------------------------------------ 6247C 6248C* 1. SCAN BULLETIN. . 6249C -------------- 6250 100 CONTINUE 6251C 6252C 'SOH' = 1 , 'LF' = 10 , 'CR' = 13 , SPACE = 32 , 'GS' = 29. 6253C 6254 I = IABS(I) 6255 K = I 6256 DO 101 I=K,J 6257 IF(I .GE. J) RETURN 1 6258 KAR = IAND(KCHAR(I),127) 6259 IF ( KAR.NE.1.AND.KAR.NE.10.AND.KAR.NE.13. 6260 C AND.KAR.NE.32.AND.KAR.NE.29) RETURN 6261 101 CONTINUE 6262C 6263 RETURN 1 6264 END 6265 SUBROUTINE NEXTEQ ( I,J ) 6266C 6267C 6268C 6269C**** *EXTINT* 6270C 6271C 6272C PURPOSE. 6273C -------- 6274C EXTRACTS N FIGURES FROM ARRAY 'KCHAR' , STARTING AT 6275C WORD I , CONVERTS CHARACTERS TO INTEGER AND PLACES 6276C IN WORD K OF 'KINT' . 6277C 6278C INPUT : I - POINTS TO FIRST CHARACTER TO BE EXTRACTED. 6279C N - NUMBER OF CCITT NO. 5 CHARACTERS TO BE EXTRACTED. 6280C 6281C OUTPUT : I - POINTS TO CHARACTER AFTER THE LAST ONE EXTRACTED. 6282C MADE NEGATIVE IF A 'SEPARATOR' IS FOUND IN THE 6283C CHARACTERS BEING EXTRACTED. 6284C IF NEGATIVE , THE ABSOLUTE VALUE IS POSITION OF 6285C 'SEPARATOR' ENCOUNTERED . 6286C K - INTEGER VALUE IN WORD K OF 'KINT'. MISSING DATA 6287C VALUE INSERTED IF '/' OR NON DIGIT ENCOUNTERED. 6288C 6289C 6290C** INTERFACE. 6291C ---------- 6292C 6293C *CALL* *EXTINT ( I,N,K )* 6294C 6295C METHOD. 6296C ------- 6297C 6298C NONE. 6299C 6300C 6301C EXTERNALS. 6302C ---------- 6303C 6304C *XXXX* *XXXXXXX(XXXX)* 6305C 6306C REFERENCE. 6307C ---------- 6308C 6309C NONE. 6310C 6311C AUTHOR. 6312C ------- 6313C 6314C J. HENNESSY 6315C 6316C MODIFICATIONS. 6317C -------------- 6318C 6319C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 6320C 6321C 6322 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6323C 6324 INCLUDE 'parameter.h' 6325 INCLUDE 'comwork.h' 6326C 6327 DIMENSION ILET(11),IFIG(11) 6328C 6329 DATA (ILET(J),J=1,11) / 6330C E O, P, Q, R, T, U, W, X, Y, I. 6331 C 69, 79, 80, 81, 82, 84, 85, 87, 88, 89, 73 / 6332C 6333 DATA (IFIG(J),J=1,11) / 6334C 3 9, 0, 1, 4, 5, 7, 2, /, 6, 8. 6335 C 51, 57, 48, 49, 52, 53, 55, 50, 47, 54, 56 / 6336C 6337C 6338C ------------------------------------------------------------------ 6339C 6340C* 1. EXTRACT N FIGURES. 6341C ------------------ 6342 100 CONTINUE 6343C 6344 IAC = 0 6345 IA = IABS(I) 6346 IB = IA + N - 1 6347C 6348C* 1.1 STORE KCHAR(J) SO THAT IT WONT BE ALTERED IN THE SUBROUTINE. 6349C ------------------------------------------------------------ 6350 110 CONTINUE 6351C 6352 DO 111 J=IA,IB 6353C 6354 KTEMP=KCHAR(J) 6355 KTEMP=KCHAR(J) 6356 KAR = IAND(KCHAR(J) , 127) 6357C 6358C 6359C CHECK FOR SPACE,LINE FEED AND CARRIAGE RETURN CHARACTER . 6360C 6361 IF ( KAR .EQ. 32 .OR. KAR .EQ. 10 .OR. KAR .EQ. 13) 6362 C THEN 6363 I = - J 6364 KINT(K) = MINDIC 6365 RETURN 6366 END IF 6367C 6368C CHECK FOR / CHARACTER . 6369C 6370 IF ( KAR.EQ.47 ) THEN 6371 I = IB + 1 6372 KINT(K) = MINDIC 6373 RETURN 6374 END IF 6375C 6376C IF LETTER ENCOUNTERED CONVERT TO FIGURE USING THE 6377C CCITT NO.2 LETTER/FIGURE RELATIONSHIP. 6378C 6379 IF ( KAR .LT. 48 .OR. KAR .GT. 57 ) 6380 C THEN 6381 DO 112 JA=1,11 6382 IF ( KAR .EQ. ILET(JA)) 6383 C KAR = IFIG(JA) 6384 112 CONTINUE 6385 END IF 6386C 6387 IF ( KAR .GE. 48 .AND. KAR .LE. 57 ) 6388 C THEN 6389 IAC = (IAC + (IAND(KAR,15)))*10 6390 ELSE 6391 KINT(K) = MINDIC 6392 I = IB + 1 6393 RETURN 6394 END IF 6395C 6396C 6397C 6398 KCHAR(J)=KTEMP 6399C 6400 111 CONTINUE 6401C 6402 KINT(K) = IAC / 10 6403 I = J 6404C 6405C 6406 RETURN 6407 END 6408 SUBROUTINE NEXTPRT ( I,J ) 6409C 6410C 6411C**** *NEXTPRT* 6412C 6413C 6414C PURPOSE. 6415C -------- 6416C SCANS BULLETIN IN 'KCHAR' FOR NEXT CHARACTER WHICH 6417C IS NOT 'SOH' , 'CR' , 'LF' , 'SPACE' OR 'GS' . 6418C 6419C INPUT : I - SCAN STARTS AT WORD I. 6420C J - SCAN STOPS AT WORD J . 6421C 6422C OUTPUT : I - POSITION OF REQUIRED CHARACTER. I > J INDICATES 6423C CHARACTER NOT FOUND. 6424C 6425C 6426C** INTERFACE. 6427C ---------- 6428C 6429C *CALL* *NEXTPRT(I,J)* 6430C 6431C METHOD. 6432C ------- 6433C 6434C NONE. 6435C 6436C 6437C EXTERNALS. 6438C ---------- 6439C 6440C NONE. 6441C 6442C REFERENCE. 6443C ---------- 6444C 6445C NONE. 6446C 6447C AUTHOR. 6448C ------- 6449C 6450C 6451C 6452C MODIFICATIONS. 6453C -------------- 6454C 6455C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 6456C 6457C 6458 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6459C 6460 INCLUDE 'parameter.h' 6461 INCLUDE 'comwork.h' 6462C 6463C ------------------------------------------------------------------ 6464C 6465C* 1. SCAN BULLETIN. 6466C -------------- 6467 100 CONTINUE 6468C 6469C 'SOH' = 1 , 'LF' = 10 , 'CR' = 13 , SPACE = 32 , 'GS' = 29. 6470C 6471 I = IABS(I) 6472 K = I 6473 DO 101 I=K,J 6474 KAR = IAND(KCHAR(I),127) 6475 IF ( KAR.NE.1.AND.KAR.NE.10.AND.KAR.NE.13. 6476 C AND.KAR.NE.32.AND.KAR.NE.29) RETURN 6477 101 CONTINUE 6478C 6479 RETURN 6480 END 6481 SUBROUTINE NEXTSEP ( I,J ) 6482C 6483C 6484C**** *NEXTSEP* 6485C 6486C 6487C PURPOSE. 6488C -------- 6489C LOCATE THE NEXT GROUP BY FINDING THE NEXT 6490C CHARACTER WHICH IS NOT 'CR' OR 'LF' OR 'SPACE'. 6491C 'CR' OR 'LF' OR 'SPACE' 6492C 6493C INPUT : I - SCAN STARTS AT WORD 'I' OF 'KCHAR' . 6494C J - SCAN ENDS AT WORD 'J' OF 'KCHAR' . 6495C 6496C OUTPUT : I - POSITION OF NEXT 'CR' OR 'LF' OR 'SPACE' CHARACTER 6497C 6498C** INTERFACE. 6499C ---------- 6500C 6501C *CALL* *NEXTSEP(I,J)* 6502C 6503C METHOD. 6504C ------- 6505C 6506C NONE. 6507C 6508C 6509C EXTERNALS. 6510C ---------- 6511C 6512C NONE. 6513C 6514C REFERENCE. 6515C ---------- 6516C 6517C NONE. 6518C 6519C AUTHOR. 6520C ------- 6521C 6522C 6523C 6524C MODIFICATIONS. 6525C -------------- 6526C 6527C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 6528C 6529C 6530 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6531C 6532 INCLUDE 'parameter.h' 6533 INCLUDE 'comwork.h' 6534C 6535C ------------------------------------------------------------------ 6536C 6537C* 1. SCAN BULLETIN. 6538C -------------- 6539 100 CONTINUE 6540C 6541C 'CR' = 13 , 'LF' = 10 , 'SPACE' = 32. 6542C 6543 I=IABS(I) 6544 K = I 6545 DO 101 I=K,J 6546 KAR = IAND(KCHAR(I), 127) 6547 IF(KAR .EQ. 13 .OR. KAR .EQ. 10 .OR. KAR .EQ. 32) RETURN 6548 101 CONTINUE 6549C 6550 RETURN 6551 END 6552 SUBROUTINE NEXTEND ( I,J ) 6553C 6554C 6555C**** *NEXTEND* 6556C 6557C 6558C PURPOSE. 6559C -------- 6560C FUNCTION : LOCATE NEXT OCCURRENCE OF EITHER 'CR' OR 'LF' 6561C 6562C INPUT : I - SCAN STARTS AT WORD 'I' OF 'KCHAR' . 6563C J - SCAN ENDS AT WORD 'J' OF 'KCHAR' . 6564C 6565C OUTPUT : I - POSITION OF NEXT 'CR' OR 'LF' CHARACTER. 6566C I > J INDICATES NO CHARACTER FOUND. 6567C 6568C** INTERFACE. 6569C ---------- 6570C 6571C *CALL* *NEXTEND(I,J)* 6572C 6573C METHOD. 6574C ------- 6575C 6576C NONE. 6577C 6578C 6579C EXTERNALS. 6580C ---------- 6581C 6582C NONE. 6583C 6584C REFERENCE. 6585C ---------- 6586C 6587C NONE. 6588C 6589C AUTHOR. 6590C ------- 6591C 6592C 6593C 6594C MODIFICATIONS. 6595C -------------- 6596C 6597C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 6598C 6599C 6600 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6601C 6602 INCLUDE 'parameter.h' 6603 INCLUDE 'comwork.h' 6604C 6605C ------------------------------------------------------------------ 6606C 6607C* 1. SCAN BULLETIN. 6608C -------------- 6609 100 CONTINUE 6610C 6611C 'CR' = 13 , 'LF' = 10 . 6612C 6613 I=IABS(I) 6614 K = I 6615 DO 101 I=K,J 6616 KAR = IAND(KCHAR(I) , 127) 6617 IF ( KAR .EQ. 13 .OR. KAR .EQ. 10 ) RETURN 6618 101 CONTINUE 6619C 6620 RETURN 6621 END 6622 SUBROUTINE PRTBULL ( I,M ) 6623C 6624C 6625C**** *PRTBULL* 6626C 6627C 6628C PURPOSE. 6629C -------- 6630C PRINTS BULLETIN IN ARRAY 'KCHAR' 6631C 6632C INPUT : BULLETIN IN 'KCHAR' . 6633C I - PRINT STARTS AT CHARACTER I 6634C M - PRINT ENDS AT CHARACTER M . 6635C 6636C OUTPUT : BULLETIN IS PRINTED . ARRAY 'KCHAR' AND POINTERS 6637C UNCHANGED. 6638C 6639C** INTERFACE. 6640C ---------- 6641C 6642C *CALL* *PRTBULL(I,M)* 6643C 6644C METHOD. 6645C ------- 6646C 6647C NONE. 6648C 6649C 6650C EXTERNALS. 6651C ---------- 6652C 6653C *CALL* *NEXTPRT(I,J)* 6654C *CALL* *NEXTEND(I,J)* 6655C 6656C REFERENCE. 6657C ---------- 6658C 6659C NONE. 6660C 6661C AUTHOR. 6662C ------- 6663C 6664C 6665C 6666C MODIFICATIONS. 6667C -------------- 6668C 6669C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 6670C 6671C 6672C IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6673C 6674 INCLUDE 'parameter.h' 6675 INCLUDE 'comwork.h' 6676C 6677 DIMENSION LINE(80) 6678C 6679C ------------------------------------------------------------------ 6680C 6681C* 1. PRINT BULLETIN. 6682C --------------- 6683 100 CONTINUE 6684C 6685 IP = I 6686 J = M 6687C 6688C* 1.1 SET OUTPUT LINE TO ALL SPACES . 6689C ------------------------------- 6690 110 CONTINUE 6691C 6692 K = 80 6693 DO 111 N=1,K 6694 LINE(N) = 32 6695 111 CONTINUE 6696C 6697C LOCATE START AND END OF NEXT LINE OF CHARACTERS ( IF ANY ). 6698C 6699 CALL NEXTPRT ( IP,J ) 6700 IF ( IP.GT.J ) RETURN 6701 JP = IP 6702 CALL NEXTEND ( JP,J ) 6703 K = JP - IP 6704 IF(K.GT.80) K=80 6705C 6706C INSERT IN OUTPUT LINE AND SUPPRESS PARITY BIT. 6707C 6708 DO 112 N =1,K 6709 LINE(N) = IAND(KCHAR(IP),127) 6710 IP = IP + 1 6711 112 CONTINUE 6712C 6713 WRITE ( *,9900) (LINE(N),N=1,K) 6714C 6715C GET NEXT LINE 6716C 6717 GO TO 110 6718C 6719 9900 FORMAT (1H ,80A1) 6720C 6721 END 6722 SUBROUTINE INITVAR ( IERR ) 6723C 6724C 6725C 6726C**** *NEXTFIG* 6727C 6728C 6729C PURPOSE. 6730C -------- 6731C LOCATE FIRST WORD CONTAINING A FIGURE IN ARRAY 6732C 'KCHAR' BETWEEN WORD 'I' AND WORD 'K' . 6733C 6734C INPUT : BULLETIN IN 'KCHAR' , 1 CHARACTER PER WORD. 6735C 6736C OUTPUT : I = REQUIRED LOCATION . I > K MEANS NO FIGURE FOUND. 6737C 6738C 6739C** INTERFACE. 6740C ---------- 6741C 6742C *CALL* *NEXTFIG(I,K)* 6743C 6744C METHOD. 6745C ------- 6746C 6747C NONE. 6748C 6749C 6750C EXTERNALS. 6751C ---------- 6752C 6753C NONE. 6754C 6755C REFERENCE. 6756C ---------- 6757C 6758C NONE. 6759C 6760C AUTHOR. 6761C ------- 6762C 6763C 6764C 6765C MODIFICATIONS. 6766C -------------- 6767C 6768C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 6769C 6770C 6771 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6772C 6773C 6774 INCLUDE 'parameter.h' 6775 INCLUDE 'comwork.h' 6776C 6777C ------------------------------------------------------------------ 6778C 6779C* 1. FIND POINTER TO NEXT FIGURE. 6780C ---------------------------- 6781 100 CONTINUE 6782C 6783C 6784 I = IABS(I) 6785 J = I 6786 DO 101 I=J,K 6787 KAR = IAND(KCHAR(I) , 127) 6788 IF ( KAR .GE. 48 .AND. KAR .LE. 57 ) RETURN 6789 101 CONTINUE 6790C 6791 RETURN 6792 END 6793 SUBROUTINE NEXTLET ( I,K ) 6794C 6795C 6796C**** *NEXTLET* 6797C 6798C 6799C PURPOSE. 6800C -------- 6801C 6802C LOCATE FIRST WORD CONTAINING A LETTER IN ARRAY 6803C 'KCHAR' BETWEEN WORD 'I' AND WORD 'K' . 6804C 6805C INPUT : BULLETIN IN 'KCHAR' , 1 CHARACTER PER WORD. 6806C 6807C OUTPUT : I = REQUIRED LOCATION . I > K MEANS NO LETTER FOUND. 6808C 6809C** INTERFACE. 6810C ---------- 6811C 6812C *CALL* *NEXTLET(I,K)* 6813C 6814C METHOD. 6815C ------- 6816C 6817C NONE. 6818C 6819C 6820C EXTERNALS. 6821C ---------- 6822C 6823C NONE. 6824C 6825C REFERENCE. 6826C ---------- 6827C 6828C NONE. 6829C 6830C AUTHOR. 6831C ------- 6832C 6833C 6834C 6835C MODIFICATIONS. 6836C -------------- 6837C 6838C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 6839C 6840C 6841 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6842C 6843C 6844 INCLUDE 'parameter.h' 6845 INCLUDE 'comwork.h' 6846C 6847C ------------------------------------------------------------------ 6848C 6849C* 1. FIND POINTER TO NEXT LETTER. 6850C ---------------------------- 6851 100 CONTINUE 6852C 6853C 6854 I = IABS(I) 6855 J = I 6856 DO 110 I=J,K 6857 KAR = IAND(KCHAR(I) , 127) 6858 IF ( KAR .GE. 65 .AND. KAR .LE. 90 ) RETURN 6859 110 CONTINUE 6860C 6861 RETURN 6862 END 6863 SUBROUTINE EXTGRP ( I,N1,N2,N3,N4,N5,N,IRET ) 6864C 6865C 6866C 6867C**** *ERRFILE* 6868C 6869C 6870C PURPOSE. 6871C -------- 6872C WRITE PROBLEM BULLETIN TO THE ERROR FILE TOGATHER WITH 6873C KEY. 6874C 6875C** INTERFACE. 6876C ---------- 6877C 6878C *CALL* *ERRFILE(IHEAD,IERR)* 6879C 6880C METHOD. 6881C ------- 6882C 6883C NONE. 6884C 6885C 6886C EXTERNALS. 6887C ---------- 6888C 6889C NONE. 6890C 6891C REFERENCE. 6892C ---------- 6893C 6894C NONE. 6895C 6896C AUTHOR. 6897C ------- 6898C 6899C M. D. DRAGOSAVAC *ECMWF* 15/08/88. 6900C 6901C 6902C MODIFICATIONS. 6903C -------------- 6904C 6905C NONE. 6906C 6907C 6908 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 6909C 6910 INCLUDE 'parameter.h' 6911 INCLUDE 'comwork.h' 6912 character*256 cf 6913C 6914 CHARACTER*1 Y63 6915 CHARACTER*80 YOUT,YOUTA 6916C CHARACTER*16384 YCHAR 6917 CHARACTER*3 YSPEC 6918C 6919 YSPEC=CHAR(13)//CHAR(13)//CHAR(10) 6920 Y63 =CHAR(63) 6921C ------------------------------------------------------------------ 6922C 6923C* 1. WRITE BULLETIN TO THE ERROR FILE. 6924C --------------------------------- 6925 100 CONTINUE 6926C 6927 J1=1 6928C 6929C* 1.1 OPEN ERROR FILE AT THE BEGINNING OF THE PROCESS. 6930C ------------------------------------------------- 6931 110 CONTINUE 6932C 6933 cf=' ' 6934 cf='/home/ma/maa/err/SYNO.error.dat' 6935 i=index(cf,' ') 6936 i=i-1 6937c 6938 OPEN(UNIT=10,IOSTAT=IOS,ERR=400, 6939 C FILE=cf(1:i), 6940 C STATUS='UNKNOWN', 6941 C RECL=80 ) 6942C 6943C ----------------------------------------------------------------- 6944C* 2. INITIALIZE POINTERS. 6945C -------------------- 6946 200 CONTINUE 6947C 6948 IST=1 6949 IEND=1 6950C 6951C 6952C ----------------------------------------------------------------- 6953C* 3. WRITE BULLETIN INTO ERROR FILE AND MARK ERROR. 6954C ---------------------------------------------- 6955 300 CONTINUE 6956C 6957 YOUT=' ' 6958 YOUTA=' ' 6959C 6960 CALL NEXTEND(IEND,ILEN) 6961 IF(IEND.GT.ILEN) GO TO 500 6962 CALL NEXTPRT(IEND,ILEN) 6963C IF(IEND.GT.ILEN) GO TO 500 6964 IEND=IEND-1 6965C 6966 II=0 6967C 6968 DO 301 I=IST,IEND 6969C 6970 II=II+1 6971 IF(KCHAR(I).GT.127) THEN 6972 YOUTA(II:II)=Y63 6973 ISIGN=1 6974 END IF 6975 YOUT(II:II)=CHAR(IAND(KCHAR(I),127)) 6976C 6977 301 CONTINUE 6978C 6979 IEND=IEND+1 6980 IST=IEND 6981C 6982 WRITE(10,'(A)') YOUT 6983 IF(ISIGN.EQ.1) WRITE(10,'(A)') YOUTA 6984 ISIGN=0 6985C 6986C 6987 GO TO 300 6988C 6989 400 CONTINUE 6990C 6991 PRINT*,'+++ ERROR DURING OPENNING UNIT 10 +++, IOS=',IOS 6992C 6993 500 CONTINUE 6994C 6995 CLOSE(10) 6996C 6997 RETURN 6998 END 6999 SUBROUTINE NEXTVAL ( I,N,K ) 7000C 7001C 7002C**** *NEXTVAL* 7003C 7004C 7005C PURPOSE. 7006C -------- 7007C 7008C LOCATE THE FIRST WORD CONTAINING THE VALUE 'N' IN 7009C ARRAY 'KCHAR' BETWEEN WORD 'I' AND WORD 'K' . 7010C 7011C INPUT : 'KCHAR' CONTAINS ONE BULLETIN , ONE CHARACTER PER 7012C WORD. 7013C 7014C OUTPUT : I = REQUIRED LOCATION . I > K MEANS VALUE NOT FOUND. 7015C 7016C 7017C** INTERFACE. 7018C ---------- 7019C 7020C *CALL* *NEXTVAL(I,N,K)* 7021C 7022C METHOD. 7023C ------- 7024C 7025C NONE. 7026C 7027C 7028C EXTERNALS. 7029C ---------- 7030C 7031C NONE. 7032C 7033C REFERENCE. 7034C ---------- 7035C 7036C NONE. 7037C 7038C AUTHOR. 7039C ------- 7040C 7041C 7042C 7043C MODIFICATIONS. 7044C -------------- 7045C 7046C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 7047C 7048C 7049 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 7050C 7051 INCLUDE 'parameter.h' 7052 INCLUDE 'comwork.h' 7053C 7054C ------------------------------------------------------------------ 7055C 7056C* 1. EXTRACT VALUE. 7057C -------------- 7058 100 CONTINUE 7059C 7060 I = IABS(I) 7061 J = I 7062 DO 101 I=J,K 7063 KAR = IAND(KCHAR(I) , 127) 7064 IF ( KAR .EQ. N ) RETURN 7065 101 CONTINUE 7066C 7067 RETURN 7068 END 7069 SUBROUTINE PRTKDEC(IA,K,J,MINDIC) 7070C 7071C 7072C**** *PRTKDEC* 7073C 7074C 7075C PURPOSE. 7076C -------- 7077C PRINTS THE DECODED FORMAT ARRAY (KDEC) 7078C OF DECODING DATA (PHASE II). 7079C 7080C 7081C 7082C** INTERFACE. 7083C ---------- 7084C 7085C *CALL* *PRTKEDEC(IA,K,J,MINDIC)* 7086C 7087C INPUT : IA - THE 'KDEC' ARRAY 7088C K - PRINT STARTS AT WORD I. 7089C J - PRINT STOPS AT WORD J . 7090C MINDIC - MISSING VALUE INDICATOR 7091C 7092C METHOD. 7093C ------- 7094C 7095C NONE. 7096C 7097C 7098C EXTERNALS. 7099C ---------- 7100C 7101C NONE. 7102C 7103C REFERENCE. 7104C ---------- 7105C 7106C NONE. 7107C 7108C AUTHOR. 7109C ------- 7110C 7111C 7112C 7113C MODIFICATIONS. 7114C -------------- 7115C 7116C M. D. DRAGOSAVAC *ECMWF* 15/08/88. 7117C 7118C 7119 IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y) 7120C 7121C 7122 DIMENSION IA(1) 7123C 7124C ------------------------------------------------------------------ 7125C 7126C* 1. PRINT ARRAY 'KDEC'. 7127C ------------------- 7128 100 CONTINUE 7129C 7130C 7131C 7132 LODATA = .TRUE. 7133 LODOT = .TRUE. 7134C 7135 WRITE(*,10000) 713610000 FORMAT(1H ,2X,' DATA IN DECODED FORMAT ( KDEC ) ',/) 7137C 7138C 7139 DO 101 I=K,J,10 7140 I2 = I+9 7141C 7142 DO 102 JJ=I,I2 7143 IF(IA(JJ) .EQ. MINDIC) GO TO 102 7144 LODATA = .FALSE. 7145102 CONTINUE 7146C 7147 IF(LODATA) THEN 7148C 7149C CHECK IF THERE ARE MORE DATA 7150C 7151 DO 103 JJ=I2,J 7152 IF(IA(JJ) .EQ. MINDIC) GO TO 103 7153 GO TO 104 7154103 CONTINUE 7155 RETURN 7156C 7157104 CONTINUE 7158C 7159 IF(LODOT) THEN 7160 WRITE(*,20000) 716120000 FORMAT(1H ,3X,'---',/1H ,3X,'---') 7162 LODOT = .FALSE. 7163 END IF 7164 GO TO 101 7165 END IF 7166C 7167 LODOT = .TRUE. 7168 LODATA = .TRUE. 7169C 7170 IF(I .EQ. 1) WRITE(*,30000) I,(IA(IK),IK=I,I2) 7171 IF(I .EQ. 11) WRITE(*,40000) I,(IA(IK),IK=I,I2) 7172 IF(I .GT. 20) WRITE(*,50000) I,(IA(IK),IK=I,I2) 717330000 FORMAT(1H ,2X,I4,4X,6(I10,1X),6X,A4,1X,3(I10,1X)) 717440000 FORMAT(1H ,2X,I4,4X,2(I10,1X),O10,1X,I10,1X,O10,1X,2(I10,1X), 7175 C 2(I10,1X),I10) 717650000 FORMAT(1H ,2X,I4,4X,10(I10,1X)) 7177C 7178101 CONTINUE 7179C 7180C 7181C 7182C 7183C 7184 RETURN 7185 END 7186 SUBROUTINE PRTKINT(IA,K,KL,MINDIC) 7187C 7188C 7189C 7190C**** *SYNEXP1* 7191C 7192C 7193C PURPOSE. 7194C -------- 7195C SET UP BUFR EXPANDED FORMAT FOR SYNOP DATA. 7196C BASIC REPORT. 7197C 7198C** INTERFACE. 7199C ---------- 7200C 7201C *CALL* *SYNEXP1(IERR)* 7202C 7203C METHOD. 7204C ------- 7205C 7206C NONE. 7207C 7208C 7209C EXTERNALS. 7210C ---------- 7211C 7212C *CALL* *DATUM(I,J,K)* 7213C 7214C REFERENCE. 7215C ---------- 7216C 7217C NONE. 7218C 7219C AUTHOR. 7220C ------- 7221C 7222C M. DRAGOSAVAC *ECMWF* AUG 1988. 7223C 7224C 7225C MODIFICATIONS. 7226C -------------- 7227C 7228C NONE. 7229C 7230C 7231 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 7232C 7233 INCLUDE 'parbuf.h' 7234 PARAMETER (KDLEN=200,KELEM=600,KELEM1=600,KVALS=40000) 7235 INCLUDE 'parameter.h' 7236 INCLUDE 'comwork.h' 7237 INCLUDE 'compoin.h' 7238C 7239 INCLUDE 'comkey.h' 7240 INCLUDE 'cominit.h' 7241 INCLUDE 'comstation.h' 7242 INCLUDE 'comwrt.h' 7243 INCLUDE 'comwrtc.h' 7244 INCLUDE 'comsubs.h' 7245 character*2 csp00,csp03,csp06,csp09,csp12,csp15,csp18,csp21 7246 character*1 cuat00,cuat06,cuat12,cuat18 7247 character*32 cstation 7248 logical first 7249 7250C 7251 CHARACTER*9 CIDENT 7252 INCLUDE 'comkeyc.h' 7253C 7254 REAL*8 RVIND 7255 DIMENSION KSUP(JSUP) ,KSEC0(JSEC0),KSEC1(JSEC1) 7256 DIMENSION KSEC2(JSEC2),KSEC3(JSEC3),KSEC4(JSEC4) 7257 DIMENSION KEY(JKEY) 7258C 7259 REAL*8 VALUES(KVALS) 7260 DIMENSION KTDLST(KELEM),KTDEXP(KELEM),KTDLST1(KELEM) 7261 DIMENSION KDATA(KDLEN), INDX(2) 7262C 7263 DIMENSION KBUFR(JBUFL) 7264C 7265C 7266 CHARACTER*64 CNAMES(KELEM) 7267 CHARACTER*24 CUNITS(KELEM) 7268 CHARACTER*80 CVALS (KELEM) 7269 CHARACTER*23 CTIME 7270 7271 CHARACTER*20 STNAME 7272 7273C ------------------------------------------------------------------ 7274C* 1. INCREASE COUNTER OF SUBSETS BY ONE. 7275C ----------------------------------- 7276 100 CONTINUE 7277C 7278 IF(IERR.NE.0) RETURN 7279C 7280 RVIND=1.7D38 7281 EPS=1.0D-8 7282 IF(.NOT.OLAST) THEN 7283 7284C NSUB=0 7285 NSUB=NSUB+1 7286 N =NSUB 7287C 7288 DO J=NSUB,NSUB 7289 IJ=(J-1)*KELEM 7290 DO I=1,134 7291 VALUES(I+IJ)=RVIND 7292 END DO 7293 END DO 7294C 7295C* 1.1 GET CURRENT DATE (YEAR AND MONTH). 7296C ---------------------------------- 7297 110 CONTINUE 7298C 7299 CALL DATUM(KDEC(1),IMONTH,IYEAR,IERR) 7300 IF(IERR.NE.0) RETURN 7301C 7302C ------------------------------------------------------------------ 7303C* 2. SYNOP - LAND BASED STATION. 7304C -------------------------- 7305 200 CONTINUE 7306C 7307 IBL=(KINT( 9)-48)*10+KINT(10)-48 7308 IST=(KINT(11)-48)*100+(KINT(12)-48)*10+KINT(13)-48 7309 IF(IBL.EQ.2.AND.IST.EQ.418) THEN 7310 JJJJJ=5 7311 END IF 7312c 7313 IJ=(NSUB-1)*KELEM 7314 7315 IF(KDEC(20).EQ.1) THEN 7316C NIL REPORT 7317 VALUES( 1+IJ)=IBL 7318 VALUES( 2+IJ)=IST 7319C VALUES( 3+IJ)=NSUB*1000+20 7320 VALUES( 37+IJ)=4. 7321 VALUES( 54+IJ)=0. 7322C 7323C Fill in KDATA 7324C 7325 7326 KDATA(1)=4 7327 KDATA(2)=0 7328C 7329 KTDLEN=1 7330 KTDLST(1)=307080 7331C 7332 DO I=1,20 7333 CVALS(NSUB)(I:I)=CHAR(255) 7334 END DO 7335 7336 7337 ELSEIF(KDEC(4).EQ.11.OR. 7338 1 KDEC(4).EQ.14 ) THEN 7339C ----------------------------------------------------------------- 7340C* 2.1 SYNOP LAND ( MANUAL/AUTOMATIC) STATION. 7341C ---------------------------------------- 7342C LOW ALTITUDE STATION. 7343C --------------------- 7344 210 CONTINUE 7345C 7346C 7347 nstid=((KINT( 9)-48)*10+KINT(10)-48)*1000+ 7348 1 (KINT(11)-48)*100+(KINT(12)-48)*10+KINT(13)-48 7349 idx=0 7350 do i=1,nst 7351 if(nstid.eq.istid(i)) then 7352 idx=i 7353 go to 211 7354 end if 7355 end do 7356C Element name Unit 7357 211 if(idx.eq.0) then 7358 print*,nstid,' not found' 7359 return 7360 end if 7361C 7362 m=1 7363 values( m+IJ)=(KINT( 9)-48)*10+KINT(10)-48 ! 001001 WMO BLOCK NUMBER NUMERIC 7364 m=m+1 7365 values( m+IJ)=(KINT(11)-48)*100+(KINT(12)-48)*10 7366 1 +KINT(13)-48 ! 001002 WMO STATION NUMBER NUMERIC 7367 m=m+1 7368 7369 values( m+IJ)=nsub*1000+20 ! 001015 STATION OR SITE NAME CCITTIA5 7370 cvals(nsub)=cstation(idx)(1:20) 7371 IF(kint(15).LE.3) THEN 7372 m=m+1 7373 values( m+IJ)=1. ! manned ! 002001 TYPE OF STATION CODE TABLE 002001 7374 ELSEIF(kint(15).LE.7) THEN 7375 m=m+1 7376 values( m+IJ)=0. ! automatic ! 002001 TYPE OF STATION CODE TABLE 002001 7377 ELSE 7378 m=m+1 7379 values( m+IJ)=RVIND 7380 END IF 7381 m=m+1 7382 values( m+IJ)=float(IYEAR ) ! 004001 YEAR YEAR 7383 m=m+1 7384 values( m+IJ)=float(IMONTH) ! 004002 MONTH MONTH 7385 m=m+1 7386 values( m+IJ)=float(KDEC(1)) ! 004003 DAY DAY 7387 m=m+1 7388 values( m+IJ)=float(KDEC(2)) ! 004004 HOUR HOUR 7389 m=m+1 7390 values( m+IJ)=float(KDEC(9)) ! 004005 MINUTE MINUTE 7391 m=m+1 7392 values( m+IJ)=KDEC(5)/100. ! 005001 LATITUDE (HIGH ACCURACY) DEGREE 7393 m=m+1 7394 values( m+IJ)=KDEC(6)/100. ! 006001 LONGITUDE (HIGH ACCURACY) DEGREE 7395 IF(KDEC(8).NE.MINDIC) THEN 7396 m=m+1 7397 if(istha(idx).ne.9999) then 7398 values( m+IJ)=float(istha(idx)) 7399 else 7400 values( m+IJ)=rvind 7401 end if 7402c values( m+IJ)=float(KDEC(8)) ! 007030 HEIGHT OF STATION GROUND ABOVE MEAN SEA M 7403 ELSE 7404 m=m+1 7405 values( m+IJ)=RVIND 7406 END IF 7407 IF(KDEC(8).NE.MINDIC) THEN 7408 m=m+1 7409 if(isthp(idx).ne.9999) then 7410 values( m+IJ)=float(isthp(idx)) 7411 else 7412 values( m+IJ)=rvind 7413 end if 7414c values( m+IJ)=float(KDEC(8)) 7415 ELSE 7416 m=m+1 7417 values( m+IJ)=RVIND ! 007031 HEIGHT OF BAROMETER ABOVE MEAN SEA LEVEL M 7418 END IF 7419 IF(KDEC(34).NE.MINDIC) THEN 7420 m=m+1 7421 values( m+IJ)=KDEC(34)*10. ! 010004 PRESSURE PA 7422 ELSE 7423 m=m+1 7424 values( m+IJ)=RVIND 7425 END IF 7426 IF(KDEC(35).NE.MINDIC) THEN 7427 m=m+1 7428 values( m+IJ)=KDEC(35)*10. ! 010051 PRESSURE REDUCED TO MEAN SEA LEVEL PA 7429 ELSE 7430 m=m+1 7431 values( m+IJ)=RVIND 7432 END IF 7433 IF(KDEC(39).NE.MINDIC) THEN 7434 m=m+1 7435 values( m+IJ)=KDEC(39)*10. ! 010061 3-HOUR PRESSURE CHANGE PA 7436 ELSE 7437 m=m+1 7438 values( m+IJ)=RVIND 7439 END IF 7440 IF(KDEC(38).NE.MINDIC) THEN 7441 m=m+1 7442 values( m+IJ)=KDEC(38) ! 010063 CHARACTERISTIC OF PRESSURE TENDENCY CODE TABLE 010063 7443 IF(KDEC(38).GE.9) values( m+IJ)=15. 7444 ELSE 7445 m=m+1 7446 values( m+IJ)=RVIND 7447 END IF 7448 m=m+1 7449 values( m+IJ)=RVIND ! 010062 24-HOUR PRESSURE CHANGE PA 7450 IF(KDEC(36).NE.MINDIC) THEN 7451 m=m+1 7452 values( m+IJ)=KDEC(36)*100. ! 007004 PRESSURE PA 7453 ELSE 7454 m=m+1 7455 values( m+IJ)=RVIND 7456 END IF 7457 IF(KDEC(37).NE.MINDIC) THEN 7458 m=m+1 7459 values( m+IJ)=KDEC(37) 7460 ELSE 7461 m=m+1 7462 values( m+IJ)=RVIND ! 010009 GEOPOTENTIAL HEIGHT GPM 7463 END IF 7464 m=m+1 7465 if(RH_tem(idx).ne.99.9) then 7466 values( m+IJ)=RH_tem(idx) ! 007032 HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR M 7467 else 7468 values( m+IJ)=rvind 7469 end if 7470 IF(KDEC(31).NE.MINDIC) THEN 7471 m=m+1 7472 values( m+IJ)=KDEC(31)/10.+273.15 ! 012101 TEMPERATURE/DRY-BULB TEMPERATURE K 7473 ELSE 7474 m=m+1 7475 values( m+IJ)=RVIND 7476 END IF 7477 IF(KDEC(32).NE.MINDIC) THEN 7478 m=m+1 7479 values( m+IJ)=KDEC(32)/10.+273.15 ! 012103 DEW-POINT TEMPERATURE K 7480 ELSE 7481 m=m+1 7482 values( m+IJ)=RVIND 7483 END IF 7484 IF(KDEC(33).NE.MINDIC) THEN 7485 m=m+1 7486 values( m+IJ)=KDEC(33) ! 013003 RELATIVE HUMIDITY % 7487 ELSE 7488 m=m+1 7489 values( m+IJ)=RVIND 7490 END IF 7491 m=m+1 7492 if(RH_vis(idx).ne.99.9) then 7493 values( m+IJ)=RH_vis(idx) ! 007032 HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR M 7494 else 7495 values( m+IJ)=rvind 7496 end if 7497 IF(KDEC(27).NE.MINDIC) THEN 7498 m=m+1 7499 values( m+IJ)=KDEC(27) ! 020001 HORIZONTAL VISIBILITY M 7500 ELSE 7501 m=m+1 7502 values( m+IJ)=RVIND 7503 END IF 7504 m=m+1 7505 if(RH_prec(idx).ne.99.9) then 7506 values( m+IJ)=RH_prec(idx) ! 007032 HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR M 7507 else 7508 values( m+IJ)=rvind 7509 end if 7510 IF(KINT(117).NE.MINDIC) THEN 7511 m=m+1 7512 if(KINT(117).eq.9999) then 7513 values( m+IJ)=-0.1 7514 else 7515 values( m+IJ)=KINT(117)/10. ! 013023 TOTAL PRECIPITATION PAST 24 HOURS KG/M**2 7516 end if 7517 ELSE 7518 m=m+1 7519 values( m+IJ)=RVIND 7520 END IF 7521 m=m+1 7522 values( m+IJ)=rvind ! 007032 HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR M 7523 IF(KDEC(42).NE.MINDIC) THEN 7524 CALL IC2700(KDEC(42),ICOVER) 7525 if(ICOVER.ne. 999999) then 7526 m=m+1 7527 values( m+IJ)=ICOVER ! 020010 CLOUD COVER (TOTAL) % 7528 else 7529 m=m+1 7530 values( m+IJ)=RVIND 7531 end if 7532 ELSE 7533 ICOVER=999999 7534 m=m+1 7535 values( m+IJ)=RVIND 7536 END IF 7537 ILT=999 7538 if(KDEC(45).NE.MINDIC.AND.KDEC(45).NE.14) THEN 7539 ILT=KDEC(45)+30 7540 END IF 7541 IMT=999 7542 if(KDEC(46).NE.MINDIC.AND.KDEC(46).NE.14) THEN 7543 IMT=KDEC(46)+20 7544 END IF 7545 IHT=999 7546 if(KDEC(47).NE.MINDIC.AND.KDEC(47).NE.14) THEN 7547 IHT=KDEC(47)+10 7548 END IF 7549 7550 m=m+1 7551 IF(ILT.EQ.999.AND.IMT.EQ.999.AND.IHT.EQ.999) THEN 7552 values( m+IJ)=RVIND ! 008002 vertical significance 7553 ELSEIF(ILT.NE.999.AND.ILT.NE.30) THEN 7554 values( m+IJ)=7. 7555 ELSEIF(IMT.NE.999.AND.IMT.NE.20) THEN 7556 values( m+IJ)=8. 7557 ELSE 7558 values( m+IJ)=9. 7559 END IF 7560 IF(ICOVER.EQ.113) THEN 7561 values( m+IJ)=5. 7562 ELSEIF(ICOVER.EQ.0) THEN 7563 values( m+IJ)=62. 7564 ELSEIF(ICOVER.EQ.999999) THEN 7565 values( m+IJ)=RVIND 7566 END IF 7567C 7568 m=m+1 7569 IF(ICOVER.EQ.0) THEN 7570 values( m+IJ)=0. 7571 ELSEIF(ICOVER.EQ.113) THEN 7572 values( m+IJ)=9 7573 ELSEIF(KDEC(44).NE.MINDIC) THEN 7574 values( m+IJ)=KDEC(44) ! 020011 cloud amount 7575 ELSE 7576 values( m+IJ)=RVIND 7577 END IF 7578C 7579 m=m+1 7580 if(ist.eq.669) then 7581 print*,'icover=',icover,KDEC(77),KDEC(43) 7582 end if 7583 IF(ICOVER.EQ.0) THEN 7584 values( m+IJ)=RVIND 7585 ELSEIF(ICOVER.EQ.999999) THEN 7586 IF(KDEC(77).NE.MINDIC) THEN 7587 values( m+IJ)=KDEC(77) 7588 END IF 7589 ELSEIF(ICOVER.EQ.113) THEN 7590 IF(KDEC(77).NE.MINDIC) THEN 7591 values( m+IJ)=KDEC(77) 7592 ELSE 7593 values( m+IJ)=RVIND 7594 END IF 7595 ELSE 7596 IF(KDEC(43).NE.MINDIC.and.KDEC(43).NE.16381.and. 7597 1 KDEC(43).NE.16382.and.KDEC(43).NE.14) THEN 7598 values( m+IJ)=KDEC(43) 7599 IF(KDEC(77).NE.MINDIC) THEN 7600 values( m+IJ)=KDEC(77) ! 020013 height of base of cloud 7601 END IF 7602 ELSE 7603 values( m+IJ)=RVIND 7604 END IF 7605 END IF 7606C 7607 m=m+1 7608 IF(KINT(18).EQ.0) then 7609 values( m+IJ)=30. 7610 ELSEIF(KINT(18).EQ.9) THEN 7611 values( m+IJ)=62. 7612 ELSEIF(kint(18).EQ.MINDIC) THEN 7613 values( m+IJ)=RVIND 7614 ELSEIF(KDEC(45).NE.MINDIC.AND.KDEC(45).NE.14) THEN 7615 values( m+IJ)=KDEC(45)+30. ! 020012 CLOUD TYPE CODE TABLE 020012 7616 ELSE 7617 values( m+IJ)=rvind 7618 END IF 7619 m=m+1 7620 IF(KINT(18).EQ.0) then 7621 values( m+IJ)=20. 7622 ELSEIF(kint(18).EQ.MINDIC) THEN 7623 values( m+IJ)=RVIND 7624 ELSEIF(KINT(18).EQ.9.OR.KDEC(46).EQ.MINDIC.OR. 7625 1 KDEC(46).EQ.14) THEN 7626 values( m+IJ)=61. 7627 ELSEIF(KDEC(46).NE.MINDIC.AND.KDEC(46).NE.14) THEN 7628 values( m+IJ)=KDEC(46)+20. ! 020012 CLOUD TYPE CODE TABLE 020012 7629 ELSE 7630 values( m+IJ)=rvind 7631 END IF 7632 m=m+1 7633 IF(KINT(18).EQ.0) then 7634 values( m+IJ)=10. 7635 ELSEIF(kint(18).EQ.MINDIC) THEN 7636 values( m+IJ)=RVIND 7637 ELSEIF(KINT(18).EQ.9.OR.KDEC(47).EQ.MINDIC.OR. 7638 1 KDEC(47).EQ.14) THEN 7639 values( m+IJ)=60. 7640 ELSEIF(KDEC(47).NE.MINDIC.AND.KDEC(47).NE.14) THEN 7641 values( m+IJ)=KDEC(47)+10. ! 020012 CLOUD TYPE CODE TABLE 020012 7642 ELSE 7643 values( m+IJ)=rvind 7644 END IF 7645 7646 m=m+1 7647 values( m+IJ)=4. ! 031001 DELAYED DESCRIPTOR REPLICATION FACTOR NUMERIC 7648C 7649 m=m+1 7650 IF(KINT(15).LE.3) THEN ! ix 7651 IF(ICOVER.EQ.113) THEN 7652 values( m+IJ)=5 ! 008002 vertical significance 7653 ELSEIF(ICOVER.EQ.999999) THEN 7654 values( m+IJ)=RVIND 7655 ELSE 7656 IF(KDEC(75).NE.MINDIC) THEN 7657 values( m+IJ)=1. 7658 else 7659 values( m+IJ)=rvind 7660 end if 7661 END IF 7662 ELSEIF(KINT(15).GT.3.AND.KINT(15).LE.7) THEN 7663 IF(KDEC(75).EQ.9) THEN 7664 values( m+IJ)=5 7665 ELSE 7666 IF(KDEC(75).NE.MINDIC) THEN 7667 values( m+IJ)=21 7668 else 7669 values( m+IJ)=rvind 7670 end if 7671 END IF 7672 ELSE 7673 values( m+IJ)=RVIND 7674 END IF 7675C 7676 m=m+1 7677 IF(KDEC(75).NE.MINDIC) THEN 7678 values( m+IJ)=KDEC(75) ! 020011 CLOUD AMOUNT CODE TABLE 020011 7679 ELSE 7680 values( m+IJ)=RVIND 7681 END IF 7682 7683 m=m+1 7684 IF(KINT(18).EQ.9 ) then 7685 if(KDEC(77).NE.MINDIC) THEN 7686 values( m+IJ)=59. 7687 else 7688 values( m+IJ)=rvind 7689 end if 7690 ELSEIF(KINT(18).EQ.MINDIC) THEN 7691 values( m+IJ)=RVIND 7692 ELSEIF(KDEC(76).NE.MINDIC) THEN 7693 values( m+IJ)=KDEC(76) ! 020012 cloud type 7694 ELSE 7695 values( m+IJ)=RVIND 7696 END IF 7697C 7698 m=m+1 7699 IF(KDEC(77).NE.MINDIC) THEN 7700 values( m+IJ)=KDEC(77) ! 020013 HEIGHT OF BASE OF CLOUD M 7701 ELSE 7702 values( m+IJ)=RVIND 7703 END IF 7704 m=m+1 7705C----- 7706 7707C------ 7708 values( m+IJ)=2. ! 008002 VERTICAL SIGNIFICANCE (SURFACE OBSERVATI CODE TABLE 008002 7709 IF(KINT(15).GT.3.AND.KINT(15).LE.7) values( m+IJ)=22. 7710 IF(KDEC(78).EQ.MINDIC) THEN 7711 values( m+IJ)=rvind 7712 end if 7713 m=m+1 7714 IF(KDEC(78).NE.MINDIC) THEN 7715 values( m+IJ)=KDEC(78) ! 020011 CLOUD AMOUNT CODE TABLE 020011 7716 ELSE 7717 values( m+IJ)=RVIND 7718 END IF 7719 7720 m=m+1 7721 IF(KINT(18).EQ.9) THEN 7722 if(KDEC(80).NE.MINDIC) THEN 7723 values( m+IJ)=59. 7724 else 7725 values( m+IJ)=rvind 7726 end if 7727 ELSEIF(KINT(18).EQ.MINDIC) THEN 7728 values( m+IJ)=RVIND 7729 ELSEIF(KDEC(79).NE.MINDIC) THEN 7730 values( m+IJ)=KDEC(79) ! 020012 cloud type 7731 ELSE 7732 values( m+IJ)=RVIND 7733 END IF 7734 7735 m=m+1 7736 IF(KDEC(80).NE.MINDIC) THEN 7737 values( m+IJ)=KDEC(80) ! 020013 HEIGHT OF BASE OF CLOUD M 7738 ELSE 7739 values( m+IJ)=RVIND 7740 END IF 7741 m=m+1 7742 values( m+IJ)=3. ! 008002 VERTICAL SIGNIFICANCE (SURFACE OBSERVATI CODE TABLE 008002 7743 IF(KINT(15).GT.3.AND.KINT(15).LE.7) values( m+IJ)=23. 7744 IF(KDEC(81).EQ.MINDIC) THEN 7745 values( m+IJ)=rvind 7746 end if 7747 m=m+1 7748 IF(KDEC(81).NE.MINDIC) THEN 7749 values( m+IJ)=KDEC(81) ! 020011 CLOUD AMOUNT CODE TABLE 020011 7750 ELSE 7751 values( m+IJ)=RVIND 7752 END IF 7753 7754 m=m+1 7755 IF(KINT(18).EQ.9) THEN 7756 if(KDEC(83).NE.MINDIC) THEN 7757 values( m+IJ)=59. 7758 else 7759 values( m+IJ)=rvind 7760 end if 7761 ELSEIF(KINT(18).EQ.MINDIC) THEN 7762 values( m+IJ)=RVIND 7763 ELSEIF(KDEC(82).NE.MINDIC) THEN 7764 values( m+IJ)=KDEC(82) ! 020012 cloud type 7765 ELSE 7766 values( m+IJ)=RVIND 7767 END IF 7768 7769 7770 m=m+1 7771 IF(KDEC(83).NE.MINDIC) THEN 7772 values( m+IJ)=KDEC(83) ! 020013 HEIGHT OF BASE OF CLOUD M 7773 ELSE 7774 values( m+IJ)=RVIND 7775 END IF 7776 m=m+1 7777 values( m+IJ)=4. ! 008002 VERTICAL SIGNIFICANCE (SURFACE OBSERVATI CODE TABLE 008002 7778 IF(KINT(15).GT.3.AND.KINT(15).LE.7) values( m+IJ)=24. 7779 IF(KDEC(84).EQ.MINDIC) THEN 7780 values( m+IJ)=rvind 7781 end if 7782 m=m+1 7783 IF(KDEC(84).NE.MINDIC) THEN 7784 values( m+IJ)=KDEC(84) ! 020011 CLOUD AMOUNT CODE TABLE 020011 7785 ELSE 7786 values( m+IJ)=RVIND 7787 END IF 7788 7789 m=m+1 7790 IF(KINT(18).EQ.9) THEN 7791 if(KDEC(86).NE.MINDIC) THEN 7792 values( m+IJ)=59. 7793 else 7794 values( m+IJ)=rvind 7795 end if 7796 ELSEIF(KINT(18).EQ.MINDIC) THEN 7797 values( m+IJ)=RVIND 7798 ELSEIF(KDEC(85).NE.MINDIC) THEN 7799 values( m+IJ)=KDEC(85) ! 020012 cloud type 7800 ELSE 7801 values( m+IJ)=RVIND 7802 END IF 7803 7804 m=m+1 7805 IF(KDEC(86).NE.MINDIC) THEN 7806 values( m+IJ)=KDEC(86) ! 020013 HEIGHT OF BASE OF CLOUD M 7807 ELSE 7808 values( m+IJ)=RVIND 7809 END IF 7810 7811 7812 IF(KINT(149).NE.MINDIC) THEN 7813 m=m+1 7814 values( m+IJ)=1. ! 031001 DELAYED DESCRIPTOR REPLICATION FACTOR NUMERIC 7815 m=m+1 7816 values( m+IJ)=RVIND ! vertical sign 7817 m=m+1 7818 values( m+IJ)=RVIND ! 020011 CLOUD AMOUNT CODE TABLE 020011 7819 IF(ICOVER.EQ.113.OR.ICOVER.EQ.999999) THEN 7820 values( m+IJ)=RVIND 7821 ELSE 7822 IF(KINT(150).NE.MINDIC) THEN 7823 values( m+IJ)=KINT(150) ! cloud amount 7824 values( m-1+IJ)=11. ! 008002 VERTICAL SIGNIFICANCE (SURFACE OBSERVATI CODE TABLE 008002 7825 IF(ICOVER.EQ.113.OR.ICOVER.EQ.999999) THEN 7826 values( m-1+IJ)=10. 7827 END IF 7828 END IF 7829 END IF 7830 7831 IF(KINT(151).NE.MINDIC) THEN 7832 m=m+1 7833 IF(ICOVER.EQ.113.OR.ICOVER.EQ.999999) THEN 7834 values( m+IJ)=RVIND 7835 ELSE 7836 values( m+IJ)=KINT(151) ! 020012 CLOUD TYPE CODE TABLE 020012 7837 END IF 7838 ELSE 7839 m=m+1 7840 values( m+IJ)=RVIND 7841 END IF 7842 m=m+1 7843 values( m+IJ)=RVIND ! 020014 HEIGHT OF TOP OF CLOUD M 7844 IF(ICOVER.EQ.113.OR.ICOVER.EQ.999999) THEN 7845 values( m+IJ)=RVIND 7846 ELSE 7847 IF(KINT(152).NE.MINDIC) THEN 7848 values( m+IJ)=KINT(152)*100. 7849 IF(values( m+IJ).GT.values( 12+IJ)) THEN 7850 values( m-3+IJ)=10. 7851 END IF 7852 END IF 7853 END IF 7854 m=m+1 7855 values( m+IJ)=RVIND ! 020017 CLOUD TOP DESCRIPTION CODE TABLE 020017 7856 IF(ICOVER.EQ.113.OR.ICOVER.EQ.999999) THEN 7857 values( m+IJ)=RVIND 7858 ELSE 7859 IF(KINT(153).NE.MINDIC) THEN 7860 values( m+IJ)=KINT(153) 7861 END IF 7862 END IF 7863 ELSE 7864 m=m+1 7865 values( m+IJ)=0. ! 031001 DELAYED DESCRIPTOR REPLICATION FACTOR NUMERIC 7866 END IF 7867c 7868 m=m+1 7869 values( m+IJ)=7. ! 008002 VERTICAL SIGNIFICANCE (SURFACE OBSERVATI CODE TABLE 008002 7870 m=m+1 7871 values( m+IJ)=RVIND ! 020054 (VAL) TRUE DIRECTION FROM WHICH CLOUDS A DEGREE TRUE 7872 m=m+1 7873 values( m+IJ)=8. ! 008002 VERTICAL SIGNIFICANCE (SURFACE OBSERVATI CODE TABLE 008002 7874 m=m+1 7875 values( m+IJ)=RVIND ! 020054 (VAL) TRUE DIRECTION FROM WHICH CLOUDS A DEGREE TRUE 7876 m=m+1 7877 values( m+IJ)=9. ! 008002 VERTICAL SIGNIFICANCE (SURFACE OBSERVATI CODE TABLE 008002 7878 m=m+1 7879 values( m+IJ)=RVIND ! 020054 (VAL) TRUE DIRECTION FROM WHICH CLOUDS A DEGREE TRUE 7880 m=m+1 7881 values( m+IJ)=RVIND ! 008002 VERTICAL SIGNIFICANCE (SURFACE OBSERVATI CODE TABLE 008002 7882 m=m+1 7883 values( m+IJ)=RVIND ! 005021 BEARING OR AZIMUTH DEGREE TRUE 7884 m=m+1 7885 values( m+IJ)=RVIND ! 007021 ELEVATION (SEE NOTE 2) DEGREE 7886 m=m+1 7887 values( m+IJ)=RVIND ! 020012 CLOUD TYPE CODE TABLE 020012 7888 m=m+1 7889 values( m+IJ)=RVIND ! 005021 BEARING OR AZIMUTH DEGREE TRUE 7890 m=m+1 7891 values( m+IJ)=RVIND ! 007021 ELEVATION (SEE NOTE 2) DEGREE 7892 m=m+1 7893 IF(KINT(94).NE.MINDIC) THEN 7894 values( m+IJ)=KINT(94) ! E 7895 elseif(KINT(99).NE.MINDIC) THEN 7896 values( m+IJ)=KINT(99) ! E' 7897 else 7898 values( m+IJ)=RVIND ! 020062 STATE OF THE GROUND (WITH OR WITHOUT SNO CODE TABLE 020062 7899 end if 7900 IF(KDEC(99).NE.MINDIC) THEN 7901 m=m+1 7902 values( m+IJ)=KDEC(99)/10. ! 013013 TOTAL SNOW DEPTH M 7903 ELSEIF(KDEC(97).NE.MINDIC.AND.KDEC(2).EQ.6) THEN 7904 m=m+1 7905 values( m+IJ)=0.0 7906 ELSE 7907 m=m+1 7908 values( m+IJ)=RVIND 7909 END IF 7910 m=m+1 7911 IF(KDEC(70).NE.MINDIC) THEN 7912 values( m+IJ)=KDEC(70)+273.15 7913 ELSE 7914 values( m+IJ)=RVIND ! 012113 GROUND MINIMUM TEMPERATURE, PAST 12 HOUR K 7915 END IF 7916 IF(KDEC(28).NE.MINDIC) THEN 7917 m=m+1 7918 values( m+IJ)=KDEC(28) ! 020003 PRESENT WEATHER (SEE NOTE 1) CODE TABLE 020003 7919 IF(KDEC(4).EQ.14) values( m+IJ)=KDEC(28)+100. 7920 ELSE 7921 m=m+1 7922 values( m+IJ)=RVIND 7923 END IF 7924 IH=NINT(values(8+IJ)) 7925 IF(IH.eq.0.or.IH.eq.6.or.IH.eq.12.or.IH.eq.18) then 7926 m=m+1 7927 values( m+IJ)=-6. ! 004024 TIME PERIOD OR DISPLACEMENT 7928 ELSEIF(IH.eq.3.or.IH.eq.9.or.IH.eq.15.or.IH.eq.21) then 7929 m=m+1 7930 values( m+IJ)=-3. ! 004024 TIME PERIOD OR DISPLACEMENT 7931 ELSE 7932 m=m+1 7933 values( m+IJ)=-1. ! 004024 TIME PERIOD OR DISPLACEMENT 7934 END IF 7935 MHPAST=nint(values( m+IJ)) 7936 IF(KDEC(29).NE.MINDIC) THEN 7937 m=m+1 7938 values( m+IJ)=KDEC(29) ! 020004 PAST WEATHER (1) (SEE NOTE 2) CODE TABLE 020004 7939 IF(KDEC(4).EQ.14) values( m+IJ)=KDEC(29)+10. 7940 ELSE 7941 m=m+1 7942 values( m+IJ)=RVIND 7943 END IF 7944 IF(KDEC(30).NE.MINDIC) THEN 7945 m=m+1 7946 values( m+IJ)=KDEC(30) ! 020005 PAST WEATHER (2) (SEE NOTE 2) CODE TABLE 020005 7947 IF(KDEC(4).EQ.14) values( m+IJ)=KDEC(30)+10. 7948 ELSE 7949 m=m+1 7950 values( m+IJ)=RVIND 7951 END IF 7952 m=m+1 7953 values( m+IJ)=-1. ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 7954 m=m+1 7955 values( m+IJ)=RVIND ! 014031 TOTAL SUNSHINE MINUTE 7956 m=m+1 7957 values( m+IJ)=-24. ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 7958 if(KDEC(111).ne.MINDIC) then 7959 m=m+1 7960 values( m+IJ)=KDEC(111) ! 014031 TOTAL SUNSHINE MINUTE 7961 else 7962 m=m+1 7963 values( m+IJ)=RVIND 7964 end if 7965 m=m+1 7966 if(RH_prec(idx).ne.99.9) then 7967 values( m+IJ)=RH_prec(idx) ! 007032 HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR M 7968 else 7969 values( m+IJ)=rvind 7970 end if 7971 IF(KDEC(41).NE.MINDIC) THEN 7972 m=m+1 7973 values( m+IJ)=-KDEC(41) ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 7974 ELSE 7975 m=m+1 7976 values( m+IJ)=RVIND 7977 END IF 7978 IF(KDEC(40).NE.MINDIC) THEN 7979 m=m+1 7980 IF(KDEC(40).EQ.0) THEN 7981 values( m+IJ)=0. ! 013011 TOTAL PRECIPITATION/TOTAL WATER EQUIVALE KG/M**2 TRACE 7982 ELSE 7983 values( m+IJ)=KDEC(40)/10. ! 013011 TOTAL PRECIPITATION/TOTAL WATER EQUIVALE KG/M**2 7984 END IF 7985 ELSE 7986 m=m+1 7987 values( m+IJ)=RVIND 7988 END IF 7989 IF(KDEC(141).NE.MINDIC) THEN 7990 m=m+1 7991 IF(KINT(115).ne.MINDIC) THEN 7992 values( m+IJ)=-KDEC(141) ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 7993 else 7994 values( m+IJ)=-3. 7995 end if 7996 ELSE 7997 m=m+1 7998 values( m+IJ)=RVIND 7999 END IF 8000 IF(KDEC(140).NE.MINDIC) THEN 8001 m=m+1 8002 IF(KDEC(140).EQ.0) THEN 8003 values( m+IJ)=0 ! 013011 TOTAL PRECIPITATION/TOTAL WATER EQUIVALE KG/M**2. 8004 ELSE 8005 values( m+IJ)=KDEC(140)/10. ! 013011 TOTAL PRECIPITATION/TOTAL WATER EQUIVALE KG/M**2 8006 END IF 8007 ELSE 8008 m=m+1 8009 values( m+IJ)=RVIND 8010 END IF 8011 m=m+1 8012 if(RH_tem(idx).ne.99.9) then 8013 values( m+IJ)=RH_tem(idx) ! 007032 HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR M 8014 else 8015 values( m+IJ)=rvind 8016 end if 8017 if(KDEC(72).ne.MINDIC) then 8018 m=m+1 8019 values( m+IJ)=-KDEC(72) ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 8020 else 8021 m=m+1 8022 values( m+IJ)=RVIND 8023 end if 8024 m=m+1 8025 if(KDEC(72).ne.MINDIC) then 8026 values( m+IJ)=0. ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 8027 else 8028 values( m+IJ)=RVIND 8029 end if 8030 if(KDEC(71).NE.MINDIC) THEN 8031 m=m+1 8032 values( m+IJ)=KDEC(71)/10.+273.15 ! 012111 MAXIMUM TEMPERATURE, AT HEIGHT AND OVER K 8033 else 8034 m=m+1 8035 values( m+IJ)=RVIND 8036 end if 8037 if(KDEC(74).NE.MINDIC) then 8038 m=m+1 8039 values( m+IJ)=-KDEC(74) ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 8040 else 8041 m=m+1 8042 values( m+IJ)=rvind 8043 end if 8044 m=m+1 8045 if(KDEC(74).NE.MINDIC) then 8046 values( m+IJ)=0. ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 8047 else 8048 values( m+IJ)=RVIND 8049 END IF 8050 if(KDEC(73).ne.mindic) then 8051 m=m+1 8052 values(m+IJ)=KDEC(73)/10.+273.15 ! 012112 MINIMUM TEMPERATURE, AT HEIGHT AND OVER K 8053 else 8054 m=m+1 8055 values(m+IJ)=rvind 8056 end if 8057 m=m+1 8058 if(RH_wind(idx).ne.99.9) then 8059 values(m+IJ)=RH_wind(idx) ! 007032 HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR M 8060 else 8061 values(m+IJ)=rvind 8062 end if 8063 m=m+1 8064 if(KINT(3).le.1) values(m+IJ)=8. 8065 if(KINT(3).eq.3.or.KINT(3).eq.4) values(m+IJ)=12. ! 002002 TYPE OF INSTRUMENTATION FOR WIND MEASURE FLAG TABLE 002002 8066 m=m+1 8067 values(m+IJ)=2. ! 008021 TIME SIGNIFICANCE CODE TABLE 008021 8068 m=m+1 8069 values(m+IJ)=-10. ! 004025 TIME PERIOD OR DISPLACEMENT MINUTE 8070 IF(KDEC(25).NE.MINDIC) THEN 8071 m=m+1 8072 values(m+IJ)=KDEC(25) ! 011001 WIND DIRECTION DEGREE TRUE 8073 ELSE 8074 m=m+1 8075 values(m+IJ)=RVIND 8076 END IF 8077 IF(KDEC(26).NE.MINDIC) THEN 8078 m=m+1 8079 values(m+IJ)=KDEC(26) ! 011002 WIND SPEED M/S 8080 ELSE 8081 m=m+1 8082 values(m+IJ)=RVIND 8083 END IF 8084 m=m+1 8085 values(m+IJ)=RVIND ! 008021 TIME SIGNIFICANCE CODE TABLE 008021 8086 m=m+1 8087 8088 iidir=0 8089 iiten=0 8090 i11=0 8091 IPERIOD=0 8092 do ii=138,147,3 8093 if(kint(ii).eq.7) then 8094C period 8095 CALL IC4077(kint(ii+1),MINDIC,IPERIOD) 8096 elseif(kint(ii).eq.10) then 8097C highest gust -10 minutes 8098 iiten=ii 8099 elseif(kint(ii).eq.11) then 8100C highest gust -period 8101 i11=ii 8102 elseif(kint(ii).eq.15) then 8103C highest gust wind direction 8104 iidir=ii 8105 end if 8106 end do 8107 8108 values(m+IJ)=-10. ! 004025 TIME PERIOD OR DISPLACEMENT MINUTE 8109 8110 m=m+1 8111 if(iidir.ne.0.and.iiten.ne.0) then 8112 if(kint(iidir).eq.15.and.kint(iidir+1).ne.mindic.and. 8113 1 kint(iiten).eq.10) then 8114 values(m+IJ)=iidir ! 011043 MAXIMUM WIND GUST DIRECTION DEGREE TRUE 8115 else 8116 values(m+IJ)=RVIND ! 8117 end if 8118 else 8119 values(m+IJ)=RVIND 8120 end if 8121 m=m+1 8122 if(iiten.ne.0) then 8123 if(kint(iiten).eq.10.and.kint(iiten+1).ne.mindic) then 8124 if(kint(3).eq.1) then 8125 values(m+IJ)=kint(iiten+1) ! 011041 MAXIMUM WIND GUST SPEED M/S 8126 else 8127 values(m+IJ)=kint(iiten+1)*.5148 !011041 MAXIMUM WIND GUST SPEED KNOTS 8128 end if 8129 else 8130 values(m+IJ)=RVIND 8131 end if 8132 else 8133 values(m+IJ)=RVIND 8134 end if 8135 m=m+1 8136 IF(IPERIOD.EQ.0) THEN 8137 values(m+IJ)=MHPAST*60. ! 004025 TIME PERIOD OR DISPLACEMENT MINUTE 8138 ELSE 8139 values(m+IJ)=IPERIOD 8140 END IF 8141 m=m+1 8142 if(iidir.ne.0.and.i11.ne.0) then 8143 if(kint(iidir).eq.15.and.kint(iidir+1).ne.mindic.and. 8144 1 kint(i11).eq.11) then 8145 values(m+IJ)=kint(iidir) ! 011043 MAXIMUM WIND GUST DIRECTION DEGREE TRUE 8146 else 8147 values(m+IJ)=RVIND 8148 end if 8149 else 8150 values(m+IJ)=RVIND 8151 end if 8152 m=m+1 8153 if(i11.ne.0) then 8154 if(kint(i11).eq.11.and.kint(i11+1).ne.mindic) then 8155 if(kint(3).eq.1) then 8156 values(m+IJ)=kint(i11+1) ! 011041 MAXIMUM WIND GUST SPEED M/S 8157 else 8158 values(m+IJ)=kint(i11+1)*.5148 !011041 MAXIMUM WIND GUST SPEED KNOTS 8159 end if 8160 else 8161 values(m+IJ)=RVIND 8162 end if 8163 else 8164 values(m+IJ)=RVIND 8165 end if 8166 m=m+1 8167 values(m+IJ)=RVIND ! 007032 HEIGHT OF SENSOR ABOVE LOCAL GROUND (OR M 8168 m=m+1 8169 values(m+IJ)=-24. ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 8170 m=m+1 8171 values(m+IJ)=RVIND ! 002004 TYPE OF INSTRUMENTATION FOR EVAPORATION CODE TABLE 002004 8172 if(kdec(110).ne.MINDIC) then 8173 m=m+1 8174 values(m+IJ)=KDEC(110) ! 013033 EVAPORATION/EVAPOTRANSPIRATION KG/M**2 8175 else 8176 m=m+1 8177 values(m+IJ)=RVIND 8178 end if 8179 m=m+1 8180 values(m+IJ)=-1. ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 8181 m=m+1 8182 values(m+IJ)=RVIND ! 014002 LONG-WAVE RADIATION, INTEGRATED OVER PER J/M**2 8183 m=m+1 8184 values(m+IJ)=RVIND ! 014004 SHORT-WAVE RADIATION, INTEGRATED OVER PE J/M**2 8185 m=m+1 8186 values(m+IJ)=RVIND ! 014016 NET RADIATION, INTEGRATED OVER PERIOD SP J/M**2 8187 m=m+1 8188 values(m+IJ)=RVIND ! 014028 GLOBAL SOLAR RADIATION (HIGH ACCURACY), J/M**2 8189 m=m+1 8190 values(m+IJ)=RVIND ! 014029 DIFFUSE SOLAR RADIATION (HIGH ACCURACY), J/M**2 8191 m=m+1 8192 values(m+IJ)=RVIND ! 014030 DIRECT SOLAR RADIATION (HIGH ACCURACY), J/M**2 8193 m=m+1 8194 values(m+IJ)=-24. ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 8195 m=m+1 8196 values(m+IJ)=RVIND ! 014002 LONG-WAVE RADIATION, INTEGRATED OVER PER J/M**2 8197 m=m+1 8198 values(m+IJ)=RVIND ! 014004 SHORT-WAVE RADIATION, INTEGRATED OVER PE J/M**2 8199 if(kdec(112).ne.mindic) then 8200 m=m+1 8201 values(m+IJ)=KDEC(112)*1000 ! 014016 NET RADIATION, INTEGRATED OVER PERIOD SP J/M**2 8202 else 8203 m=m+1 8204 values(m+IJ)=RVIND 8205 end if 8206 m=m+1 8207 values(m+IJ)=RVIND ! 014028 GLOBAL SOLAR RADIATION (HIGH ACCURACY), J/M**2 8208 m=m+1 8209 values(m+IJ)=RVIND ! 014029 DIFFUSE SOLAR RADIATION (HIGH ACCURACY), J/M**2 8210 m=m+1 8211 values(m+IJ)=RVIND ! 014030 DIRECT SOLAR RADIATION (HIGH ACCURACY), J/M**2 8212 m=m+1 8213 values(m+IJ)=RVIND ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 8214 m=m+1 8215 values(m+IJ)=RVIND ! 004024 TIME PERIOD OR DISPLACEMENT HOUR 8216 m=m+1 8217 values(m+IJ)=RVIND ! 012049 (VAL) TEMPERATURE CHANGE OVER SPECIFIED K 8218C 8219C 8220c DO i=1,20 8221c CVALS(1)(I:I)=char(255) 8222c END DO 8223C 8224 END IF 8225 ELSE 8226 8227 if(NSUB .ne.0) then 8228C 8229C Fill in KDATA 8230C 8231 IF(NSUB .GT. KDLEN) THEN 8232 print*,'Number of subsets greater than KDLEN parameter' 8233 call exit(2) 8234 END IF 8235 iix=0 8236 do iii=1,NSUB 8237 ij=(iii-1)*kelem 8238 iix=iix+1 8239 KDATA(iix)=4 8240 iix=iix+1 8241 KDATA(iix)=nint(values(54+IJ)) 8242 end do 8243C 8244 KTDLEN=1 8245 KTDLST(1)=307080 8246 8247C Find first subset which is not NIL 8248 8249 inil=0 8250 do i=1,NSUB 8251 ij=(i-1)*kelem 8252 if(abs(values(5+ij)-rvind)/rvind .gt.eps) then 8253 inil=i 8254 exit 8255 end if 8256 end do 8257 8258 IF(INIL .eq.0) Then 8259 print*,'NIL bulletin detected' 8260 return 8261 END IF 8262C 8263C Fill in KSEC0 8264C 8265 KSEC0(1)=0 8266 KSEC0(2)=0 8267 KSEC0(3)=4 8268C 8269C Fill in KSEC1 8270C 8271 KSEC1( 1)=22 ! length 8272 KSEC1( 2)=4 ! bufr edition 8273 KSEC1( 3)=NCENTRE ! originating centre 8274 KSEC1( 4)=KDEC(21) ! update sequence number 8275 KSEC1( 5)=0 ! presence of section 2 8276 KSEC1( 6)=0 ! bufr message type (bufr table A) 8277 KSEC1( 7)=170 ! bufr message subtype 8278 KSEC1( 8)=0 8279 8280 KSEC1( 9)=NINT(values(5+(INIL-1)*kelem)) ! year 8281 IF(KSEC1( 2).le.3) then 8282 KSEC1( 9)=mod(nint(values(5+(INIL-1)*kelem)),100) 8283 if(KSEC1( 9).eq.0) KSEC1( 9)=100 8284 END IF 8285 KSEC1(10)=NINT(values(6+(INIL-1)*kelem)) 8286 KSEC1(11)=NINT(values(7+(INIL-1)*kelem)) 8287 KSEC1(12)=NINT(values(8+(INIL-1)*kelem)) 8288 KSEC1(13)=NINT(values(9)+(INIL-1)*kelem) 8289 KSEC1(14)=0 ! bufr master tables used 8290 KSEC1(15)=14 ! version of master table used 8291 KSEC1(16)=0 ! originating sub-centre 8292 KSEC1(17)=0 ! international sub-category 8293 if(KSEC1(12).EQ.3.or.KSEC1(12).EQ.9.or. 8294 1 KSEC1(12).EQ.15.or.KSEC1(12).EQ.21) KSEC1(17)=1 8295 if(KSEC1(12).EQ.0.or.KSEC1(12).EQ.6.or. 8296 1 KSEC1(12).EQ.12.or.KSEC1(12).EQ.18) KSEC1(17)=2 8297 KSEC1(18)=0 ! second 8298C 8299C Fill in KSEC2 8300 8301 NYEAR =NINT(VALUES(5+(inil-1)*kelem)) 8302 NMONTH =NINT(VALUES(6+(inil-1)*kelem)) 8303 NDAY =NINT(VALUES(7+(inil-1)*kelem)) 8304 NHOUR =NINT(VALUES(8+(inil-1)*kelem)) 8305 NMINUTE=NINT(VALUES(9+(inil-1)*kelem)) 8306 NSECOND=0 8307C 8308 NLAT1=NINT(VALUES(10+(inil-1)*kelem)*100000)+9000000 8309 NLON1=NINT(VALUES(11+(inil-1)*kelem)*100000)+18000000 8310 NLAT2=0 8311 NLON2=0 8312 CIDENT= CHAR(KINT(09))//CHAR(KINT(10))//CHAR(KINT(11))// 8313 1 CHAR(KINT(12))//CHAR(KINT(13))//' ' 8314 8315 NTYPE=1 ! SURFACE DATA 8316 NSBTYPE=170 ! ! SYNOP LAND 8317 IF(KSEC1(5).eq.128) then 8318 key( 1)=52 8319 key( 2)=NTYPE 8320 key( 3)=NSBTYPE 8321 key( 4)=NYEAR 8322 key( 5)=NMONTH 8323 key( 6)=NDAY 8324 key( 7)=NHOUR 8325 key( 8)=NMINUTE 8326 key( 9)=NSECOND 8327 key(10)=NLON1 8328 key(11)=NLAT1 8329 key(12)=NLON1 8330 key(13)=NLAT1 8331 key(14)=1 8332 key(15)=0 8333 WRITE(CIDENT(1:2),'(I2.2)') NINT(VALUES(1+IJ)) 8334 WRITE(CIDENT(3:5),'(I3.3)') NINT(VALUES(2+IJ)) 8335 key(16)=ichar(cident(1:1)) 8336 key(17)=ichar(cident(2:2)) 8337 key(18)=ichar(cident(3:3)) 8338 key(19)=ichar(cident(4:4)) 8339 key(20)=ichar(cident(5:5)) 8340 key(21)=32 8341 key(22)=32 8342 key(23)=32 8343 key(24)=32 8344C 8345 KSEC2(1)=52 8346 8347 NOBS=1 8348 NRECR=1 8349 NOBS=NSUB 8350 NBUFTYPE=0 8351C 8352 NCORR=0 8353 NNIL=0 8354C 8355 NQC=70 8356C 8357 CALL ASCTIM(CTIME) 8358 READ(CTIME,'(I2,10X,I2,1X,I2,1X,I2,1X,I2)') IDD,IHH,IMM,ISS,ICC 8359C 8360 key(26)=idd 8361 key(27)=ihh 8362 key(28)=imm 8363 key(29)=iss 8364 key(30)=NRDAY 8365 key(31)=NRHOUR 8366 key(32)=NRMIN 8367 key(33)=NRSEC 8368c 8369 do jjj=34,45 8370 key(jjj)=0 8371 end do 8372c 8373 key(46)=70 8374 kerr=0 8375 call bupkey(key,ksec1,ksec2,kerr) 8376 if(kerr.ne.0) then 8377 print*,'BUPKEY: error',kerr 8378 call exit(2) 8379 end if 8380 END IF 8381 8382C Fill in KSEC3 8383C 8384 KSEC3(1)=0 8385 KSEC3(2)=0 8386 KSEC3(3)=NSUB ! number of subsets 8387 KSEC3(4)=128 ! uncompressed observation 8388C 8389C 8390 KPMISS=1 8391 KPRUS=1 8392 NOKEY=0 8393 CALL BUPRQ(KPMISS,KPRUS,NOKEY) 8394 8395C Pack BUFR 8396C 8397 KBUFL=JBUFL 8398 CALL BUFREN(KSEC0 ,KSEC1,KSEC2,KSEC3,KSEC4, 8399 1 KTDLEN,KTDLST,KDLEN,KDATA, 8400 2 KELEM,KVALS,VALUES,CVALS,KBUFL,KBUFR,IERR) 8401 IF(IERR.GT.0) THEN 8402 RETURN 8403 END IF 8404 8405C 8406C WRITE DATA INTO OUTPUT FILE 8407C 8408 KBUFL=KBUFL*4 8409 CALL PBWRITE(IUNIT1,KBUFR,KBUFL,IERR) 8410 if(ierr.ge.0) then 8411 ierr=0 8412 end if 8413C 8414 end if 8415 END IF 8416C 8417C ----------------------------------------------------------------- 8418 RETURN 8419 END 8420 SUBROUTINE KTOMPSI(IA) 8421C 8422C 8423C**** *KTOMPSI* 8424C 8425C 8426C PURPOSE. 8427C -------- 8428C 8429C CONVERTS KNOTS TO METRES PER SECOND, ROUNDING 8430C TO NEAREST METRE. 8431C 8432C INPUT : IA WIND SPEED IN KNOTS (INTEGER) 8433C 8434C OUTPUT : IA WIND SPEED IN M/S (INTEGER) 8435C 8436C 8437C** INTERFACE. 8438C ---------- 8439C 8440C *CALL* *KTOMPSI(IA)* 8441C 8442C METHOD. 8443C ------- 8444C 8445C NONE. 8446C 8447C 8448C EXTERNALS. 8449C ---------- 8450C 8451C NONE. 8452C 8453C REFERENCE. 8454C ---------- 8455C 8456C NONE. 8457C 8458C AUTHOR. 8459C ------- 8460C 8461C M. DRAGOSAVAC *ECMWF* AUG 1988. 8462C 8463C 8464C MODIFICATIONS. 8465C -------------- 8466C 8467C NONE. 8468C 8469C 8470 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 8471C 8472C 8473C 8474C ------------------------------------------------------------------ 8475C 8476C* 1. CONVERT WIND IN KNOTS TO METER PER SECOND . 8477C ------------------------------------------- 8478 100 CONTINUE 8479C 8480C 8481 IA=INT(0.5148 * IA +0.5) 8482 RETURN 8483 END 8484 FUNCTION P(Z) 8485C 8486 DATA A/5.252368255329/, B/44330.769230769/ 8487 DATA C/0.000157583169442/ 8488 DATA PTRO/226.547172/, PO/1013.25/ 8489C 8490 IF (Z.GT.11000.) GO TO 50 8491 Y = 1.-Z/B 8492 P = PO*(Y**A) 8493 RETURN 8494C 849550 Y = -C*(Z-11000.) 8496 P = PTRO*EXP(Y) 8497 RETURN 8498 END 8499 SUBROUTINE SAVBULL ( IERR ) 8500C 8501C 8502C**** *SAVBULL* 8503C 8504C 8505C PURPOSE. 8506C -------- 8507C 8508C WRITE COMPLETE BULLETIN TO ERROR FILE . 8509C 8510C BULLETIN IN KCHAR(1)-KCHAR(IGS) IN CCITT 5. 8511C 8512C 8513C** INTERFACE. 8514C ---------- 8515C 8516C *CALL* *SAVBULL(IERR)* 8517C 8518C METHOD. 8519C ------- 8520C 8521C NONE. 8522C 8523C 8524C EXTERNALS. 8525C ---------- 8526C 8527C NONE. 8528C 8529C REFERENCE. 8530C ---------- 8531C 8532C NONE. 8533C 8534C AUTHOR. 8535C ------- 8536C 8537C 8538C 8539C MODIFICATIONS. 8540C -------------- 8541C 8542C M. DRAGOSAVAC *ECMWF* AUG 1988. 8543C 8544C 8545 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 8546C 8547 INCLUDE 'parameter.h' 8548 INCLUDE 'comwork.h' 8549 INCLUDE 'comindx.h' 8550 INCLUDE 'combuff.h' 8551C character*256 cf 8552C 8553C 8554 CHARACTER*80 YLINE,YLINEA 8555 CHARACTER*1 Y63 8556 CHARACTER*4 YGS 8557 CHARACTER*3 YCRLF 8558 CHARACTER*15000 YBUFF 8559C 8560 Y63=CHAR(63) 8561 YGS=CHAR(13)//CHAR(13)//CHAR(10)//CHAR(3) 8562 YCRLF=CHAR(13)//CHAR(13)//CHAR(10) 8563C ------------------------------------------------------------------ 8564C* 1. OPEN ERROR FILE AT THE BEGINNING OF THE PROCESS. 8565C ------------------------------------------------- 8566 100 CONTINUE 8567C 8568C 8569 YBUFF=' ' 8570 YLINE=' ' 8571 YLINEA=' ' 8572 I1=1 8573C 8574 IP = 1 8575 JP = IP 8576 J = IGS 8577C 8578C* 1.1 OUTPUT INITIAL CONTROL CHARACTERS. 8579C ---------------------------------- 8580 110 CONTINUE 8581C 8582 CALL NEXTPRT (JP,IGS) 8583 K = JP - IP 8584 N1 = 0 8585 DO 111 N=1,K 8586 N1 = N1 + 1 8587 IF ( KCHAR(IP).GT.127) THEN 8588 YLINEA(N1:N1)=Y63 8589 ISIGN=1 8590 KCHAR(IP)=IAND(KCHAR(IP),127) 8591 END IF 8592 YLINE(N1:N1) = CHAR(KCHAR(IP)) 8593 IP = IP + 1 8594C 8595 111 CONTINUE 8596C 8597 YBUFF(I1:)=YLINE(1:N1) 8598 I1=I1+N1 8599 IF(ISIGN.EQ.1) THEN 8600 YBUFF(I1:)=YLINEA(1:N1) 8601 I1=I1+N1 8602 YBUFF(I1:)=YCRLF 8603 I1=I1+3 8604 ISIGN=0 8605 END IF 8606C 8607 YLINE=' ' 8608 YLINEA=' ' 8609C 8610 120 CONTINUE 8611C 8612 CALL NEXTPRT (IP,J) 8613 IF (IP .GT. J) GO TO 400 8614 JP = IP 8615 CALL NEXTEND (JP,J) 8616 CALL NEXTPRT (JP,J) 8617 K = JP - IP 8618 N1 = 0 8619 DO 112 N=1,K 8620 N1 = N1 + 1 8621 IF ( KCHAR(IP).GT.127 ) 8622 C THEN 8623 YLINEA(N1:N1) = Y63 8624 ISIGN= 1 8625 KCHAR(IP) = IAND(KCHAR(IP),127) 8626 END IF 8627C 8628 YLINE(N1:N1) = CHAR(KCHAR(IP)) 8629 IP = IP + 1 8630C 8631 112 CONTINUE 8632C 8633 YBUFF(I1:)=YLINE(1:N1) 8634 I1=I1+N1 8635 IF(ISIGN.EQ.1) THEN 8636 YBUFF(I1:)=YLINEA(1:N1) 8637 I1=I1+N1 8638 YBUFF(I1:)=YCRLF 8639 I1=I1+3 8640 ISIGN=0 8641 END IF 8642C 8643 YLINE=' ' 8644 YLINEA=' ' 8645C 8646 GO TO 120 8647C 8648 400 CONTINUE 8649C 8650 YBUFF(I1:)=YGS(1:4) 8651 I1=I1+4 8652C 8653C REMOVE PARITY BIT 8654C 8655 DO 410 I = 1 , IGS 8656 KCHAR(I) = IAND(KCHAR(I) , 127) 8657 410 CONTINUE 8658C 8659C WRITE BULLETIN IN ERROR IN EMPRESS ERROR DB. 8660C 8661C CALL PUT_ERROR_BULL('SYNO',I1,YBUFF,IERR) 8662C 8663 RETURN 8664 END 8665 SUBROUTINE SAVREP ( IHEAD,IERR) 8666C 8667C 8668C**** *SAVREP* 8669C 8670C 8671C PURPOSE. 8672C -------- 8673C 8674C WRITE REPORT IN ERROR TO THE ERROR FILE. 8675C 8676C IHEAD = 0 , WRITE BULLETIN HEADER AND ERROR REPORT 8677C TO ERROR FILE. 8678C = 1 , WRITE ERROR REPORT ONLY. 8679C = 2 , WRITE 'GS' CHARACTER AT END. 8680C 8681C IERR NOT USED. 8682C 8683C IHEAD SET TO 1 IF HEADER WRITTEN , OTHERWISE 8684C UNCHANGED. 8685C 8686C IERR SET TO -1 , IF ERROR IN WRITE , OTHERWISE 8687C UNCHANGED. 8688C 8689C** INTERFACE. 8690C ---------- 8691C 8692C *CALL* *SAVREP(IHEAD,IERR)* 8693C 8694C METHOD. 8695C ------- 8696C 8697C NONE. 8698C 8699C 8700C EXTERNALS. 8701C ---------- 8702C 8703C NONE. 8704C 8705C REFERENCE. 8706C ---------- 8707C 8708C NONE. 8709C 8710C AUTHOR. 8711C ------- 8712C 8713C M. DRAGOSAVAC *ECMWF* AUG 1988. 8714C 8715C 8716C MODIFICATIONS. 8717C -------------- 8718C 8719C NONE. 8720C 8721C 8722 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 8723C 8724 INCLUDE 'parameter.h' 8725 INCLUDE 'comwork.h' 8726 INCLUDE 'comindx.h' 8727 INCLUDE 'combuff.h' 8728 INCLUDE 'comerror.h' 8729 INCLUDE 'comerrorc.h' 8730 character* 256 youtfile 8731 CHARACTER*15000 YBUFF 8732C character*256 cf 8733C 8734 DIMENSION ISTART(4),IFIN(4) 8735C 8736 CHARACTER *80 YLINE,YLINEA 8737 CHARACTER*1 Y63 8738 CHARACTER*4 YGS 8739 CHARACTER*3 YCRLF 8740C 8741 Save YBUFF 8742C 8743 Y63=CHAR(63) 8744 YGS=CHAR(13)//CHAR(13)//CHAR(10)//CHAR(3) 8745 YCRLF=CHAR(13)//CHAR(13)//CHAR(10) 8746C ------------------------------------------------------------------ 8747C* 1. OPEN ERROR FILE AT THE BEGINNING OF THE PROCESS. 8748C ------------------------------------------------- 8749 100 CONTINUE 8750C 8751 YLINE=' ' 8752 YLINEA=' ' 8753 ISIGN=0 8754C 8755C 8756C* 1.2 WRITE BULLETIN HEADER TO ERROR 8757C ------------------------------ 8758C FILE IF NOT ALREADY DONE. 8759C ------------------------- 8760 120 CONTINUE 8761C 8762 IF ( IHEAD.NE.0 ) GO TO 130 8763C 8764 IF(IHEAD.EQ.0) THEN 8765 I1=1 8766 YBUFF=' ' 8767 END IF 8768C 8769 ISTART(1) = 1 8770 ISTART(2) = ISL 8771 ISTART(3) = IAH 8772 ISTART(4) = IMI 8773C 8774 IFIN(1) = ISL 8775 IFIN(2) = IAH 8776 IFIN(3) = JAH 8777 CALL NEXTEND(IFIN(3),IGS) 8778 CALL NEXTPRT(IFIN(3),IGS) 8779 IFIN(4) = JMI 8780 CALL NEXTEND(IFIN(4),IGS) 8781 CALL NEXTPRT(IFIN(4),IGS) 8782C 8783 IP = 0 8784 N2 = 0 8785C 8786 IHEAD = 1 8787C 8788 NN = 4 8789C 8790 DO 121 N=1,NN 8791 K = IFIN(N) - ISTART(N) 8792 IF(K.GT.80) K=80 8793 DO 122 N1=1,K 8794 N2 = N2 + 1 8795 IP = IP + 1 8796 IF (KCHAR(IP).GT.127) 8797 C THEN 8798 YLINEA(N2:N2) = Y63 8799 ISIGN=1 8800 KCHAR(IP)=IAND(KCHAR(IP),127) 8801 END IF 8802C 8803 YLINE(N2:N2) = CHAR(KCHAR(IP)) 8804C 8805 122 CONTINUE 8806C 8807C 8808C 8809 YBUFF(I1:)=YLINE(1:N2) 8810 I1=I1+N2 8811 IF(ISIGN.EQ.1) THEN 8812 YBUFF(I1:)=YLINEA(1:N2) 8813 I1=I1+N2 8814 YBUFF(I1:)=YCRLF 8815 I1=I1+3 8816 ISIGN=0 8817 END IF 8818C 8819 YLINE=' ' 8820 YLINEA=' ' 8821C 8822 N2 = 0 8823C 8824 121 CONTINUE 8825C 8826C 8827C* 1.3 WRITE ERROR REPORT , IF REQUIRED. 8828C*** --------------------------------- 8829 130 CONTINUE 8830C 8831 IF ( IHEAD.EQ.2 ) GO TO 140 8832C 8833C 8834C AVOID WRITING REPORT TWICE IF MIMIMJMJ LINE IS 8835C MISSING. 8836C 8837 IF ( IAH.EQ.KPT ) THEN 8838 RETURN 8839 END IF 8840C 8841C AVOID WRITING MIMIMJMJ TWICE ( CORRUPT MIMIMJMJ CAN BE TAKEN 8842C AS STATION NUMBER ) 8843C 8844 IF ( KPT.LT.IFIN(4) ) KPT = IFIN(4) 8845C 8846C 8847 IP = KPT 8848 IF(KDEC(4) .EQ. 35 .OR. KDEC(4) .EQ. 36) IP = IMI 8849 IF(KDEC(4) .EQ. 32 .OR. KDEC(4) .EQ. 33) IP = IMI 8850 J = IEQ+ 3 8851 IF ( J.GT.IGS) J = IGS 8852C 8853 133 CALL NEXTPRT (IP,J) 8854 IF (IP.GT.J) THEN 8855 RETURN 8856 END IF 8857 JP = IP 8858 CALL NEXTEND(JP,J) 8859 CALL NEXTPRT(JP,J) 8860 K = JP - IP 8861 N1 = 0 8862 IF(K.GT.80) K=80 8863 DO 131 N=1,K 8864 N1 = N1 + 1 8865 IF ( KCHAR(IP).GT.127) 8866 C THEN 8867 YLINEA(N1:N1) = Y63 8868 ISIGN= 1 8869 KCHAR(IP) = IAND(KCHAR(IP),127) 8870 END IF 8871C 8872 YLINE(N1:N1) = CHAR(KCHAR(IP)) 8873 IP = IP + 1 8874C 8875 131 CONTINUE 8876C 8877 YBUFF(I1:)=YLINE(1:N1) 8878 I1=I1+N1 8879 IF(ISIGN.EQ.1) THEN 8880 YBUFF(I1:)=YLINEA(1:N1) 8881 I1=I1+N1 8882 YBUFF(I1:)=YCRLF 8883 I1=I1+3 8884 ISIGN=0 8885 END IF 8886C 8887 YLINE=' ' 8888 YLINEA=' ' 8889C 8890C 8891 GO TO 133 8892C 8893C 8894C* 1.4 WRITE 'GS' AT END OF BULLETIN. 8895C ------------------------------ 8896 140 CONTINUE 8897C 8898 YLINE(1:4)= YGS 8899C 8900 YBUFF(I1:)=YLINE(1:4) 8901 I1=I1+4 8902C 8903C WRITE BULLETIN INTO DB 8904C 8905C if(Nmode.eq.0) then 8906C CALL PUT_ERROR_BULL('SYNO',I1,YBUFF,IERR) 8907C else 8908C open(11,file=youtfile,err=200, 8909C 1 form='formatted', 8910C 2 status='unknown') 8911C write(11,err=210,iostat=ios,fmt='(a)') ybuff(1:i1) 8912C close(11) 8913C ierr=1 8914C end if 8915C 8916 GO TO 400 8917C 8918 400 CONTINUE 8919C 8920C REMOVE PARITY BIT 8921C 8922 DO 500 I = 1 , IGS 8923 KCHAR(I) = IAND(KCHAR(I) , 127) 8924 500 CONTINUE 8925C 8926C 8927 RETURN 8928C 8929 200 continue 8930c 8931 print*,'Open error on ',youtfile 8932 call exit(2) 8933c 8934 210 continue 8935c 8936 print*,'write error on ',youtfile 8937 call exit(2) 8938 return 8939 END 8940 SUBROUTINE ERRSTA (IPART,IMARK,IFIRST,NUMBER) 8941C 8942C 8943C 8944C**** *ERRSTA* 8945C 8946C 8947C PURPOSE. 8948C -------- 8949C 8950C COUNTS THE NUMBER OF ERRORS IN THE REPORT 8951C COUNTS THE NUMBER OF ERRORS IN THE DECODING JOB 8952C MARKS THE ERROR BIT TO KDEC 8953C ADDS ?-MARK TO KCHAR AT THE ERRONEUS GROUP 8954C 8955C INPUT : IPART - INDICATOR OF NOER 8956C (IN TEMPS 3 = A, 4 = B, 5 = C, 6 = D) 8957C IMARK = 1 IF ? IS TO BE ADDED TO ERRONEUS GROUP 8958C IFIRST = O IF FIRST DECODING ATTEMPT OF THE REPORT 8959C = 1 OTHERWISE 8960C NUMBER - NUMBER OF ERRORS IN THE REPORT SO FAR 8961C 8962C OUTPUT : NUMBER - NEW NUMBER OF ERRORS 8963C NOER - NUMBER OF ERRONEUS REPORT (INCREASED BY 1 8964C IF THE FIRST ERROR IN THE REPORT) 8965C 8966C 8967C** INTERFACE. 8968C ---------- 8969C 8970C *CALL* *ERRSTA(IPART,IMARK,IFIRST,NUMBER)* 8971C 8972C METHOD. 8973C ------- 8974C 8975C NONE. 8976C 8977C 8978C EXTERNALS. 8979C ---------- 8980C 8981C *XXXX* *XXXXXXX(XXXX)* 8982C 8983C REFERENCE. 8984C ---------- 8985C 8986C NONE. 8987C 8988C AUTHOR. 8989C ------- 8990C 8991C A.HOLOPAINEN NOV.83 8992C 8993C 8994C MODIFICATIONS. 8995C -------------- 8996C 8997C M. DRAGOSAVAC *ECMWF* AUG 1988. 8998C 8999C 9000 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 9001C 9002 INCLUDE 'parameter.h' 9003 INCLUDE 'comwork.h' 9004 INCLUDE 'comindx.h' 9005 INCLUDE 'comstat.h' 9006C 9007C ------------------------------------------------------------------ 9008C 9009C* 1. . 9010C ----------------------------------- 9011 100 CONTINUE 9012C 9013 IF(NUMBER .GE. 0) NUMBER = NUMBER + 1 9014 IF ( IFIRST.EQ.0 ) 9015 C THEN 9016 IF(NUMBER .EQ. 1) 9017 C NUMRERR(IPART)=NUMRERR(IPART) + 1 9018 NOER(IPART,KERR)=NOER(IPART,KERR) + 1 9019C KERBIT =ISHFT(KDEC(20),1-KERR) .AND. 1 9020C IF(KERBIT .EQ. 0) KDEC(20) = KDEC(20) + 2**(KERR-1) 9021 END IF 9022C 9023 IPT = IABS(IPT) 9024 IF(IMARK .EQ. 1) KCHAR(IPT) = IOR(KCHAR(IPT) , 128) 9025 IF(IMARK .EQ. 2) 9026 C THEN 9027 NPT = IPT 9028 CALL NEXSEP2(NPT,IEQ,*200) 9029 CALL PREPRT(NPT,IMI,*200) 9030 KCHAR(NPT) = IOR(KCHAR(NPT) , 128) 9031 END IF 9032C 9033200 CONTINUE 9034C 9035 RETURN 9036 END 9037 SUBROUTINE REMEEE 9038C 9039C 9040C**** *REMEEE* 9041C 9042C 9043C PURPOSE. 9044C -------- 9045C 9046C HANDLE TYPING ERRORS CORRECTED BY THE 'E E E' 9047C PROCEDURE AS SPECIFIED IN GTS MANUAL. 9048C 9049C 9050C** INTERFACE. 9051C ---------- 9052C 9053C *CALL* *REMEEE* 9054C 9055C INPUT : REPORT IN KCHAR(IPT) - KCHAR(IEQ) , IN CCITT 5 , 9056C 1 CHARACTER PER WORD. 9057C 9058C OUTPUT : E'S , ERRONEUS CHARACTERS AND REPEATED GROUPS REPLACED 9059C BY SPACE CHARACTERS. THESE ARE IGNORED IN SCANNING 9060C ROUTINES. 9061C 9062C 9063C METHOD. 9064C ------- 9065C 9066C NONE. 9067C 9068C 9069C EXTERNALS. 9070C ---------- 9071C 9072C NONE. 9073C 9074C REFERENCE. 9075C ---------- 9076C 9077C NONE. 9078C 9079C AUTHOR. 9080C ------- 9081C 9082C M. DRAGOSAVAC *ECMWF* AUG 1988. 9083C 9084C 9085C MODIFICATIONS. 9086C -------------- 9087C 9088C NONE. 9089C 9090C 9091 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 9092C 9093 INCLUDE 'parameter.h' 9094 INCLUDE 'comwork.h' 9095 INCLUDE 'comindx.h' 9096C 9097C ------------------------------------------------------------------ 9098C* 1. CHECK FOR 'E E E'. 'EEE' IS ACCEPTED EVEN 9099C THOUGH THIS MAY BE AMBIGUOUS WITH A SYNOP '333' GROUP IN 9100C LETTER SHIFT. FREQUENTLY ONLY 1 OR 2 'E'S MAY BE USED. 9101C THESE ALSO CATERED FOR. 9102 100 CONTINUE 9103C 9104C SKIP PAST SHIP'S CALL SIGN AND LOCATE 'E' IF ANY EXISTS. 9105C 9106 I = IPT + 4 9107 N = 69 9108 CALL NEXTVAL(I,N,IEQ) 9109 IF(I .GT. IEQ) RETURN 9110C 9111C 'E' CHARACTER FOUND. REPLACE 'E' AND ANY FOLLOWING 'E'S BY SPACES 9112C E.G. 40118 7012EE 40118 70500 BECOMES 9113C 40118 7012 40118 70500 . 9114C 9115 K = I 9116 CALL NEXTFIG(K,IEQ) 9117 IF(K .GE. IEQ) RETURN 9118C 9119 DO 101 J=I,K-1 9120 IF((KCHAR(J) .NE. 10) .AND. (KCHAR(J) .NE. 13)) 9121 1 KCHAR(J) = 32 9122101 CONTINUE 9123C 9124C SET POINTER TO CHARACTER BEFORE THE 'E'. CHANGE 9125C THIS CHARACTER TO A 'SPACE'. 9126C E.G. 40118 7012 40118 70500 BECOMES 9127C 40118 701 40118 70500 . 9128C 9129 N = I - 1 9130 IF((KCHAR(N) .NE. 10) .AND. (KCHAR(N) .NE. 13)) 9131 1 KCHAR(N) = 32 9132C 9133C SCANNING BACKWARDS REPLACE CHARACTERS BY 'SPACE' 9134C UNTIL A 'SPACE' CHARACTER IS ENCOUNTERED. 9135C E.G. 40118 701 40118 70500 BECOMES 9136C 40118 40118 70500 . 9137C 9138 DO 102 I=N-1,IPT,-1 9139 IF(KCHAR(I) .EQ. 32) GO TO 300 9140 IF((KCHAR(I) .NE. 10) .AND. (KCHAR(I) .NE. 13)) 9141 1 KCHAR(I) = 32 9142 102 CONTINUE 9143C 9144C NO CHARACTER FOUND 9145C 9146 GO TO 100 9147C 9148C --------------------------------------------------------------------- 9149C* 3. 'I' NOW POINTS TO THE 'SPACE' AFTER LAST FIGURE OF THE GROUP 9150C BEFORE THE SERIES OF SPACES AND 'K' POINTS TO FIRST FIGURE 9151C OF FOLLOWING GROUP. IF THESE GROUPS ARE THE SAME REMOVE 9152C ONE GROUP (SECOND). 9153C E.G. 40118 40118 70500 BECOMES 9154C 40118 70500 . 9155C 9156 300 CONTINUE 9157C 9158 I = I - 5 9159 IF((KCHAR(I) .EQ. KCHAR(K)) .AND. 9160 1 (KCHAR(I+1) .EQ. KCHAR(K+1)) .AND. 9161 2 (KCHAR(I+2) .EQ. KCHAR(K+2)) .AND. 9162 3 (KCHAR(I+3) .EQ. KCHAR(K+3)) .AND. 9163 4 (KCHAR(I+4) .EQ. KCHAR(K+4))) 9164 5 THEN 9165 N = K + 4 9166 DO 301 I=K,N 9167 KCHAR(I) = 32 9168 301 CONTINUE 9169 END IF 9170C 9171C 9172C* 4. SOMETIMES MORE THAN 1 GROUP HAS TO BE DELETED 9173C E.G. 40118 59623 7012EE 40118 70500 . 9174C THIS WILL NOW HAVE BECOME 9175C 40118 59623 40118 AND POINTERS ARE 9176C I K 9177C 40118 59623 NEED TO BE REMOVED. 9178 400 CONTINUE 9179C 9180 I = I - 6 9181 N = K - 1 9182 IF((KCHAR(I) .EQ. KCHAR(K)) .AND. 9183 1 (KCHAR(I+1) .EQ. KCHAR(K+1)) .AND. 9184 2 (KCHAR(I+2) .EQ. KCHAR(K+2)) .AND. 9185 3 (KCHAR(I+3) .EQ. KCHAR(K+3)) .AND. 9186 4 (KCHAR(I+4) .EQ. KCHAR(K+4))) 9187 5 THEN 9188 DO 401 J=I,N 9189 KCHAR(J) = 32 9190 401 CONTINUE 9191 END IF 9192C 9193C GO BACK TO BEGINNING OF SUBROUTINE TO FIND OUT 9194C IF THERE ARE MORE 'E'-CORRECTIONS. 9195C 9196 GO TO 100 9197C 9198 END 9199 SUBROUTINE NEXTMI(I,J,II) 9200C 9201C 9202C 9203C**** *NEXTMI* 9204C 9205C 9206C PURPOSE. 9207C -------- 9208C 9209C TO FIND NEXT MIMIMJMJ GROUP IN THE BULLETIN. 9210C SCANS BULLETIN IN 'KCHAR' FOR NEXT GROUP OF 9211C ('TTAA' OR 'TTBB' OR 'TTCC' OR 'TTDD' ETC.) 9212C 9213C 9214C** INTERFACE. 9215C ---------- 9216C 9217C *CALL* *NEXTMI(I,J,II)* 9218C 9219C INPUT : I - SCAN STARTS AT WORD I. 9220C J - SCAN STOPS AT WORD J . 9221C 9222C 9223C OUTPUT : II- POSITION OF THE FIRST CHARACTER 9224C IN REQUIRED GROUP 9225C IF CHARACTER NOT FOUND II = 99999 9226C 9227C METHOD. 9228C ------- 9229C 9230C NONE. 9231C 9232C 9233C EXTERNALS. 9234C ---------- 9235C 9236C NONE. 9237C 9238C REFERENCE. 9239C ---------- 9240C 9241C NONE. 9242C 9243C AUTHOR. 9244C ------- 9245C 9246C 9247C 9248C MODIFICATIONS. 9249C -------------- 9250C 9251C M. DRAGOSAVAC *ECMWF* AUG 1988. 9252C 9253C 9254 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 9255C 9256 INCLUDE 'parameter.h' 9257 INCLUDE 'comwork.h' 9258C 9259 DIMENSION MIMJ(26) 9260C 9261C 9262 DATA MIMJ /65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 9263 & 80,81,82,83,84,85,86,87,88,89,90/ 9264C ------------------------------------------------------------------ 9265C* 1. FIND NEXT MIMIMJMJ GROUP. 9266C ------------------------- 9267 100 CONTINUE 9268C 9269C 9270 II=9999 9271 K =IABS(I) 9272 M =IABS(I) 9273C 9274 101 CONTINUE 9275C 9276 CALL NEXSEP2(M,J,*1000) 9277 CALL NEXPRT2(M,J,*1000) 9278C 9279 IF(M.GE.J) RETURN 9280C 9281 K1= KCHAR(M ) 9282 K2= KCHAR(M+1) 9283 K3= KCHAR(M+2) 9284 K4= KCHAR(M+3) 9285C 9286 DO 102 N=1,26 9287C 9288 IF(K1.EQ.MIMJ(N).AND.K2.EQ.MIMJ(N)) 9289 & THEN 9290C 9291 DO 103 NN=1,26 9292C 9293 IF(K3.EQ.MIMJ(NN).AND.K4.EQ.MIMJ(NN)) 9294 & THEN 9295 CALL PRESEP(M,K,*1000) 9296 CALL PREPRT(M,K,*1000) 9297 II= M+1 9298 RETURN 9299 END IF 9300C 9301 103 CONTINUE 9302C 9303 END IF 9304C 9305 102 CONTINUE 9306C 9307 GO TO 101 9308C 9309 1000 CONTINUE 9310C 9311 RETURN 9312 END 9313 subroutine Read_GTS(IUNIT,YOUT,K,IERR) 9314C 9315C 9316C This subroutine returns ascii time in form 9317C 9318C dd-mmm-yyyy hh:mm:ss.cc 9319C 9320 character*8 cdate 9321 character*10 ctime 9322 character*5 zone 9323 integer itimes(8) 9324 character*8 yppdate 9325 character*3 ymonth(12) 9326 character*11 cdatepp 9327C 9328 data ymonth/'Jan','Feb','Mar','Apr','May','Jun','Jul', 9329 1 'Aug','Sep','Oct','Nov','Dec'/ 9330C 9331 CHARACTER*23 CDATETIME 9332C 9333C------------------------------------------------------------------------------------ 9334 yppdate=' ' 9335 call getenv('PP_DATE',yppdate) 9336C 9337 if(yppdate.eq.' ') then 9338 CALL DATE_AND_TIME(cdate,ctime,zone,itimes) 9339 9340 9341 CDATETIME=cdate(7:8)//'-'//ymonth(itimes(2))//'-'// 9342 1 cdate(1:4)//' '//ctime(1:2)//':'//ctime(3:4)// 9343 2 ':'//ctime(5:9) 9344 9345C 9346 else 9347 CALL DATE_AND_TIME(cdate,ctime,zone,itimes) 9348 cdatepp(3:3)='-' 9349 cdatepp(7:7)='-' 9350c 9351c get pp date 9352c 9353 read(yppdate(5:6),'(i2.2)') imm 9354 9355 cdatepp(8:11)=yppdate(1:4) 9356 cdatepp(4:6)=ymonth(imm) 9357 cdatepp(1:2)=yppdate(7:8) 9358C 9359 CDATETIME=CDATEPP(1:11)//' '//ctime(1:2)//':'//ctime(3:4)// 9360 1 ':'//ctime(5:9) 9361 end if 9362C 9363 RETURN 9364 END 9365 integer function iymd2c(idate) 9366c 9367c**** *iymd2c* 9368c 9369c 9370c purpose. 9371c -------- 9372c returns century day for given yyyymmdd. 9373c 9374c** interface. 9375c ---------- 9376c 9377c *iymd2c(idate)* 9378c 9379c input : idate (yyyymmdd) 9380c 9381c output: idate (century day) 9382c 9383c 9384c method. 9385c ------- 9386c 9387c none. 9388c 9389c 9390c externals. 9391c ---------- 9392c 9393c none. 9394c 9395c reference. 9396c ---------- 9397c 9398c none. 9399c 9400c author. 9401c ------- 9402c 9403c m. dragosavac *ecmwf* 21/02/98. 9404c 9405c 9406c modifications. 9407c -------------- 9408c 9409c none. 9410c 9411c 9412 implicit logical(o,g), character*8(c,h,y) 9413c 9414 dimension idm(13) 9415c 9416 data idm/0,31,28,31,30,31,30,31,31,30,31,30,31/ 9417c 9418c ------------------------------------------------------------------ 9419c* 1. set month. 9420c ---------- 9421 100 continue 9422c 9423 idays=0 9424c 9425 iym=idate/100 9426 id=idate-iym*100 9427 iy=iym/100 9428 im=iym-iy*100 9429 iyear=iy 9430c 9431 if(iyear.gt.2000) then 9432 do 111 i=2001,iyear-1 9433 idays=idays+365 9434 if(mod(i,4).eq.0) idays=idays+1 9435 111 continue 9436c 9437 do 112 i=1,im 9438 idays=idays+idm(i) 9439 if(i.eq.3) then 9440 if(mod(iyear,4).eq.0) idays=idays+1 9441 end if 9442 112 continue 9443c 9444 idays=idays+id 9445c 9446 iymd2c=idays 9447 else 9448 do 101 i=1900,iyear-1 9449 idays=idays+365 9450 if(mod(i,4).eq.0) idays=idays+1 9451 101 continue 9452c 9453 do 102 i=1,im 9454 idays=idays+idm(i) 9455 if(i.eq.3) then 9456 if(mod(iyear,4).eq.0) idays=idays+1 9457 end if 9458 102 continue 9459c 9460 idays=idays+id-1 9461c 9462 iymd2c=idays 9463 end if 9464c 9465 return 9466 end 9467 integer function ic2ymd(kday) 9468c 9469c**** *ic2ymd* 9470c 9471c 9472c purpose. 9473c -------- 9474c returns integer yyyymmdd for given century day. 9475c 9476c** interface. 9477c ---------- 9478c 9479c *i=ic2ymd(kday)* 9480c 9481c input : kday 9482c 9483c output: i (in form of yyyymmdd) 9484c 9485c 9486c method. 9487c ------- 9488c 9489c none. 9490c 9491c 9492c externals. 9493c ---------- 9494c 9495c none. 9496c 9497c reference. 9498c ---------- 9499c 9500c none. 9501c 9502c author. 9503c ------- 9504c 9505c m. dragosavac *ecmwf* 21/02/98. 9506c 9507c 9508c modifications. 9509c -------------- 9510c 9511c none. 9512c 9513c 9514 implicit logical(o,g), character*8(c,h,y) 9515c 9516 dimension idm(12) 9517c 9518 data idm/31,28,31,30,31,30,31,31,30,31,30,31/ 9519c 9520c ------------------------------------------------------------------ 9521c* 1. set year. 9522c --------- 9523 100 continue 9524c 9525c If number of days zero or negative it is previous century 9526c 9527 if(kday.le.0) then 9528 kday=kday+36891 9529 end if 9530c 9531 if(kday.gt.36891) then 9532 kday=kday-36891 9533 end if 9534c 9535c first 10 years of 20 century will not be used. 9536c This number of years will be interpreted as 21st century 9537c 9538 iy=1900 9539 if(kday.lt.7300) iy=2001 9540c 9541 do 101 i= 1,100 9542 if(mod(i,4).eq.0) then 9543 iday=kday-366 9544 if(iday.gt.0) then 9545 iy=iy+1 9546 kday=iday 9547 else 9548 go to 200 9549 end if 9550 else 9551 iday=kday-365 9552 if(iday.gt.0) then 9553 iy=iy+1 9554 kday=iday 9555 else 9556 go to 200 9557 end if 9558 end if 9559 101 continue 9560c 9561c 2. set month. 9562c ---------- 9563 200 continue 9564c 9565 if(mod(iy,4).eq.0.and.iy.le.2000) kday=kday+1 9566 9567 do 201 i=1,12 9568c 9569c print*,'kday=',kday 9570 iday=kday-idm(i) 9571 if(i.eq.2) then 9572 if(mod(iy,4).eq.0) iday=kday-29 9573 end if 9574c 9575 if(iday.le.0) then 9576 im=i 9577 id=kday 9578 go to 300 9579 else 9580 kday=iday 9581 end if 9582 201 continue 9583c 9584c* 3. set yyyymmd. 9585c ---------- 9586 300 continue 9587c 9588 ic2ymd=iy*10000+im*100+id 9589c 9590 return 9591 end 9592 integer function iymdhm2m(ktime) 9593c 9594c**** *iymdhm2m* 9595c 9596c 9597c purpose. 9598c -------- 9599c calculate time in minutes since 1/1/1978, 9600c given input as ktime(1) year (1992) 9601c ktime(2) month 9602c ktime(3) day 9603c ktime(4) hour 9604c ktime(5) minute 9605c 9606c** interface. 9607c ---------- 9608c 9609c *iymdhm2m(ktime)* 9610c 9611c input : ktime(5) 9612c 9613c 9614c method. 9615c ------- 9616c 9617c none. 9618c 9619c 9620c externals. 9621c ---------- 9622c 9623c none. 9624c 9625c reference. 9626c ---------- 9627c 9628c none. 9629c 9630c author. 9631c ------- 9632c 9633c m. dragosavac *ecmwf* 21/10/89. 9634c 9635c 9636c modifications. 9637c -------------- 9638c 9639c none. 9640c 9641c 9642 implicit logical(l,o,g), character*8(c,h,y) 9643c 9644 integer ktime(5) 9645c 9646 dimension idm(13) 9647c 9648 data idm/0,31,28,31,30,31,30,31,31,30,31,30,31/ 9649c 9650c ------------------------------------------------------------------ 9651c* 1. set minutes. 9652c ------------ 9653100 continue 9654c 9655 idays=0 9656c 9657 do 101 i=1978,ktime(1)-1 9658 idays=idays+365 9659 if(mod(i,4).eq.0) idays=idays+1 9660 101 continue 9661c 9662 do 102 i=1,ktime(2) 9663 idays=idays+idm(i) 9664 if(i.eq.3) then 9665 iy=ktime(1) 9666 if(mod(iy,4).eq.0) idays=idays+1 9667 end if 9668 102 continue 9669c 9670 idays=idays+ktime(3)-1 9671c 9672 itm=idays*1440+ktime(4)*60+ktime(5) 9673c 9674 iymdhm2m=itm 9675c 9676 return 9677 end 9678 integer function ictime2m(ctime) 9679c 9680c**** *ictime2m* 9681c 9682c 9683c purpose. 9684c -------- 9685c calculate time in minutes since 1/1/1978, 9686c given input ctime as ascii time on vms 9687c 9688c** interface. 9689c ---------- 9690c 9691c *ictime2m* 9692c 9693c 9694c method. 9695c ------- 9696c 9697c none. 9698c 9699c 9700c externals. 9701c ---------- 9702c 9703c none. 9704c 9705c reference. 9706c ---------- 9707c 9708c none. 9709c 9710c author. 9711c ------- 9712c 9713c m. dragosavac *ecmwf* 21/10/89. 9714c 9715c 9716c modifications. 9717c -------------- 9718c 9719c none. 9720c 9721c 9722 implicit logical(l,o,g), character*8(c,h,y) 9723c 9724 character*23 ctime 9725 character*3 ymonth(12) 9726c 9727 dimension idm(13) 9728c 9729 data idm/0,31,28,31,30,31,30,31,31,30,31,30,31/ 9730 data ymonth/'jan','feb','mar','apr','may','jun','jul', 9731 1 'aug','sep','oct','nov','dec'/ 9732c 9733c ------------------------------------------------------------------ 9734c* 1. set minutes. 9735c ------------ 9736100 continue 9737c 9738 idays=0 9739c 9740 do 101 i=1,12 9741 if(ctime(4:6).eq.ymonth(i)) then 9742 im=i 9743 im=im+1 9744 go to 110 9745 end if 9746 101 continue 9747c 9748 110 continue 9749c 9750 read(ctime,'(i2,5x,i4,1x,i2,1x,i2)') id,iy,ih,imin 9751c 9752 do 111 i=1978,iy-1 9753 idays=idays+365 9754 if(mod(i,4).eq.0) idays=idays+1 9755 111 continue 9756c 9757 do 112 i=1,im-1 9758 idays=idays+idm(i) 9759 if(i.eq.3) then 9760 if(mod(iy,4).eq.0) idays=idays+1 9761 end if 9762 112 continue 9763c 9764 idays=idays+id-1 9765c 9766 itm=idays*1440+ih*60+imin 9767c 9768 ictime2m=itm 9769c 9770 return 9771 end 9772 subroutine daymn(ydate,n) 9773C 9774c 9775c**** *daypn* 9776c 9777c 9778c purpose. 9779c -------- 9780c calculate date from ydate plus n days. 9781c 9782c 9783c** interface. 9784c ---------- 9785c 9786c none. 9787c 9788c method. 9789c ------- 9790c 9791c none. 9792c 9793c 9794c externals. 9795c ---------- 9796c 9797c none. 9798c 9799c reference. 9800c ---------- 9801c 9802c none. 9803c 9804c author. 9805c ------- 9806c m. dragosavac *ecmwf* 15/02/98. 9807c 9808c 9809c modifications. 9810c -------------- 9811c 9812c none. 9813c 9814c 9815 implicit logical(l,o,g), character*8(c,h,y) 9816c 9817c 9818 character*8 ydate 9819c 9820 read(ydate(1:8),'(i8)') idate 9821 idays=iymd2c(idate) 9822 idays=idays-n 9823 idate=ic2ymd(idays) 9824 write(ydate(1:8),'(i8.8)') idate 9825c 9826c 9827 return 9828 end 9829 subroutine daypn(ydate,n) 9830C 9831C 9832c 9833c**** *daypn* 9834c 9835c 9836c purpose. 9837c -------- 9838c calculate date from ydate plus n days. 9839c 9840c 9841c** interface. 9842c ---------- 9843c 9844c none. 9845c 9846c method. 9847c ------- 9848c 9849c none. 9850c 9851c 9852c externals. 9853c ---------- 9854c 9855c none. 9856c 9857c reference. 9858c ---------- 9859c 9860c none. 9861c 9862c author. 9863c ------- 9864c 9865c m. dragosavac *ecmwf* 15/02/87. 9866c 9867c 9868c modifications. 9869c -------------- 9870c 9871c none. 9872c 9873c 9874 implicit logical(o,g), character*8(c,h,y) 9875c 9876c 9877 character*8 ydate 9878c 9879 read(ydate(1:8),'(i8)') idate 9880 idays=iymd2c(idate) 9881 idays=idays+n 9882 idate=ic2ymd(idays) 9883 write(ydate(1:8),'(i8.8)') idate 9884c 9885c 9886 return 9887 end 9888 subroutine juldate(kjday,kyear,kmonth,kday) 9889C 9890C 9891C 9892C**** *datum* 9893C 9894C 9895C PURPOSE. 9896C -------- 9897C DEFINE PROPER MONTH AND YEAR IF DAY IS DEFINED. 9898C 9899C** INTERFACE. 9900C ---------- 9901C 9902C *CALL* *DATUM(IDD,IMM,IYY,kerr)* 9903C 9904C IDD - DAY 9905C IMM - MONTH 9906C IYY - YEAR 9907C 9908C METHOD. 9909C ------- 9910C 9911C IF IDD IS GREATER THAN CURRENT DAY DAY IS CONSIDERED TO BE FROM 9912C PREVIOUS MONTH.IF CURRENT MONTH IS JANUARY 9913C YEAR BECOMS PREVIOUS ONE. 9914C IF IDD IS LESS OR EQUALL THAN CURRENT DAY IT IS FROM CURRENT MONTH 9915C AND YEAR. 9916C 9917C 9918C 9919C EXTERNALS. 9920C ---------- 9921C 9922C *CALL* *DATE(YDATE)* 9923C 9924C REFERENCE. 9925C ---------- 9926C 9927C NONE. 9928C 9929C AUTHOR. 9930C ------- 9931C 9932C M. D. DRAGOSAVAC *ECMWF* 15/09/87. 9933C 9934C 9935C MODIFICATIONS. 9936C -------------- 9937C 9938C NONE. 9939C 9940C 9941 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 9942C 9943 CHARACTER*3 YMONTH(12) 9944 character*23 ydtime 9945C 9946 DATA YMONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul', 9947 1 'Aug','Sep','Oct','Nov','Dec'/ 9948C 9949CC 9950C ------------------------------------------------------------------ 9951C 9952C* 1. GET DATE FROM THE SYSTEM. 9953C ------------------------- 9954 100 CONTINUE 9955CC 9956 CALL asctim(ydtime) 9957 READ(ydtime( 8:11),'(I4.4)') IYEAR 9958 READ(ydtime(1:2),'(I2.2)') IDAY 9959C 9960 DO 101 I=1,12 9961 IF(ydtime(4:6).EQ.YMONTH(I)) IMONTH=I 9962 101 CONTINUE 9963CC 9964C 9965C* 1.1 DEFINE MONTH AND YEAR 9966C --------------------- 9967 110 CONTINUE 9968C 9969 IF(IDAY.GE.IDD) THEN 9970 IMM=IMONTH 9971 IYY=IYEAR 9972 RETURN 9973 END IF 9974C 9975 IF(IDAY.LT.IDD) THEN 9976 IF(IMONTH.EQ.1) THEN 9977 IMM=12 9978 IYY=IYEAR-1 9979 RETURN 9980 END IF 9981 IMM=IMONTH-1 9982 IYY=IYEAR 9983 END IF 9984C 9985 RETURN 9986 END 9987 subroutine next_date(cdate,ctime,cdelta,cdate1,ctime1) 9988C 9989C 9990c 9991c**** *next_date* 9992c 9993c 9994c purpose. 9995c -------- 9996c 9997c 9998c 9999c** interface. 10000c ---------- 10001c 10002c none. 10003c 10004c method. 10005c ------- 10006c 10007c none. 10008c 10009c 10010c externals. 10011c ---------- 10012c 10013c none. 10014c 10015c reference. 10016c ---------- 10017c 10018c none. 10019c 10020c author. 10021c ------- 10022c 10023c m. dragosavac *ecmwf* 15/02/99. 10024c 10025c 10026c modifications. 10027c -------------- 10028c 10029c none. 10030c 10031c 10032 implicit logical(o,g), character*8(c,h,y) 10033c 10034c 10035 character*8 cdate,cdate1 10036 character*4 ctime,ctime1,cdelta 10037c 10038 read(ctime(1:2),'(i2)') ihour 10039 read(ctime(3:4),'(i2)') imin 10040 read(cdelta,'(i4)') idelta 10041c 10042 imin1=ihour*60+imin+idelta 10043c 10044 ihour2=imin1/60 10045 imin2=imin1-ihour2*60 10046c 10047 if(ihour2.gt.24) then 10048 ihour2=ihour2-24 10049 write(ctime1(1:2),'(i2.2)') ihour2 10050 write(ctime1(3:4),'(i2.2)') imin2 10051c 10052 cdate1=cdate 10053 call daypn(cdate1,1) 10054c 10055 else 10056 cdate1=cdate 10057 write(ctime1(1:2),'(i2.2)') ihour2 10058 write(ctime1(3:4),'(i2.2)') imin2 10059 end if 10060c 10061 return 10062 end 10063 subroutine daypdelta(ky,km,kd,kdelta,ky1,km1,kd1) 10064C 10065c 10066 idate=ky*10000+km*100+kd 10067c 10068 icentury_day=iymd2c(idate) 10069c 10070 icentury_day=icentury_day+kdelta 10071c 10072 new_date=ic2ymd(icentury_day) 10073c 10074 ky1=new_date/10000 10075 idiff= (new_date-ky1*10000) 10076 km1=idiff/100 10077 kd1=idiff-km1*100 10078c 10079 return 10080 end 10081 SUBROUTINE STATION_TEXT(IERR) 10082 10083C**** *STATION_TEXT* 10084C 10085C 10086C PURPOSE. 10087C -------- 10088C READ IN STATION LIST 10089C ( WMO VOLUMEN A - LIST OF OBSERVING STATIONS) 10090C 10091C** INTERFACE. 10092C ---------- 10093C 10094C *CALL* *STATION_TEXT(IERR)* 10095C 10096C METHOD. 10097C ------- 10098C 10099C NONE. 10100C 10101C 10102C EXTERNALS. 10103C ---------- 10104C 10105C 10106C REFERENCE. 10107C ---------- 10108C 10109C NONE. 10110C 10111C AUTHOR. 10112C ------- 10113C 10114C M. DRAGOSAVAC *ECMWF* AUG 2009. 10115 10116 IMPLICIT LOGICAL(O,G), CHARACTER*8(C,H,Y) 10117C 10118 INCLUDE 'comstation.h' 10119 include 'combase.h' 10120 character*256 cf 10121C 10122 character*2 csp00,csp03,csp06,csp09,csp12,csp15,csp18,csp21 10123 character*1 cuat00,cuat06,cuat12,cuat18 10124 character*32 cstation 10125 10126C 10127C ------------------------------------------------------------------ 10128C* 1. READ IN STATION LIST. 10129C --------------------- 10130 100 CONTINUE 10131C 10132 i=index(cppbase,' ') 10133 i=i-1 10134 10135 cf=' ' 10136 cf=cppbase(1:i)//'/dat/synop2bufr_station.txt' 10137 i=index(cf,' ') 10138 i=i-1 10139c 10140 OPEN(UNIT=4,IOSTAT=IOS,ERR=300, 10141 1 FILE=cf(1:i), 10142 1 STATUS='OLD', 10143 1 FORM='formatted') 10144C 10145 NST=0 10146 200 continue 10147 10148 NST=NST+1 10149 read(4,fmt=8889,iostat=ios,END=400) irgcoun(nst), istid(nst), 10150 1 rlatid(nst), rlongid(nst), 10151 2 isthp(nst), istha(nst) ,ipcode(nst), 10152 3 csp00(nst),csp03(nst),csp06(nst), 10153 4 csp09(nst),csp12(nst),csp15(nst), 10154 5 csp18(nst),csp21(nst), 10155 6 cuat00(nst),cuat06(nst),cuat12(nst), 10156 7 cuat18(nst),cstation(nst),RH_tem(nst), 10157 8 RH_vis(nst),RH_prec(nst),RH_wind(nst) 10158c 10159 8889 format(i4,1x,i5.5,1x,f7.2,1x,f7.2,1x,i4,1x,i4,1x,i1, 10160 1 1x,8(a2,1x),4(a,1x),a,1x,F4.1,3(3x,F4.1)) 10161 if(ios.ne.0) then 10162 print*,'Read error on ',cf(1:i) 10163 call exit(2) 10164 end if 10165 10166 go to 200 10167c 10168 10169 400 continue 10170C 10171 NST=NST-1 10172 CLOSE(4) 10173C 10174 return 10175 300 continue 10176 print*,'open error on ',cf(1:i) 10177 10178 END 10179 SUBROUTINE IC4077(ICODE,MINDIC,IPERIOD) 10180C 10181C 10182C**** 10183C* 10184C* NAME : IC4077 10185C* 10186C* FUNCTION : DECODE TIME PERIOD 10187C* 10188C* INPUT : ICODE - CODE for preriod 10189C* MINDIC - MISSING VALUE 10190C* 10191C* OUTPUT : IPERIOD - in minutes 10192C* 10193C* 10194C**** 10195C 10196C 10197C*** SET MISSING VALUE 10198C 10199 IPERIOD=MINDIC 10200C 10201C*** 10202 if(icode.eq.mindic) return 10203 10204 if(icode.ge.0.and.icode.lt.69) then 10205 if(icode.eq.0) then 10206 iperiod=0 10207 elseif(icode.eq.69) then 10208 iperiod=MINDIC 10209 elseif(icode.ge.61.and.icode.lt.68) then 10210 iperiod=-((icode/10)*60+30) 10211 elseif(icode.eq.67) then 10212 iperiod=-15*60 10213 elseif(icode.eq.68) then 10214 iperiod=-18*60 10215 else 10216 ihour=icode/10 10217 iminutes=icode-ihour*10 10218 iperiod=-(ihour*60+iminutes*6) 10219 end if 10220 end if 10221C 10222 RETURN 10223 END 10224 10225