program WXPXPLOT C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C . . . . C MAIN PROGRAM: WXPXPLOT C PRGMMR: CARUSO ORG: NP12 DATE: 2000-03-13 C C ABSTRACT: MAKES THE WEATHER DEPICITION CHART FOR AFOS AND IS THE C FIRST OF THREE JOB STEPS USED TO MAKE THE WEATHER DEPICITION CHART C FOR FAX AND VARIAN. THIS PROGRAM IS RUN IN FOUR DIFFERENT PROD- C UCTION JOB STEPS, THEY ARE: RW1,RW3,RW4, RW5. FAX AND AFOS CHARTS C ARE MADE IN EACH RW RUN, BUT THE FAX CHART IS ONLY SENT IN RWS 3 & 4, C AND THE AFOS CHARTS ARE SENT IN RWS 1, 3, AND 5. C C PROGRAM HISTORY LOG: C 78-MM-DD ORIGINAL AUTHOR HENRICHSEN C 86-10-29 HENRICHSEN DOCUMENT. C 91-09-15 HENRICHSEN MODIFY STATION LOOKUP TABLE C ADD NEW DOCBLOCKS. MODIFY TO ALLOW FAX CHART C TO RUN EVERY HOUR. C REPLACED CALLS TO ENCODE WITH CALL TO MOVCH. C 91-10-01 HENRICHSEN CORRECT AND AN ERROR IN PLOTTING THE VISIBILIT C ON THE AFOS CHART. C 93-01-06 LUKE LIN CONVERT TO FORTRAN-77 AND PLOT AUTOMATIC STAT C AND SOME SPECIAL WW ON BOTH AFOS AND FAX CHART C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY, FAX ONLY C 97-07-09 RICHARD WOBUS - CORRECT BINARY SEARCH ALGORITHM, C ENLARGE STATION ARRAYS, ADD DIAGNOSTICS C 97-08-25 RICHARD WOBUS - ADD CONVERTED AFOS PLOT PRODUCT C 98-02-03 RICHARD WOBUS - Y2K YY TO YYYY CONVERSIONS END IN 2050 C 98-02-26 RICHARD WOBUS - CLEAN OUT OLD CODE AND UPDATE COMMENTS c 98-06-01 Chris Caruso - removed cdir$ integer=64 from top of this c code. c 98-06-19 Chris Caruso - extend COMMON ispaceaf to equal length c of that COMMON in s/r iniafbin c 99-07-14 Chris Caruso - replace w3as00 with getarg to read script c command line arguments on the ibm. c 99-08-09 Chris Caruso - add code to open afos output file as direct c access file. c 05-10-11 Chris Magee - increase creps and lenrep arrays from 3000 to c 4000 reports. c 06-06-07 Chris Magee - correct iwxaut array entry in position 27 from c '95' - TS w/ rain &/or snow to '17' - TS. Add c documentation to explain character set usage c when plotting wx symbols. c 06-12-07 Chris Magee - add code to check raw string for TSRA, TSSHRA, c and TSSN so that correct wx symbol is plotted C (instead of TS w/ './*' above it). C 12-12-12 Krishna Kumar - Added a non-fatal error condition when the metar C reports ever exceed 6000 C C USAGE: C INPUT PARAMETERS: C 1ST CHARACTER: TESTMODE: C TESTMODE=o FOR OPERATIONS C TESTMODE=t FOR TEST C INPUT FILES: C Fort.11 - STATION TABLE c fort.12 - control cards needed by s/r wxpxdata c fort.13 - metar data dumped from bufr database C Fort.14 - TABLE OF FAX CUTS C Fort.15 - DATE/TIME FILE C Fort.16 - RUN IDENTIFIER C Fort.48 - THE PRODUCTION PIL LIST FILE. C C OUTPUT FILES: C Fort.23 - title and LABEL INFORMATION PASSED TO WXPXANAL C Fort.28 - THIS FILE CONTAINS DATA FOR THE ANALYSIS STEP c (LAST STEP of wx dep production) C Fort.52 - THIS FILE CONTAINS THE COMPLETED AFOS GRAPHICS PRODUCT. C Fort.55 - THESE FILES CONTAIN THE LABLES FOR THE NEXT STEP. C thru THESE FILES ARE NECESSARY WHEN MAKING A FAX CHART BUT MAY C fort.63 BE DUMMY FILES WHEN ONLY AFOS IS DESIRED. C fort.97 Will generate a text file when the metar reports ever C exceed 6000 with non-fatal error messages which will C then be used to post the contents of this file to the C JLOGFILE C C SUBPROGRAMS CALLED: C NOTE: IJAREA DIFFERS FROM IJAREA IN GRAPHICS LIBRARY C UNIQUE - AFMDC3 AFMDC5 AFMDC8 AFSLGD BSIR C - CALLTR HRLYRD IJAREA MKCHDR MK_GHDR C - NONVIS RTFILL STAPLT w3fb04 WRTAFS c - wxpxdata contrl forsfc iniafbin C C W3LIB90 - W3TAGB W3TAGE c - w3utcdat w3doxdat C Gphlib90 - DUCK GTAPIL PUTLAB consol c system - getenv C C EXIT STATES: C COND = 0 - SUCCESSFUL RUN c = 1 - missing one or more input files c = 2 - error return from wxpxdata (reading bufr). C = 3 - error return from gtapil. c = 4 - error return from mk_ghdr. C = 5 - ERROR ON READING FT05 ,INPUT CARDS. c = 6 - end of file encountered C = 7 - ERROR opening afos output file as direct access. C = 8 - NON-FATAL warning if the total number of stations C exceeds 6000 C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM C C$$$ C C integer, parameter :: metar_counts=6000 COMMON /ISPACEAF/LBLOCK,ICNTOT,LBNKFG,lword4,maxcnt,ndsrn, * idum1,idum2,idum3,idum4,idum5 CHARACTER*1 LBLOCK(16384) integer icntot integer lbnkfg integer lword4 integer maxcnt integer ndsrn integer idum1,idum2,idum3,idum4,idum5 COMMON/ibgnd/t1,orient,ximax,xjmax,xipole,xjpole,xmeshl real t1,orient,ximax,xjmax,xipole,xjpole,xmeshl crlwb test integer krprlw(2) character*130 cirec character*3 lmo character*3 cdow, cmon character*4 irname COMMON/wxpisa/ rsastn,rsatbl(2700) integer rsastn character*12 rsatbl logical affb logical affrb crlwe COMMON/reports/ creps, CTHUND COMMON/numrep/ lenrep,icount CHARACTER*130 CREPS(metar_counts) CHARACTER*6 CTHUND(metar_counts) character*6 CTS integer lenrep(metar_counts) integer icount COMMON /KPLOT/ LABEL(2,1024),LABIX,NOBUF,IDRA(50) CHARACTER*4 IDRAC(50) EQUIVALENCE (IDRA(1),IDRAC(1)) C C THE AEROFORD DEVICE HEADER RECORD... COMMON / HEADER /IPRINT, IHD1 CHARACTER*10 IHD1 character*200 good1 character*23 ihd3 character*12 gpdheadr integer ngood data ngood/0/ C C THE PRODUCT DEFINITION CONSTANTS.... COMMON / PRODUK / PI,GS,PDC,ZD,ZT,ZFACT COMMON /PACKRA/JTIME(2),IVLDHR,IVLDAY,IVLDMO,IVLDYR, 1 IHOUR,IDAY,IMO,IYR4D,IXTZ INTEGER PI,GS,PDC,ZD,ZT,ZFACT COMMON/XYLOC/XOLD,YOLD,XNEW,YNEW,SCALE,LASTPN,IFIRST integer xold, yold, xnew, ynew, ifirst real scale integer kimax, kjmax data kimax /2048/ data kjmax /1536/ C integer idat(8) integer jdat(8) integer jdate(4) integer kdate(4) integer nchar integer(4) narg, iargc, numarg character*8 cbuf CHARACTER*70 ENDMSG CHARACTER*56 ENDMSS CHARACTER*70 MESG(7) c messages are set within code. listed here only for doc purposes. c data MESG/ c * 'ERROR MISSING ONE OR MORE INPUT FILES...ABORT', c * 'ERROR READING BUFR DATA VIA WXPXDATA ', c * 'ERROR NO AFOS MAPS MADE, BAD RETURN FROM GTAPIL= .: ', c * 'BAD RETURN FROM MK_GHDR. IRTN = .: ', c * 'ERROR WHILE READING INPUT OF WXPX PARAMETERS.', c * 'ERROR...PHYSICAL END OF FILE ENCOUNTERED ON c 'INPUT OF WXPX PARAMETERS.', c * 'ERROR OPENING AFOS OUTPUT FILE AS DIRECT ACCESS'/ C CHARACTER*112 goodend character*56 goodend1, goodend2 data goodend1 1/'NWS,GOT DATA FOR WX DEP VALID :'/ data goodend2 1/'NWS,MADE AFOS MAP POW :'/ C 1 '12345678901234567890123456789012345678901234567890123456 C real ANG00 data ANG00 /00.0/ real ANG90 data ANG90 /90.0/ real DOTSGI c data DOTSGI /56.25/ data DOTSGI /54.00/ real HGT01 data HGT01 / 1.0/ real HGT03 data HGT03 / 3.0/ real HGT04 data HGT04 / 4.0/ real HGT05 data HGT05 / 5.0/ real HGT11 data HGT11 /11.0/ real HGT16 data HGT16 /16.0/ real HGT17 data HGT17 /17.0/ real HGT18 data HGT18 /18.0/ real HGT21 data HGT21 /21.0/ real TABWW data TABWW /32.0/ C C.....FOR USE IN WRITING OUT DATA TO FILE MFILE FOR ANALYSIS STEP.. c CHARACTER*1 APLOT CHARACTER*1 AZOMT CHARACTER*8 BLANK8 data BLANK8 /' '/ character*4 ckrun character*28 dateln data dateln /'13Z FRI 13 AUG 1991 13+41 '/ CHARACTER*28 IBCD data IBCD /' '/ CHARACTER*4 IHVSBY data IHVSBY /' '/ CHARACTER*40 ltitle data ltitle /' WEATHER DEPICTION '/ character*4 imode C AFOS DATA OUTPUT UNIT NO integer afosout data afosout /52/ c data control file unit no with file unit and id info integer idatcunit data idatcunit /12/ c metar input file unit no integer imetunit data imetunit /13/ c plot control file unit no with file unit and id info integer ipltcunit data ipltcunit /14/ c date file unit no integer iunitdate data iunitdate /15/ c plot pass file unit no integer iptpsunit data iptpsunit /23/ c print unit no integer iprintunit data iprintunit/6/ c runid unit no integer irununit data irununit /16/ c label file unit no integer lblfil data lblfil /55/ crlwb c modify to overwrite test integer IPRY0(2) data IPRY0 /0,0/ integer IPRY1(2) data IPRY1 /0,1/ integer IPRY2(2) data IPRY2 /0,2/ integer IPRY0r(2) data IPRY0r /2,0/ integer IPRY1r(2) data IPRY1r /2,1/ integer IPRY2r(2) data IPRY2r /2,2/ crlwe CHARACTER*4 IWWXSN(2) c data IWWXSN /'7300','7300'/ !test pil data IWWXSN /'7211','7711'/ !prod. pil C THE SUBSET NUMBERS FOR WEATHER DEPICTION PLOT... CHARACTER*4 KHAAAA(5) data KHAAAA / 5*'AAAA'/ integer KNIT data KNIT /X'6F015B00'/ CHARACTER*4 KNITC EQUIVALENCE (KNIT,KNITC) C integer KPRIOR integer KROTAT data KROTAT /3/ CHARACTER*4 MINE data MINE /'CMC.'/ C integer LABIX CHARACTER*3 MONTHS(12) data MONTHS /'JAN','FEB','MAR','APR', $ 'MAY','JUN','JUL','AUG', $ 'SEP','OCT','NOV','DEC'/ CHARACTER*3 CDYOWK(7) data CDYOWK /'SUN','MON','TUE','WED', $ 'THU','FRI','SAT'/ integer MSKNAM data MSKNAM /X'FFFFFFEF'/ integer MSKOCT data MSKOCT /X'00000007'/ integer NAMSTN(2) CHARACTER*4 NAMSTA(2) EQUIVALENCE (NAMSTN(1),NAMSTA(1)) C integer PILFIL data PILFIL /48/ integer VFD12(15) data VFD12 /8,8,4,4,8,8,2,2,8,8,8,4,4,8,8/ integer VFD23(15) data VFD23 /8,8,4,4,4,4,2,2,2,2,2,2,2,2,2/ integer VFN12(15) data VFN12 /1,1,1,1,3,3,1,1,5,5,5,3,3,7,7/ integer VFN23(15) data VFN23 /1,1,1,1,1,1,1,1,1,1,1,1,1,1,1/ CHARACTER*24 WXPX data WXPX /'WXPXSF 00 Z WXDPN '/ C integer ICADS(3) data ICADS /62,69,76/ integer ILADS(9) integer IROTPR(2) integer IWWDTH(4) data IWWDTH /15,20,15,20/ integer JVIS(3,2771) integer JWWHGT(4) data JWWHGT /15,15,20,20/ integer LKUPSZ(106) data LKUPSZ 1 /0,0,0,0,3,3,2,2,2,4,1,1,1,1,1,1,1,1,1,1, A 1,1,1,1,1,1,1,1,1,1,3,1,3,3,1,3,1,1,1,1, B 3,1,1,1,1,1,1,1,4,4,1,1,2,3,2,2,3,3,1,2, C 1,1,1,1,2,2,3,3,1,2,1,3,2,4,2,4,3,3,3,1, D 2,2,2,2,2,2,2,2,2,2,2,4,4,4,4,4,4,4,4,4, E 4,4,4,4,4,4/ CHARACTER*1 LKUPWW(106) data LKUPWW 1 /'0','0','0','0','A','B','A','B','C','A','A','B', 2 'C','D','E','G','F','H','I','J','K','L','M','N', 3 'O','P','Q','R','S','T','C','U','D','E','V','F', 4 'W','X','Y','Z','G','0','1','2','3','4','5','6', 5 'B','C','7','8','D','H','E','F','I','J','9','G', 6 '-','+','/',')','H','I','K','L','(','J','.','M', 7 'K','D','L','E','N','O','P',',','P','Q','R','S', 8 'T','U','V','W','X','Y','Z','F','G','H','I','J', 9 'K','L','M','N','O','P','Q','R','S','T'/ integer iwxaut(200) data iwxaut/ z 00,01,02,03,05,05,-1,-1,-1,-1, 1 10,76,13,-1,-1,-1,-1,-1,18,-1, 2 45,63,53,63,73,57,17,36,36,38, 3 45,41,43,45,37,39,-1,-1,-1,-1, 4 63,63,65,63,65,73,75,66,67,-1, 5 53,51,53,55,56,57,57,58,59,-1, 6 63,61,63,65,66,67,67,68,69,-1, 7 73,71,73,75,79,79,79,-1,-1,-1, 8 81,80,81,81,82,86,86,86,-1,-1, 9 95,17,95,96,97,97,99,-1,-1,19, a -1,-1,-1,-1,04,-1,06,07,07,09, b 05,39,-1,13,-1,-1,-1,17,-1,19, c 31,31,-1,71,49,49,49,49,49,-1, d 31,-1,-1,-1,-1,-1,-1,-1,-1,38, e -1,45,45,12,12,12,45,45,45,45, f 51,51,53,53,53,55,55,55,-1,69, g 61,61,63,63,63,65,65,65,-1,-1, h 71,71,73,73,73,75,75,75,77,73, i 63,67,69,73,88,88,88,88,90,90, j 90,90,92,92,-1,-1,-1,-1,-1,-1/ integer N integer Nclm(3) data Nclm /60,67,74/ integer NCOL integer NPT integer NVADS data NVADS /51/ integer VFNUM(15) data VFNUM /1,1,3,1,5,3,7,1, 1 9,5,5,3,3,7,7/ integer VFDEN(15) data VFDEN /16, 8,16, 4,16, 8,16, 2, 1 16 ,8, 8, 4, 4, 8, 8/ ccc 1/16, 1/8, 3/16, 1/4, 5/16, 3/8, 7/16, 1/2, ccc 9/16, 5/8, 5/8, 3/4, 3/4, 7/8, 7/8 integer WWN C CHARACTER*4 DSNAME(11) data DSNAME /'NMC.','PROD','.RAW', 1 'DTA.','HRLY',6*' '/ CHARACTER*4 IDLAB integer LABEL LOGICAL LFOUND integer LHT data LHT /X'00000004'/ integer LNN data LNN /X'00000001'/ integer LVV data LVV /X'00000002'/ integer LWW data LWW /X'00000008'/ CHARACTER*4 STNAME integer SFCBPL CHARACTER*1 hocb1 CHARACTER*1 hocb2 CHARACTER*4 MAPEND data MAPEND /' END'/ C C.....END OF MAP MARKER FOR END OF FILE MFILE integer iceilhgt integer iceilhgtt(3) integer iclam(3) CHARACTER*5 IDIFAX CHARACTER*1 IHCHR CHARACTER*1 IRMK(6) data IRMK /'B','I','N','O','V','C'/ CHARACTER*1 ISYMBL(15) data ISYMBL /'A','B','C','D','E','F','G','H', 1 'I','J','K','L','M','N','O'/ CHARACTER*1 IVCHR CHARACTER*1 IVHUNT CHARACTER*1 KWW CHARACTER*1 LAVSBY(4) logical lchout CHARACTER*1 LI data LI /'I'/ CHARACTER*1 LMS data LMS /'-'/ CHARACTER*1 LPT data LPT /'.'/ CHARACTER*1 LST data LST /'/'/ CHARACTER*1 LSTAR data LSTAR /'*'/ character*4 ctmp LOGICAL LTHUND CHARACTER*8 LNXTLN integer LNXTL DATA LNXTL /X'0000000D'/ EQUIVALENCE (LNXTL,LNXTLN) CHARACTER*1 MSKF integer mskfi equivalence (mskf,mskfi) data MSKFi /X'0F'/ CHARACTER*4 NAFAX integer NSKY CHARACTER*130 CMETAR LOGICAL VV3 C CHARACTER*4 ISUBST CHARACTER*4 IHYRC CHARACTER*4 INNAME DATA INNAME/' '/ CHARACTER*4 IHCIGH CHARACTER*1 LVVFR,LHTFR,LFR CHARACTER*1 LSTNCR CHARACTER*1 LPRT LOGICAL LLPRT LOGICAL LRTN LOGICAL LOFTHH,LOFTWW CHARACTER*1 LBLANK data lblank /' '/ CHARACTER*5 OBTYPE LOGICAL AUTOST CHARACTER*1 RGTBKT data RGTBKT /']'/ C .....RIGHT BRACKET FOR AUTOMATIC STATION C integer(8) iexit c c COMMON block holding num. of afos records c COMMON/reccnt/ nrecnaf integer nrecnaf character*11 envvar data envvar/'XLFUNIT_ '/ character*80 cfilnam integer iunit(6) data iunit/11,12,13,14,15,16/ logical am_i_here logical foundrun data foundrun /.true./ EQUIVALENCE (IHVSBY,LAVSBY(1)) EQUIVALENCE (KPRIOR,IROTPR(1)) EQUIVALENCE (CMETAR(1:4),STNAME) C C ********************************************** CALL W3TAGB('WXPXPLOT',2000,0073,0079,'NP12') c c initialize ibgnd and xyloc constants. fill in goodend message. c t1 = 37.5 orient = 105.0 ximax = 55.0 xipole = 27.0 xjmax = 42.0 xjpole = 46.0 xmeshl = 190.5 ifirst = 0 scale = 100.0 do i = 1,56 goodend(i:i) = goodend1(i:i) goodend(i+56:i+56) = goodend2(i:i) enddo c c initialize error and end messages to all blanks c do k = 1,7 do j = 1,70 mesg(k)(j:j) = ' ' enddo enddo do j = 1,70 endmsg(j:j) = ' ' enddo do j = 1,50 endmss(j:j) = ' ' enddo C c check for necessary input files. if any are missing, abort. c note that file fort.16 is not necessary to run, so if it's c missing, set logical to indicate so and keep going. c do ii = 1,6 write(envvar(9:10),fmt='(i2.2)') iunit(ii) call getenv(envvar,cfilnam) inquire(file=cfilnam,exist=am_i_here,iostat=ierr) if(.not.am_i_here) then !file is missing if(ii.lt.6) then print 860, ii, cfilnam 860 format(//,' FILE ',i2,' NAME = ',a80,' DOES NOT EXIST...') print *,' ABORT WXPXPLOT.' WRITE(MESG(1)(1:45), * FMT='(''ERROR MISSING ONE OR MORE INPUT FILES...ABORT'')') iexit = 1 go to 999 else print*,' missing runid file. do not abort.' foundrun = .false. endif endif enddo c c open afos output file as direct access c nrecnaf = 0 irlaf = 1280 open(afosout,access='DIRECT',recl=irlaf,iostat=ios) if(ios.ne.0) then print*,' error opening afos output file as direct access' WRITE(MESG(7)(1:48), * FMT='('' ERROR OPENING AFOS OUTPUT FILE AS DIRECT ACCESS'')') iexit = 7 go to 999 endif ixxx = 0 call rtfill lchout = .false. C C . . . . STEP(0) . . . DETERMINE CURRENT HOURLY DATA FILE TIME. C READ IN command line arguments c narg = iargc() print *, 'narg=',narg do numarg = 1,narg call getarg(numarg,cbuf) enddo print*,' cbuf = ',cbuf C C . . . set print flag C c if(cbuf(1:1).eq.'t'.or.cbuf(1:1).eq.'T') lchout = .true. lchout = .true. C 120 CONTINUE C C MAKE BOTH FAX label file AND AFOS MAPS. C IKEY = 1 IENDKY = 2 write(6,'('' in WXPXPLOT: ikey,iendky'', * 2i5)') ikey,iendky 19 CONTINUE c c get system time only for minutes (needed for dateln) c call w3utcdat(jdat) print*,' jdat = ',jdat irunhour = jdat(5) irunmin = jdat(6) c c get date (4 digit year, mon, day, hr) from unit 19 c rewind iunitdate read(iunitdate,'(i4,3i2)') iyrin,imoin,idyin,ihrin print*,' after iunitdate read' print*,' iyrin = ',iyrin print*,' imoin = ',imoin print*,' idyin = ',idyin iyr4d = iyrin imo = imoin iday = idyin ihour = ihrin ivldhr = ihour ivlday = iday ivldmo = imo ivldyr = iyr4d idat(1) = iyrin idat(2) = imoin idat(3) = idyin idat(4) = -5 idat(5) = ihrin idat(6) = 0 idat(7) = 0 idat(8) = 0 call w3doxdat(idat,jdow,jdoy,jday) print*,' after doxdat' cdow = cdyowk(jdow) cmon = months(imoin) c C step(1). C read in metar data c call wxpxdata(idatcunit,imetunit,iyrin,imoin,idyin, * ihrin,lchout,irtn) print*,' after wxpxdata - irtn code = ',irtn if (irtn.ne.0) then if (irtn. eq. 8) then write(6,'('' ***** NON-FATAL ERROR in WXPXPLOT: * Number of Metar reports exceeded & return code * are='',2i5)')metar_counts,irtn GO TO 888 else write(6,'('' WXPXPLOT: err return from wxpxdata='',i5)') * irtn WRITE(MESG(2)(1:37), * FMT='(''ERROR READING BUFR DATA VIA WXPXDATA '')') IEXIT = 2 GO TO 999 endif endif C 888 CONTINUE C itz = ihour C C . . . GET PIL NUMBER BY CALLING GTAPIL.... C ISUBST = IWWXSN(1) IF ( IHOUR.GT.11) ISUBST = IWWXSN(2) CALL GTAPIL(ISUBST,PILFIL,IHD1,IRTN) IF(IRTN.NE.0) THEN WRITE(MESG(3)(1:56), * FMT='(''ERROR NO AFOS MAPS MADE, BAD RETURN FROM '', * ''GTAPIL= '',I3,'' .: '')') IRTN IEXIT = 3 GO TO 999 ENDIF C C DEFINE THE PRODUCT DEFINITION CONSTANTS. C pi = 1 GS = 2000 PDC = 0 ZD = 0 ZT = 0 ZFACT = 0 c c additional constants for afos c affb = .false. affrb = .false. izt = 0 isi = 0 C C DEFINE THE PARAMETERS FOR SUB INIT c IMAX = 2048 JMAX = 1536 ITIME = IHOUR * 100 SCFAC = 100.0 c c mkchdr and mk_ghdr must be called to initialize ugtf files c jdate(1) = iyrin jdate(2) = imoin jdate(3) = idyin jdate(4) = ihrin print*,' jdate = ',jdate(1),jdate(2),jdate(3),jdate(4) indicator = 1 call mkchdr(indicator,jdate,ihd1,good1,ngood,ihd3) print 1111,ihd3 1111 format( 1h ,' ihd3=', a23) do i = 1,4 kdate(i) = jdate(i) enddo call mk_ghdr(kdate,gs,kimax,kjmax,pi,gpdheadr,iretn_mkg) if (iretn_mkg.ne.0) then write(6,'('' in wxpxplot: mkghdr iretn ='',i8)')irtn PRINT *,' BAD RETURN FROM MK_GHDR ' WRITE(MESG(4)(1:40), * FMT='(''BAD RETURN FROM MK_GHDR. IRTN = '',I3, * ''.: '')') IRETN_MKG IEXIT = 4 go to 999 endif c c initialize COMMON/ispaceaf/ to 0 and save gpdheadr to c this COMMON. c call iniafbin(afosout,ihd3,gpdheadr,scale,iret_ini) if(iret_ini.ne.0) print*,' iret_ini = ',iret_ini lckpnt = 15 if(lchout) PRINT 17,lckpnt 17 FORMAT(' ', ' ARRIVED AT lckpnt =',I4) C c step (2). C INPUT PARAMETERS... C CARD = 1. C IDLAB IS INPUT CARD IDENTIFICATION. C IDSEQ IS INPUT CARD SEQUENCE NUMBERS, 1 THRU 8. C IMODE IS B, T, OR V... C B = BOTH VARIAN AND FACSIMILE TRANSMISSION C T = TEMPORARY - MANUAL TRANSMISSION C V = VARIAN TRANSMISSION C ISCHED IS SLOT NUMBER FOR STORAGE ON VARIAN DISK. C NAFAX IS NATIONAL FACSIMILE #. C IDIFAX IS DIGITIAL & AVIATION METEOROGICAL FACSIMILE #. C JSCHED IS SLOT NUMBER FOR STORAGE ON FAX DISK. C C SEARCH FOR TITLE CARD HEADER... c write(6,'('' WXPXPLOT: ready to read input cards'')') rewind ipltcunit 200 CONTINUE READ(ipltcunit,2000,ERR=996,END=997) IDLAB,IDSEQ,LPRT,MFILE 2000 FORMAT(A4,2X,I2,2X,A1,22X,I2) write(6,'('' '',a4,2x,i2,2x,a1,22x,i2)') 1 idlab,idseq,lprt,mfile IF(IDLAB.EQ.WXPX(1:4) .AND. IDSEQ.EQ.0) GO TO 210 GO TO 200 210 CONTINUE READ(ipltcunit,2100,ERR=996,END=997) IDLAB,IDSEQ,IMODE, $ ISCHED,NAFAX,IDIFAX,JSCHED 2100 FORMAT(A4,2X,I2,2X,A4,2X,I4,2X,A4,2X,A5,2X,I4) write(6,'('' '',a4,2x,i2,2x,a4,2x,i4,2x,a4,2x,a5,2x,i4)') 1 idlab,idseq,imode,isched,nafax,idifax,jsched IF(IDLAB.EQ.WXPX(1:4) .AND. IDSEQ.EQ.ITZ) GO TO 70 IF(IDLAB.EQ.WXPX(1:4) .AND. IDSEQ.EQ.ITZ+24) GO TO 70 GO TO 210 70 CONTINUE print*,' found match on idlab and idseq' write(6,'('' '',a4,2x,i2,2x,a4,2x,i4,2x,a4,2x,a5,2x,i4)') 1 idlab,idseq,imode,isched,nafax,idifax,jsched c C STATION DATE TIME GROUP FOR FILE MFILE c IF(LPRT.EQ.'R') then WRITE(MFILE,25) ihour, iday, imo, iyr4d 25 FORMAT(10x,i2,1x,i2,1x,i2,1x,i4) write(mfile,'(i5)') rsastn endif lckpnt = 70 24 FORMAT(' DATA WILL BE WRITTEN TO MFILE=',I2,' FOR ANALYSIS STEP'/) LLPRT = .FALSE. c c get run from unit 16 (irununit) if unit 16 is present. c if(foundrun) then rewind irununit read(irununit,'(a4)',err=26,end=26) ckrun write(6,'('' in WXPXPLOT: ckrun='',a4)') ckrun wxpx(21:24) = ckrun endif 26 CONTINUE C C ... ...STEP(3)...INITIALIZE PUTLAB FOR TEXT & GENERATE MAP LABELS... c rewind lblfil DO I = 1,1024 LABEL(1,I) = 0 LABEL(2,I) = 0 enddo LABIX = 0 NOBUF = 0 IBCD(1:4) = KNITC CALL PUTLAB(1,1,1.0,IBCD,0.0,4,IPRY0,0) C C TITLE FOR NORTH AMERICA WEATHER DEPICTION CHART. c IPT = 295 JPT = 184 c C LINE ONE....NOAA LABEL .. C CALL DUCK(IPT-6,JPT+03,0,7) C C LINE TWO...'WEATHER DEPICTION'... c CALL PUTLAB(IPT-6,JPT-27,HGT11,'WEATHER DEPICTION',ANG00,17, 1 IPRY1,0) C C LINE THREE...DATE TIME GROUP... C E.G. c dateln /'13Z FRI 13 AUG 1991 13+41 '/ c 1234567890123456789012345678 C c c put hour into dateln c write(ctmp(1:2),'(i2)') ihour if (ctmp(1:1).eq.' ') ctmp(1:1)='0' dateln(1:2) = ctmp(1:2) c c for gulf label c wxpx(10:11) = ctmp(1:2) c c put char day of week into dateln c dateln(5:7) = cdow(1:3) c c put numerical day of week into dateln c write(ctmp(1:2),'(i2)') iday if (ctmp(1:1).eq.' ') ctmp(1:1)='0' dateln(10:11) = ctmp(1:2) c c for gulf label c wxpx(13:14) = ctmp(1:2) c c put char month into dateln c dateln(13:15) = cmon(1:3) c c put year into dateln c write(ctmp(1:4),'(i4)') iyrin dateln(17:20) = ctmp(1:4) c c put run hour into dateln c write(ctmp(1:2),'(i2)') irunhour if (ctmp(1:1).eq.' ') ctmp(1:1)='0' dateln(22:23) = ctmp(1:2) C c put run minutes into dateln. c write(ctmp,'(i2)') irunmin if (ctmp(1:1).eq.' ') ctmp(1:1)='0' dateln(25:26) = ctmp(1:2) write(6,'('' in WXPXPLOT: dateln '',a28)') dateln goodend(33:52) = dateln(1:20) goodend(79:98) = dateln(1:20) C C NOW PUT TIME LINE INSIDE OF TITLE BOX. C CALL PUTLAB(IPT-30,JPT-53,HGT11,DATELN,ANG00,20,IPRY2,0) c C PLOT ADDITIONAL DTG GROUPS... c CALL PUTLAB(1875,0562,HGT21,DATELN,ANG90,26,IPRY2,0) C C EXTRA...'NOAA LABEL' IN ATLANTIC c CALL DUCK(1810,0562,1,7) C CALL PUTLAB(0008,0562,HGT21,DATELN,ANG90,26,IPRY2,0) CALL PUTLAB(0038,0562,HGT21,'WEATHER DEPICTION',ANG90,17, 2 IPRY2,0) print*,' fax labels done' C C PUT IN AFOS MAP TITLE .... c ltitle(1:20) = dateln(1:20) C C . . .LOAD NEXT LINE CHARACTER............ C ltitle(22:22) = lnxtln(8:8) C IX = 1250 IY = 250 ZT = 0 PRINT 64,LTITLE 64 FORMAT(' ','AFOS TITLE =',A40) call afmdc5(ltitle,40,ix,iy,affb,affrb,izt,isi,iretn) CALL AFSLGD lckpnt = 8 if(lchout) PRINT 17,lckpnt print*,' afos labels done' C 65 CONTINUE C C ...PUT DATE/TIME GROUP IN GULF OF ALASKA. C CALL PUTLAB(200,1150,HGT01,WXPX(5:9),ANG00,5,IPRY2,0) CALL PUTLAB(200,1150-15,HGT01,WXPX(10:14),ANG00,5,IPRY2,0) CALL PUTLAB(200,1150-30,HGT01,WXPX(15:19),ANG00,5,IPRY2,0) CALL PUTLAB(200,1150-45,HGT01,CKRUN,ANG00,4,IPRY2,0) c c pass dateln and gulf label to WXPXANAL C write(iptpsunit,'(a20)') dateln(1:20) write(iptpsunit,'(a20)') wxpx(5:24) write(iptpsunit,'(2i5,1x,a4,1x,a5,1x,a4)') * isched,jsched,nafax,idifax,imode C C LINE FOUR....NAFAX, IDIFAX AND NMC NUMBERS... C ibcd(1:4) = nafax(1:4) ibcd(5:12) = blank8(1:8) ibcd(13:17) = idifax(1:5) C CALL PUTLAB(IPT,JPT-78,1.0,IBCD,ANG00,17,IPRY1,0) CALL PUTLAB(IPT+220,JPT-78,19.0,MINE,ANG00,04,IPRY1,0) C C SURROUND DTG + LABELS WITH SOLID BORDER... c CALL PUTLAB(IPT-49,JPT+45,HGT16,KHAAAA,ANG00,17, * IPRY0,0) CALL PUTLAB(IPT-55,JPT-95,HGT16,KHAAAA,ANG00,17, * IPRY0,0) CALL PUTLAB(IPT-55,JPT-89,HGT17,KHAAAA,ANG90,07,IPRY0,0) CALL PUTLAB(IPT+285,JPT-95,HGT17,KHAAAA,ANG90,07,IPRY2,0) C C ...DRAW THE AUTOMATED STATION LEGEND ABOVE THE ORIGINAL c CALL PUTLAB(IPT-49,JPT+80,HGT16,KHAAAA,ANG00,17, * IPRY0,0) CALL PUTLAB(IPT-55,JPT+46,HGT17,KHAAAA,ANG90,02,IPRY0,0) CALL PUTLAB(IPT+285,JPT+46,HGT17,KHAAAA,ANG90,02,IPRY0,0) c C ..... STATION CIRCLE C ...SET THE KPRIOR TO ROTATE CHARACTER SIDEWAYS c IROTPR(1) = KROTAT IROTPR(2) = IPRY0(2) CALL PUTLAB(IPT-20,JPT+57,27.0,'A',ANG90,1,KPRIOR,0) CALL PUTLAB(IPT,JPT+57,42.0,RGTBKT,ANG90,1,KPRIOR,0) IROTPR(1) = 0 c C ..... RIGHT BRACKET c CALL PUTLAB(IPT+15,JPT+57,1.0,' IS AUTOMATIC WX OBS', X ANG00,20,IPRY0,0) C C FAX MAP DELINATORS... c C ...LOWER LEFT FAX CORNER MARK ... c ILLCRN = 3.0 * DOTSGI + 0.5 JLLCRN = 1.5 * DOTSGI + 0.5 ILLA = ILLCRN - 6 JLLA = JLLCRN - 6 CALL PUTLAB(ILLA,JLLA,HGT16,KHAAAA,ANG00,3,IPRY0,0) CALL PUTLAB(ILLA,JLLA,HGT17,KHAAAA,ANG90,3,IPRY0,0) c C ... UPPER LEFT FAX CORNER MARK ... c JULCRN = 22.0 * DOTSGI + 0.5 CALL PUTLAB(ILLA,JULCRN,HGT16,KHAAAA,ANG00,3,IPRY0,0) JULB = JULCRN + 6 - 60 CALL PUTLAB(ILLA,JULB,HGT17,KHAAAA,ANG90,3,IPRY0,0) c C ... LOWER RIGHT FAX CORNER MARK ... c ILRCRN = 35.0 * DOTSGI + 0.5 ILRA = ILRCRN + 6 - 60 CALL PUTLAB(ILRA,JLLA,HGT16,KHAAAA,ANG00,3,IPRY0,0) CALL PUTLAB(ILRCRN,JLLA,HGT17,KHAAAA,ANG90,3,IPRY0,0) c C ...UPPER RIGHT FAX CORNER MARK ... c CALL PUTLAB(ILRA,JULCRN,HGT16,KHAAAA,ANG00,3,IPRY0,0) CALL PUTLAB(ILRCRN,JULB,HGT17,KHAAAA,ANG90,3,IPRY0,0) CALL PUTLAB(1598,3225,HGT16,'AAA',ANG90,3,IPRY0,0) C C STATION MODEL & LEGEND... c ICNT = 0 lckpnt = 30 if(lchout) PRINT 17,lckpnt C C ... ...BEGIN TO READ INDIVIDUAL HOURLY REPORTS ... c 30 CONTINUE c if(lchout) print*,' top of 300 loop...icount = ',icount do 300 i = 1,icount print *,' icnt is ',icnt c c blank out cmetar in case new report is shorter than c previous one. c do jj = 1,130 cmetar(jj:jj) = ' ' enddo c c read new report into cmetar c ilength = lenrep(i) do ix = 1,ilength cmetar(ix:ix) = creps(i)(ix:ix) enddo if (cmetar(1:4).eq." ") then write(6,'('' WXPXPLOT: blank record read'')') go to 300 endif c c read new report's CTHUND string into CTS c CTS(1:6) = CTHUND(i)(1:6) ixxx = ixxx + 1 c c remove duplicates c if (inname.eq.stname) then go to 300 else INNAME = STNAME endif iwrite = 0 if(inname.eq.'CWAE') iwrite = 1 if(inname.eq.'CWAN') iwrite = 1 if(inname.eq.'KE74') iwrite = 1 if(inname.eq.'KEWB') iwrite = 1 if(inname.eq.'KSAV') iwrite = 1 if(inname.eq.'KSLN') iwrite = 1 if(inname.eq.'KSMN') iwrite = 1 if(inname.eq.'MYGW') iwrite = 1 if(inname.eq.'MYNN') iwrite = 1 if (iwrite.eq.1) then write(6,'('' in WXPXPLOT: inname = '',A4)') inname endif C C ... ...STEP(4)...STATION CALLERS - LOOK FOR STN IN PLOT TABLE... c CALL CALLTR(INNAME,iskew,IPLPRI,LFOUND) c c add new usage: c c iplpri=0 means plot sky cover, cld ht, present wx, visibility c iplpri=1 means plot present wx c iplpri=2 means plot present wx only if thunderstorm or severe c iplpri=4 means no plot, save category for analysis only c c izoomt=0-3 is AFOS zoom threshhold c izoomt=4 means no afos plot c these numbers suppress the plot of thunderstorms where c many stations are crowded together c if (iwrite.eq.1) then write(6,'('' in WXPXPLOT: iskew,iplpri'',1x,o3,i4))') 1 iskew,iplpri endif LTHUND = .FALSE. IZOOMT = IPLPRI/10 IPLPRI = MOD(IPLPRI,10) NAMSTA(1) = STNAME namsta(2) = blank8(1:4) C C ... ...STEP(6)...LATITUDE AND LONGITUDE. C GET LAT & LONG FOR EACH STATION AND CONVERT TO REAL FORMAT... C C LATITUDES ARE ALL NORTH & C LONGITUDES ARE ALL WEST. C c check to see if lat or long are missing. if so, skip this report c if(cmetar(9:13).eq.'99999'.or.cmetar(14:19).eq.'999999') * go to 300 read(cmetar(9:12),fmt='(i4)') lat if(cmetar(13:13).eq.'S') lat = -lat read(cmetar(14:18),fmt='(i5)') lon if(cmetar(19:19).eq.'E') lon = 36000 - lon rlat = lat/100. rlon = lon/100. C C ... ...STEP(7)...GET I/J PLOT COORDINATES FOR GIVEN LAT & LONG... c CALL IJAREA(RLAT,RLON,ICTR,JCTR,LRTN) c C CHECK RETURN STATUS FROM IJAREA... c IFLAG = 0 if (.not. lrtn) then if ( .not.lfound) then write(6,'('' in wxpxplot: stn not in range, lo,la,i,j:'' 1 ,a4,2f9.3,2i7)') inname,rlon,rlat,ictr,jctr else write(6,'('' in wxpxplot: stn not in range, lo,la,i,j:'' 1 ,a4,2f9.3,2i7,'' in table'')')inname,rlon,rlat,ictr,jctr endif else if (.not. lfound) then write(6,'('' in wxpxplot: stn not in table, lo,la: '' 1 ,a4,2f9.3)') inname,rlon,rlat endif endif c c move notfound test here so nonfound stations can be listed c IF( .NOT. LRTN) GO TO 300 IF(.NOT.LFOUND) GO TO 300 if(lchout) print 654,rlat,rlon 654 format(' found station in table..rlat = ',f7.2, * ' rlon = ',f8.2) C C ... ...STEP(8)...OBTAIN PARAMETERS FOR PLOTTING, WHICH ARE... C N, VV, WW, & CLD HGT. SFCBPL = 0 VV3 = .FALSE. C C ... ...STEP(8A)...N - TOTAL SKY COVER. C SKY COVERAGE LEGEND... C N =0 CLEAR C N =1,2 FEW c N =3,4 SCATTERED C N =5,6,7 BROKEN C N =8 OVERCAST C N =9 OBSCURATION C N =10 MISSING C C DEFAULT FOR TOTAL SKY COVER IS MISSING...N =10. c N = 10 C C LOOK AT EACH OF THREE CLOUD LAYERS... c read(cmetar(59:59),fmt='(i1)') inret if(inret.ne.0) then DO 81 IL = 1,inret C C ....CLOUD LAYER ADDRESSES c NCOL = Nclm(IL) if(cmetar(ncol:ncol+1).ne.' ') then read(cmetar(ncol:ncol+1),fmt='(i2)') nsky else c C ....GET NEXT TWO CHARACHERS... c hocb1 = cmetar(NCOL+2:ncol+2) hocb2 = cmetar(NCOL+3:ncol+3) c C ...CLEAR SKY CHECK... c IF(hocb1.EQ.'C' .AND. hocb2.EQ.'L') N = 0 go to 81 endif c c check for missing c if(nsky.eq.99) go to 81 c c check for clam = 10 (partially obscured) or 15 (indiscernible for c reasons other than fog or other met. phenom, or obs wasn't made). c check for clam = 14 (reserved, so set n to 10 (missing). c if(nsky.eq.10.or.nsky.eq.15) n = 9 if(nsky.eq.14) n = 10 c c check for valid clam values c if(nsky.ge.0.and.nsky.le.9) n = nsky 81 CONTINUE endif C C LOOK FOR 'BINOVC' WHEN N = 8. c IF(N.EQ.8) then J = 1 DO 83 II = 1,50 IC = 79 + ii IF(cmetar(IC:IC).NE.IRMK(J)) GO TO 83 IF(J.EQ.6) N = 7 J = J +1 83 CONTINUE endif if(lchout) print 655,stname,n 655 format(' for station = ',a4,' n = ',i2) c C SET FLAG FOR PLOTTING SKY COVER... c SFCBPL = IOR(SFCBPL,LNN) C C ... ...STEP(8B)...VV - HORIZONTAL SURFACE VISIBILITY. C INITIALIZE SETUP VARIABLES... c NPT = 0 ihvsby(1:4) = blank8(1:4) c C MISSING VISIBILITY CHECK... c IF(cmetar(NVADS:NVADS).EQ.'9') then rsvby = 0. GO TO 840 else C c check visibility. will be plotted if le 5 miles c convert visibility from m to miles here (ivsby is c in meters, x (100 cm/m) x (1 in/2.54 cm) x (1 ft/12 in) c x (1 mi/5280 ft.). c read(cmetar(nvads:nvads+4),fmt='(i5)') ivsby rvsby = float(ivsby) * 100. * (1./2.54) & * (1./12.) * (1./5280.) ivsby = rvsby endif IF(ivsby.LT.3) VV3 =.TRUE. c C PLOT VISIBILITY IF LESS THAN OR EQUAL TO 5 MILES. c IF(ivsby.le.5) then C C SET FLAG FOR PLOTTING VISIBILITY... c SFCBPL = IOR(SFCBPL,LVV) endif 840 CONTINUE if(lchout) print 656,stname,ivsby,rvsby 656 format(' for station = ',a4,' ivsby = ',i6, * ' rvsby = ',f8.2) C C ... ...STEP(8C)...H - ING HEIGHT. C DEFAULT FOR CEILING HEIGHT IS MISSING...ICEILHGT =-1. c ICEILHGT = -1 rceilhgt = -1.0 c C CLEAR SKY CHECK... c IF(N.NE.0) then c C LOOK FOR CLOUD LAYER INDICATOR... c if(inret.ne.0) then C C GET CLOUD HEIGHT FOR PLOTTING... c first, get ceiling. ceiling is the c height of the lowest layer of clouds c above the sfc that are either broken c or overcast. when found, convert c hocb to feet, then divide by 100 c to get value expected for plotting c get starting column for each loop c ICEILHGT = 0 DO IH = 1,inret iscol = icads(ih) if(cmetar(iscol:iscol+4).ne.'99999') then read(cmetar(iscol:iscol+4),fmt='(i5)') iceilhgtt(ih) read(cmetar((iscol-2):(iscol-1)),fmt='(i2)') iclam(ih) else iceilhgtt(ih) = -1 iclam(ih) = -1 endif enddo if(inret.eq.1) then c c only 1 cloud layer present c if(iclam(1).ge.5.and.iclam(1).lt.9) then iceilhgt = iceilhgtt(1) else iceilhgt = -1 endif elseif(inret.eq.2) then c c 2 cloud layers present. clam2 can never be less c than or equal to clam1. if clam1 is bkn or ovc, use that c cloud base as ceiling. if clam1 isn't bkn or ovc, then c check clam2 to see if it's bkn or ovc, and if so, use that c cloud base as ceiling. if both are not bkn or ovc, set c ceiling to missing. c if(iclam(1).ge.5.and.iclam(1).lt.9) then iceilhgt = iceilhgtt(1) elseif(iclam(2).ge.5.and.iclam(2).lt.9) then iceilhgt = iceilhgtt(2) else iceilhgt = -1 endif elseif(inret.eq.3) then c c 3 cloud layers present. for ceiling, use cloud height c associated with first clam that's ge 5 and lt 9. c if(iclam(1).ge.5.and.iclam(1).lt.9) then iceilhgt = iceilhgtt(1) elseif(iclam(2).ge.5.and.iclam(2).lt.9) then iceilhgt = iceilhgtt(2) elseif(iclam(3).ge.5.and.iclam(3).lt.9) then iceilhgt = iceilhgtt(3) else iceilhgt = -1 endif endif c c convert from meters to feet/100. c if(iceilhgt.gt.0) then rceilhgt = float(iceilhgt) * 3.2808 / 100. iceilhgt = nint(rceilhgt) !in feet/100 endif endif IF(ICEILHGT.NE.-1) SFCBPL = IOR(SFCBPL,LHT) endif if(lchout) print 657,stname,iceilhgt,rceilhgt 657 format(' for station = ',a4,' iceil = ',i6, * ' rceil = ',f8.2) C C ... ...STEP(8D)...WW - PRESENT WEATHER. c wwn = -1 if(cmetar(56:58).ne.'999') then read(cmetar(56:58),fmt='(i3)') wwn endif iauto = 0 autost = .false. if(wwn.ge.100.and.wwn.lt.199) then iauto = 1 autost = .true. endif ixw = -777 if(wwn.ge.100) then if(wwn.le.299) then ixw = wwn - 99 wwn = iwxaut(ixw) else wwn = -1 ixw = -333 endif endif iwwno = wwn c c this logic is from the former wwcnvt.f c C ... THAT FINISHES FOR MOST CASES; BUT FOR A FEW SPECIAL WX CODES C ... OF OBSTRUCTION TO VSBY, WE WILL ADD MORE LOGIC HERE ... C IF(WWN .EQ. 4) THEN c C ... OBSTRUCTION BY SMOKE ... c if visibility gt 5 miles, set ww to missing. c IF(rvsby .GT. 5.005) then wwn = -1 endif ELSEIF(WWN .EQ. 5) THEN c C ... OBSTRUCTION BY HAZE ... c if visibility gt 5 miles, set ww to missing. c IF(rvsby .GT. 5.005) then wwn = -1 endif ELSEIF(WWN .EQ. 6) THEN c C ... OBSTRUCTION BY DUST ... c if visibility gt 5 miles, set ww to missing. c IF(rvsby .GT. 5.005) then wwn = -1 endif ELSEIF(WWN .EQ. 7) THEN c C ... OBSTRUCTION BY BLOWING DUST OR SAND ... c if visibility gt 5 miles, set ww to missing. c IF(rvsby .GT. 5.005) then wwn = -1 else IF(rvsby.le.0.625) THEN !vis lt 10/16 mi. IF(rvsby.le.0.3125) THEN !vis lt 5/16 mi. WWN = 34 ELSE WWN = 31 ENDIF ENDIF endif ELSEIF(WWN .EQ. 10) THEN c C ... OBSTRUCTION BY FOG ... c if visibility gt 5 miles, set ww to missing. c IF(rvsby .GT. 5.005) then wwn = -1 else IF(rvsby.le.0.625) THEN !vis lt 10/16 mi IF(N .EQ. 9) THEN WWN = 45 ELSE WWN = 44 ENDIF endif endif ELSEIF(WWN .EQ. 37) THEN c C ... OBSTRUCTION BY DRIFTING SNOW ... c if visibility gt 5 miles, set ww to missing. c IF(rvsby .GT. 5.005) then wwn = -1 else IF(rvsby.le.0.625) THEN !vis lt 10/16 mi. IF(rvsby.le.0.3125) THEN !vis lt 5/16 mi. WWN = 39 ELSE WWN = 38 ENDIF ENDIF endif ELSEIF(WWN .EQ. 76) THEN c C ... OBSTRUCTION BY ICE NEEDLES ... c if visibility gt 5 miles, set ww to missing. c IF(rvsby .GT. 5.005) then wwn = -1 endif ENDIF C c if we changed the present weather number, then print c if (wwn.ne.iwwno) then write(6,'('' in WXPXPLOT:'', z '' after adj: stn,iwwno,wwn,iauto,rvsby,n'', 1 1x,a4,2i4,i3,f7.3,i3)') inname,iwwno,wwn,iauto,rvsby,n endif if (wwn.eq.0) then wwn = -1 endif IF(WWN.NE.-1) SFCBPL = IOR(SFCBPL,LWW) if(lchout) print 658,stname,wwn,izoomt,iplpri 658 format(' for station = ',a4,' wwn = ',i4,' izoomt = ', * i4,' iplpri = ',i4) C C ... ...STEP(9)...PLOT SEQUENCE VIA 'PUTLAB'... C C ADJUST ICTR & JCTR COORDINATES TO UPPER LEFT CORNER, C SIDEWAY PROJECTION... c IPT = ICTR - 7 JPT = JCTR - 7 IROTPR(1) = KROTAT IROTPR(2) = IPRY0(2) LOFTHH = .FALSE. LOFTWW = .FALSE. JCTR2 = JCTR C C ... ...STEP(9A)...PLOT STATION CIRCLE WITH CLOUD AMOUNT... C ...OTHERWISE, THIS STN NOT PLOTTED, EXCP FOR WW (IF ANY) c AND CATEGORY. c IF(IPLPRI .ge. 2) then IPT = ICTR + 7 GO TO 510 endif IF(IAND(SFCBPL,LNN).NE.0) then LSTNCR = ISYMBL(N+1) CALL PUTLAB(IPT,JPT,27.0,LSTNCR,ANG90,1,KPRIOR,0) c C PUT A RIGHT BRACKET BEHIND THE STATION CIRCLE FOR AUTO WX OBS c if (iauto.eq.1) then IPTBK = IPT + 15 JPTBK = JPT CALL PUTLAB(IPTBK,JPTBK,42.0,RGTBKT,ANG90,1,KPRIOR,0) ENDIF endif C C ... ...STEP(9B)...PLOT PRESENT WEATHER... c 510 CONTINUE IWW = WWN IF(IAND(SFCBPL,LWW).EQ.0) GO TO 530 c c changed the following line to lt 100 (was previously le 105). c earlier code prevents any wwn from being greater than 99 (if c wwn ge 100 and le 299, array iwxaut is accessed for new wwn). c IF((WWN.EQ.17).OR.(WWN.GE.90.AND.WWN.LT.100)) LTHUND = .TRUE. IF(WWN.EQ.19.OR.IXW.EQ.105) LTHUND = .TRUE. c C .... ADD TORNADO AND VOLASH INTO SEVERE THUNDERSTORM c C ...ADD LOGIC FOR SPECIAL PRESENT WEATHER SYMBOL LIKE P, P-, ... c IF (WWN.LT.100) THEN IWWNU = WWN + 1 c c don't even plot a thunderstorm if priority ge 4 c if (iplpri.ge.4) go to 530 c C NULL SET CHECK... c IF(IWWNU.LE.4) GO TO 530 IF(IPLPRI.ge.2) then c C ...OTHERWISE, DO NOT PLOT THIS STATION EXCEPT FOR THUNDERSTORM WW c IF( .NOT. LTHUND ) GO TO 560 endif KWW = LKUPWW(IWWNU) KWWSZ = LKUPSZ(IWWNU) ZHGT = FLOAT(KWWSZ) C C* IF thunderstorm, check for specific strings TSRA, TSSHRA, or C* TSSN in Remarks to reset the plotted symbol from generic TS C* w/ rain and/or snow (./*) to TS with rain or TS with snow. C* Don't modify if auto station reports both rain and snow w/ TS! C IF ( LTHUND ) THEN print*,' CTS = ',CTS ivctsra = INDEX ( CTS, 'VCTSRA') itsrasn = INDEX ( CTS, 'TSRASN') itssnra = INDEX ( CTS, 'TSSNRA') itsra = INDEX ( CTS, 'TSRA') itsshra = INDEX ( CTS, 'TSSHRA') itssn = INDEX ( CTS, 'TSSN') IF ( itsrasn .eq. 0 .and. itssnra .eq. 0 .and. * ivctsra .eq. 0 ) THEN print*,' found a TS!' IF ( itsra .ne. 0 .or. itsshra .ne. 0 ) THEN print*,' found a TSRA or TSSHRA!!!' IF ( IWWNU .eq. 96 ) THEN KWW = 'Q' KWWSZ = 4 ZHGT = 4.0 ELSE IF ( IWWNU .eq. 98 ) THEN KWW = 'S' KWWSZ = 4 ZHGT = 4.0 END IF END IF IF ( itssn .ne. 0 ) THEN print*,' found a TSSN!!!' IF ( IWWNU .eq. 96 ) THEN KWW = 'R' KWWSZ = 4 ZHGT = 4.0 ELSE IF ( IWWNU .eq. 98 ) THEN KWW = 'T' KWWSZ = 4 ZHGT = 4.0 END IF END IF END IF END IF IMOVWW = ISHFT(iskew,-3) IMOVWW = IAND(IMOVWW,MSKOCT) if(imovww.eq.1) then c C ... COMES HERE IF IMOVWW=1, TO MOVE WW LINE UP 10 DOTS c JCTR2 = JCTR + 10 IPT = IPT - JWWHGT(KWWSZ) JPT = JCTR2 - IWWDTH(KWWSZ) / 2 elseif(imovww.eq.2) then c C ...COMES HERE IF IMOVWW=2, TO MOVE WW DIRECTLY ABV CIRCLE c LOFTWW = .TRUE. JPT = JCTR + 8 IPT = ICTR - JWWHGT(KWWSZ) / 2 elseif(imovww.eq.3) then C ...COMES HERE IF IMOVWW=3, TO MOVE WW LINE DOWNWARD 10 DOTS JCTR2 = JCTR - 10 IPT = IPT - JWWHGT(KWWSZ) JPT = JCTR2 - IWWDTH(KWWSZ) / 2 elseif(imovww.eq.4) then C ... COMES HERE IF IMOVWW=4, TO MOVE WW DIRECTLY UNDER CIRCLE JPT = JCTR - 7 - IWWDTH(KWWSZ) IPT = ICTR - JWWHGT(KWWSZ) / 2 else IPT = IPT - JWWHGT(KWWSZ) JPT = JCTR2 - IWWDTH(KWWSZ) / 2 endif IROTPR(2) = IPRY2(2) C C* To determine which character set to use, ANG90 must C* be used when specifying an explicit character set (see C* /nwprod/lib/sorc/gph/putlab.f documentation). Third input C* arg to putlab (here it's ZHGT+TABWW) is also used to define C* which char set to use. For plotting present weather symbols, C* ZHGT is set via lookup table LKUPSZ and is valued from 0 to 4. C* This is added to TABWW (TABWW = 32) to set char sets from 32 C* to 36, which include all the wx symbols. Entries in LKUPSZ C* correspond to the present weather code IWWNU which is set using C* the present weather value read from BUFR. C print*,' calling putlab with kww = ',kww,' zhgt = ',zhgt CALL PUTLAB(IPT,JPT,ZHGT+TABWW,KWW,ANG90,1,KPRIOR,0) endif IF (IXW .EQ. 28) THEN c c automated station...blowing other (unknown type) c PRINT *,' ***** FIND A BO.' IPTWW = ICTR - 9 JPTWW = JCTR + 8 CALL PUTLAB(IPTWW,JPTWW,HGT03,'BO',ANG90,2,KPRIOR,0) ELSEIF (IXW .EQ. 22 .or. IXW .EQ. 41) THEN c c automated station...precip (unknown type) c PRINT *,' ***** FIND A P.' IPTWW = ICTR - 4 JPTWW = JCTR + 8 CALL PUTLAB(IPTWW,JPTWW,HGT03,'P',ANG90,1,KPRIOR,0) ELSEIF (IXW .EQ. 81) THEN c c automated station...light precip (unknown type) c PRINT *,' ***** FIND A P-.' IPTWW = ICTR - 9 JPTWW = JCTR + 8 CALL PUTLAB(IPTWW,JPTWW,HGT03,'P-',ANG90,2,KPRIOR,0) ELSEIF (IXW .EQ. 100 .or. IXW .EQ. 120) THEN PRINT *,' ***** FIND A TORNADO' IPTWW = ICTR - 21 JPTWW = JCTR + 8 CALL PUTLAB(IPTWW,JPTWW,HGT05,'TORNADO',ANG90,7,KPRIOR,0) ELSEIF (IXW .EQ. 105) THEN PRINT *,' ***** FIND A VOLCANIC ASH' IPTWW = ICTR - 17 JPTWW = JCTR + 8 CALL PUTLAB(IPTWW,JPTWW,HGT05,'VOLASH',ANG90,6,KPRIOR,0) ENDIF C C ... ...STEP(9C)...PLOT SURFACE VISIBILITY... c 530 CONTINUE IF(IPLPRI .GE. 2) GO TO 558 C ...WHICH SKIPS TO IFR CATEGORY CHECK, IF NON-PLOTTED STN IF(IAND(SFCBPL,LVV).EQ.0) GO TO 550 C C FRACTIONAL MILE CHECK... c first, compute fraction of visibility. c ifx16 is fraction multiplied by 16. c find nearest whole number to ifx16 for c fractional numerator, then determine the c proper denominator c fract = rvsby - float(ivsby) if(fract.lt.0.001) fract = 0.0 ifx16 = nint(fract * 16.) IF(ivsby.lt.3.and.ifx16.gt.0) then JPT = JCTR2 - 9 IPT = IPT - 14 IF(rvsby.lt.1.) then if(ifx16.eq.1.or.ifx16.eq.3.or. * ifx16.eq.5.or.ifx16.eq.7.or. * ifx16.eq.9) then idenom = 16 inumer = ifx16 elseif(ifx16.eq.2.or.ifx16.eq.6.or. * ifx16.eq.10.or.ifx16.eq.11.or. * ifx16.eq.14.or.ifx16.eq.15) then idenom = 8 inumer = ifx16/2 elseif(ifx16.eq.4.or.ifx16.eq.12.or. * ifx16.eq.13) then idenom = 4 inumer = ifx16/4 elseif(ifx16.eq.8) then idenom = 2 inumer = 1 endif else IF(rvsby.GE.2.) then inumer = 1 if(ifx16.le.2.) then idenom = 8 elseif(ifx16.le.6) then idenom = 4 else idenom = 2 endif elseif(rvsby.LT.2.) then if(ifx16.le.2.or.ifx16.eq.5.or.ifx16.eq.6.or. * (ifx16.ge.9.and.ifx16.le.11).or. * ifx16.ge.14) then idenom = 8 elseif(ifx16.eq.3.or.ifx16.eq.4.or. * ifx16.eq.12.or.ifx16.eq.13) then idenom = 4 else idenom = 2 endif if(ifx16.le.4.or.ifx16.eq.7.or.ifx16.eq.8) then inumer = 1 elseif(ifx16.eq.5.or.ifx16.eq.6.or. * ifx16.eq.12.or.ifx16.eq.13) then inumer = 3 elseif(ifx16.ge.9.and.ifx16.le.11) then inumer = 5 else inumer = 7 endif endif endif IF(IDENOM .NE. 16) IPT = IPT + 7 if(idenom.lt.10) then write(ihvsby(3:3),fmt='(i1)') idenom ihvsby(4:4) = ' ' else write(ihvsby(3:4),fmt='(i2)') idenom endif c if(idenom.lt.10) then CALL PUTLAB(IPT,JPT,19.0,Ihvsby(3:3),ANG00,1,IPRY2,0) else CALL PUTLAB(IPT,JPT,19.0,Ihvsby(3:4),ANG00,2,IPRY2,0) endif c c put in numerator. c move slash code after numerator c skip over slash c ipt = ipt - 4 JPT = JCTR2 IPT = IPT - 5 write(ihvsby(2:2),fmt='(i1)') inumer CALL PUTLAB(IPT,JPT,19.0,Ihvsby(2:2),ANG00,1,IPRY2,0) c C PUT IN FRACTIONAL SLASH... c skip back over numerator c ipt = ipt + 4 ipt = ipt + 5 c c plot slash here c JPT = JCTR2 - 4 IPT = IPT - 3 CALL PUTLAB(IPT,JPT,38.0,'H',ANG00,1,IPRY2,0) IPT = IPT - 1 CALL PUTLAB(IPT,JPT,38.0,'H',ANG00,1,IPRY2,0) c c skip forward over numerator c JPT = JCTR2 ipt = ipt - 5 IF(rvsby.EQ.0.) GO TO 544 endif JPT = JCTR2 - 7 IPT = IPT - 12 c C LOAD WHOLE VISBY INTO 1ST BYTE OF IHVSBY FOR AFOS. c write(ihvsby(1:1),fmt='(i1)') ivsby if(ivsby.gt.0) then CALL PUTLAB(IPT,JPT,HGT18,Ihvsby(1:1),ANG00,1,IPRY1,0) endif 544 CONTINUE 550 CONTINUE C ... C ... ...STEP(9D)...PLOT CEILING HEIGHT... C ... ihcigh = blank8(1:4) IF(IAND(SFCBPL,LHT).EQ.0) GO TO 558 if(iceilhgt.lt.10) then write(ibcd(1:1),fmt='(i1)') iceilhgt ibcd(2:3) = ' ' nchar = 1 elseif(iceilhgt.lt.100) then write(ibcd(1:2),fmt='(i2)') iceilhgt ibcd(3:3) = ' ' nchar = 2 else write(ibcd(1:3),fmt='(i3)') iceilhgt nchar = 3 endif write(ihcigh,'(i3)') iceilhgt IMOVHT = IAND(iskew,MSKOCT) if(lchout) print*,' imovht = ',imovht if(imovht.eq.1) then c C ... COMES HERE IF IMOVHT=1, TO MOVE HHH TO LOWER RIGHT CORNER c IPT = ICTR + 5 JPT = JCTR - 16 elseif(imovht.eq.2) then c C ... COMES HERE IF IMOVHT=2, TO MOVE HHH UP ALONGSIDE (RIGHT) c LOFTHH = .TRUE. IPT = ICTR + 8 JPT = JCTR - 9 elseif(imovht.eq.3) then c C ... COMES HERE IF IMOVHT=3, TO MOVE HHH TO LOWER LEFT c if(nchar.eq.3) then IPT = ICTR - 30 elseif(nchar.eq.2) then IPT = ICTR - 20 else ipt = ictr - 10 endif JPT = JCTR - 21 else JPT = JCTR - 7 - 12 IPT = ICTR - 8 IF(ICEILHGT .LT. 10) IPT = IPT + 5 IF(ICEILHGT .GT. 99) IPT = IPT - 5 endif CALL PUTLAB(IPT,JPT,HGT01,IBCD,ANG00,nchar,IPRY1,0) 558 CONTINUE IPLOTQ = SFCBPL IPLOTQ = IAND(IPLOTQ,MSKNAM) C C ... WHICH TURNS OFF THE PLOTTING OF STN NAME FOR AFOS ... C IN = N IF(IPLPRI .LT. 2) GO TO 5300 C C ... OTHERWISE,THIS IS A DISCARD UNLESS ITS A THUNDERSTORM... C IF(.NOT. LTHUND) GO TO 560 IPLOTQ = 8 IZOOMT = 0 5300 CONTINUE C C ...LAT. LONG. CONVERSION FOR SUB STAPLT call w3fb04(rlat,rlon,xmeshl,orient,xi,xj) xi = xipole + xi xj = xjpole + xj if(xi.lt.1.0) go to 300 if(xj.lt.1.0) go to 300 if(xi.gt.ximax) go to 300 if(xj.gt.xjmax) go to 300 IDOT = (XI - 1.0) * T1 + 0.5 JDOT = (XJ - 1.0) * T1 + 0.5 C C ... PLOTTER SUB FOR WEATHER DEPICTION CHART c this is for the AFOS plotting string C if (izoomt.le.3) then if(lchout) print 754,idot,jdot,izoomt,in,ihvsby,iww if(lchout) print 755,ihcigh,namsta,iplotq 754 format(' calling staplt with idot = ',i5,' jdot = ',i5, * ' izoomt = ',i5,' in = ',i5,' ihvsby = ',a4, * ' iww = ',i6) 755 format(' ihcigh = ',a4,' namsta = ',2a4,' iplotq = ',i6) CALL STAPLT(IprintUNIT,IDOT,JDOT,IZOOMT,IN,IHVSBY,IWW, 1 ihcigh,NAMSTa,IPLOTQ,IFLAG,LLPRT,AUTOST,lchout) endif C C ... ...STEP(9E)...PLOT INDICATOR FOR IFR OR MARGINAL VFR. C 560 CONTINUE C IFR =2 WHEN ICEILHGT LESS THAN 1000 FEET &/OR C rvsby IS LESS 3 MILES. C MVFR =1 WHEN ICEILHGT IS BETWEEN 1000 TO 3000 C FEET &/OR rvsby IS 3 MILES OR MORE. C C CLOUD AMOUNT MISSING, BY PASS THIS SECTION. IF(N.EQ.10) GO TO 590 LVVFR = '3' LHTFR = '3' C C LOOK AT VISIBILITY... C IF(IAND(SFCBPL,LVV).EQ.0) GO TO 570 LVVFR = '2' IF(VV3) LVVFR = '1' LFR = LVVFR 570 CONTINUE C C LOOK AT CEILING HEIGHT... C IF(IAND(SFCBPL,LHT).EQ.0) GO TO 580 IF(ICEILHGT.GT.30) GO TO 580 LHTFR = '2' IF(ICEILHGT.LT.10) LHTFR = '1' 580 CONTINUE IF(LHTFR.LT.LVVFR) LFR = LHTFR IF(LVVFR.EQ.'3' .AND. LHTFR.EQ.'3') LFR = '0' ICNT = ICNT + 1 JVIS(1,ICNT) = ICTR JVIS(2,ICNT) = JCTR JVIS(3,ICNT) = mova2i(LFR) C C.....FOR WRITING OUT STATION DATA TO FILE MFILE. C first, reset char strings to all blanks, then c fill in with values for current station c APLOT = ' ' AZOMT = ' ' IDRLON = 0 IDRLAT = 0 write(aplot(1:1),fmt='(i1)') iplpri write(azomt(1:1),fmt='(i1)') izoomt IDRLON = RLON * 100 IDRLAT = RLAT * 100 c C.....CHECKING TO SEE IF FLAG ON c IF(LPRT.EQ.'R') then if(lchout) print 854,mfile,stname,idrlat,idrlon,lfr 854 format(' writing to file = ',i4,' stname = ',a4, * ' idrlat = ',i6,' idrlon = ',i6,' lfr = ',a1) WRITE(MFILE,586) STNAME,idrlat,idrLON,JCTR,ICTR, 1 LFR,cmetar(36:38),cmetar(33:35),APLOT(1:1),AZOMT(1:1) 586 FORMAT(1X,A4,1X,i5,1x,i5,1X,i5,1x,i5, * 1X,A1,1X,A3,1X,A3,1X,A1,1X,A1) endif C 590 CONTINUE IF(LPRT.NE.'T') GO TO 600 IF(LVVFR.NE.'3' .OR. LHTFR.NE.'3') GO TO 600 CALL PUTLAB(ICTR-8,JCTR+7,HGT04,STNAME,ANG00,3,IPRY1,0) 600 CONTINUE if(lchout) print*,' bottom of 300 loop...i = ',i 300 continue C write(6,'('' in wxpxplot: main loop complete'')') c C.....WRITING END OF MAP FLAG ONTO FILE MFILE...... c IF(LPRT.EQ.'R') WRITE(MFILE,585) MAPEND,idrLAT,idrLON, * JCTR,ICTR,LFR 585 FORMAT(1X,A4,1X,i5,1x,i5,1X,i5,1x,i5,1X,A1) call wrtafs(ihd3,afosout,irtn) if (irtn.ne.0) then write(6,'('' in wxpxplot: wrtafs irtn ='',i8)')irtn endif C 610 CONTINUE lckpnt = 99 if(lchout) PRINT 17,lckpnt ITAG = 999 write(6,'('' in wxpxplot: before putlab: itag = '',i6)') itag CALL PUTLAB(1,1,1.0,IBCD,0.0,1,1,ITAG) write(6,'('' in wxpxplot: after putlab: itag = '',i6)') itag IEXIT = 0 IF(IEXIT.NE.0) GO TO 999 endmsg(1:40) = goodend(17:56) C ILOC = 1 IF(IKEY.EQ.2) ILOC = 57 DO K = IKEY,IENDKY endmss(1:56) = goodend(iloc:iloc+55) CALL CONSOL(ENDMSS) ILOC = ILOC + 56 enddo GO TO 1200 996 CONTINUE PRINT 970 970 FORMAT(' ','ERROR WHILE READING INPUT OF WXPX PARAMETERS.',/) WRITE(MESG(5)(1:45), * FMT='(''ERROR WHILE READING INPUT OF WXPX PARAMETERS.'')') IEXIT = 5 go to 999 997 CONTINUE PRINT 971 971 FORMAT(' ','ERROR...PHYSICAL END OF FILE ENCOUNTERED ON', * ' INPUT OF WXPX PARAMETERS.',/) WRITE(MESG(6)(1:69), * FMT='(''ERROR...PHYSICAL END OF FILE ENCOUNTERED ON INPUT *OF WXPX PARAMETERS.'')') IEXIT = 6 999 CONTINUE ENDMSG = MESG(IEXIT) 1200 WRITE(6,1210) ENDMSG 1210 FORMAT(' END MESSAGE=',A70) print*,' IEXIT = ',iexit CALL W3TAGE('WXPXPLOT') call errexit(IEXIT) CCCCC close(afosout) CCCCC CALL W3TAGE('WXPXPLOT') stop END c********************************************************************* subroutine wxpxdata(idatcunit,imetunit,iyr,imon,iday, * ihour,lchout,irtn) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: WXPXDATA UNPACK SURFACE DATA C PRGMMR: WOBUS ORG: NP2 DATE: 1998-03-04 C C ABSTRACT: WXPXDATA READS IN OBSERVATIONAL METAR DATA AND C saves IT INTO A COMMON block FOR INPUT C INTO GRAPHICS CODES C C PROGRAM HISTORY LOG: C 96-10-03 LARRY SAGER C 97-01-24 RICHARD WOBUS - INCORPORATE IN WX DEPICTION JOB C 97-06-04 RICHARD WOBUS - ZERO OUT ARRAYS BEFORE BUFR CALL C 97-07-09 RICHARD WOBUS - READ BUFR THROUGH TEMPORARY ARRAY, C PROCESS ALL METAR CLOUD LAYERS C 98-02-26 RICHARD WOBUS - CLEAN UP ODE AND DOCUMENTATION c 98-05-26 Chris Caruso - remove cdir$ integer=64 from c top of this program. changing this c from being a separate step for c production of wx depiction charts c to being a subroutine called by c wxpxplot. array containing reports c will be passed in COMMON. c 02-03-25 C. Caruso Magee replace HOCB with new mnemonic HBLCS. c 02-05-07 C. Caruso Magee Split string STR into 2 mnemonics strings c since BULTIM is part of a replicated sequence c with bufrtab.000 now. c 02-05-07 C. Caruso Magee Undo 3/25/02 change. METAR still uses HOCB. c 05-10-11 C. Caruso Magee Increase creps and lenrep arrays from 3000 to c 4000 reports. c 06-06-14 C. Caruso Magee Add CTHUND char string to COMMON. c C USAGE: call wxpxdata(idatcunit,imetunit,iyr,imon,iday,ihour, c lchout,irtn) c c input arguments: c idatcunit - integer logical unit number of control file c imetunit - integer logical unit number of bufr metar data c iyr - integer year read in from script (4 digits) c imon - integer month c iday - integer day c ihour - integer hour c lchout - logical print flag. print is on if true. c c output arguments: c CTHUND - character string array indicating presence of c certain TS strings (via COMMON) c irtn - return code c C INPUT FILES: c fort.12 - input control cards C Fort.13 - BUFR UPPER AIR DATA FILE C C OUTPUT FILES: c none C C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) C UNIQUE: - CONTRL FORSFC C LIBRARY: C BUFR - OPENBF READMG READSB UFBINT C C EXIT STATES: C COND = 0 - SUCCESSFUL RUN C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM C C$$$ C C C WXPXDATA decodes a bufr message containing metar data C and forms the simple graphics format. C integer, parameter :: metar_counts=6000 COMMON/reports/ creps, CTHUND COMMON/numrep/ lenrep,icount CHARACTER*8 INOUT CHARACTER*8 SUBSET CHARACTER*60 STR1 CHARACTER*10 STR2 CHARACTER*5 RAWRPT CHARACTER*5 CATA(48) CHARACTER*20 CATB CHARACTER*1 CBLK CHARACTER*1 CREP(130) CHARACTER*130 CREPS(metar_counts) character*1 orf(8) CHARACTER*1 ORM(40) CHARACTER*1 ORR(400) CHARACTER*400 CRR CHARACTER*6 CTHUNDTMP CHARACTER*6 CTHUND(metar_counts) CHARACTER*1 OBLK data oblk/' '/ equivalence (orf,ifillr) data ifillr /X'4025BA43B7400000'/ C DIMENSION HDR (10) DIMENSION ARR1 (9) DIMENSION ARR2 (1) C REAL ARR (50,11) REAL ARY (10,10) REAL RRR (1,50) EQUIVALENCE (ORR,RRR) REAL RLIMS (4) real rzero data rzero/0./ C INTEGER NRET1 (48) logical lremark C integer idatcunit integer imetunit integer iyr, imon, iday, ihour integer lenrep(metar_counts) logical lchout C DATA CBLK /' '/ DATA STR1/'YEAR RPID CLAT CLON SELV HOUR MINU MNTH DAYS'/ DATA STR2/'BULTIM'/ DATA RAWRPT/'RRSTG'/ DATA CATB /'VSSO CLAM HOCB '/ DATA FMISS /999999./ C save C C CONTRL READS IN THE CONTROL CARDS AND FORMS THE HEADER C RECORD FOR SFCDAT C CALL CONTRL (idatcunit, RLIMS, CATA, INUMP, IRET) IF (IRET .NE. 0) THEN PRINT *,' CONTROL CARDS ARE BAD--JOB STOPPED with code = ',IRET irtn = 102 go to 9999 ENDIF if(lchout) print*,' inump = ',inump ihr = ihour ICOUNT = 0 C----------------------------------------------------------------------| C 1. OPEN THE FILE | C----------------------------------------------------------------------| IRET = 0 LUBFR = imetunit INOUT = 'IN' LUNDX = lubfr CALL OPENBF( LUBFR, INOUT, LUNDX ) iret1 = 0 C----------------------------------------------------------------------| C 3. ADVANCE THE POINTER TO THE NEXT BUFR MESSAGE IN THE FILE | C AND READ THE BUFR MESSAGE INTO AN INTERNAL BUFFER | C----------------------------------------------------------------------| 160 CALL READMG( LUBFR, SUBSET, IDATE, IRET1 ) If( IRET1 .EQ. -1 ) THEN C----------------------------------------------------------------------| C 3a. WE HAVE REACHED THE END-OF-FILE. PRINT THAT FACT AND QUIT C IF LAST UNIT WAS READ. IF WE HAVEN'T READ THRU UNIT 13 YET, C GO TO NEXT INPUT UNIT TO READ. C----------------------------------------------------------------------| PRINT *, ' ' PRINT *, ' Read EOF ' GO TO 9998 ENDIF IF( IRET1 .EQ. 0 ) THEN C----------------------------------------------------------------------| C 3b. WE HAVE READ A BUFR MESSAGE. C 4. READ AND UNPACK THE BUFR MESSAGE | C INITIALIZE IRET2 TO 0 AND READ THIS UNPACKED BUFR MESSAGE | C UNTIL SUBSETS HAVE BEEN READ. | C----------------------------------------------------------------------| IRET2 = 0 170 continue C----------------------------------------------------------------------| c clear previous report, so missing data will show as missing C----------------------------------------------------------------------| do i = 1,10 hdr(i) = 0.0 enddo do i = 1,9 arr1(i) = 0.0 enddo do i = 1,1 arr2(i) = 0.0 enddo do j = 1,11 do i = 1,50 arr(i,j) = 0.0 enddo enddo do i = 1,40 orm(i) = ' ' enddo do i = 1,48 nret1(i) = 0 enddo CTHUNDTMP(1:6) = ' ' CALL READSB (LUBFR, IRET2) if(iret2.eq.0) then C----------------------------------------------------------------------| C 5. ACCESS RELEVANT PARTS OF THE UNPACKED BUFR MESSAGE | C STORE INTO HDR ARRAY FOR PASSING INTO S/R FORSFC. C DATA STR1/'YEAR RPID CLAT CLON SELV HOUR MINU MNTH DAYS'/ C DATA STR2/'BULTIM'/ C----------------------------------------------------------------------| CALL UFBINT (LUBFR, ARR1, 9, 1, NRET, STR1) CALL UFBINT (LUBFR, ARR2, 1, 1, NRET, STR2) HDR(1) = ARR1(1) HDR(3) = ARR1(2) HDR(4) = ARR1(3) HDR(5) = ARR1(4) HDR(6) = ARR1(5) HDR(7) = ARR1(6) HDR(8) = ARR1(7) HDR(9) = ARR1(8) HDR(10) = ARR1(9) HDR(2) = ARR2(1) C----------------------------------------------------------------------| C PROCESS ONLY THOSE REPORTS REQUESTED C----------------------------------------------------------------------| IF((HDR(4) .GT. RLIMS(1)) .OR. (HDR(4) .LT. RLIMS(2))) 1 GO TO 170 IF((HDR(5) .LT. RLIMS(3)) .OR. (HDR(5) .GT. RLIMS(4))) 1 GO TO 170 C----------------------------------------------------------------------| C READ IN THE RAW REPORT C----------------------------------------------------------------------| DO K = 1,50 RRR(1,K) = RZERO enddo CALL UFBINT (LUBFR, RRR, 1, 50, NRRT1, 'RRSTG ') C----------------------------------------------------------------------| C Store ORR array into character string and check for special C thunderstorm characters. If found, store in separate char C string to pass back to wxpxplot. C----------------------------------------------------------------------| DO kk = 1,400 CRR(kk:kk) = ORR(kk) ENDDO print*,' crr = ',crr(1:60) ivctsra = INDEX ( CRR, 'VCTSRA') itsrasn = INDEX ( CRR, 'TSRASN') itssnra = INDEX ( CRR, 'TSSNRA') itsshra = INDEX ( CRR, 'TSSHRA') itsra = INDEX ( CRR, 'TSRA') itssn = INDEX ( CRR, 'TSSN') IF ( ivctsra.ne.0 ) THEN CTHUNDTMP = CRR ( ivctsra:ivctsra+5 ) ELSE IF ( itsrasn.ne.0 ) THEN CTHUNDTMP = CRR ( itsrasn:itsrasn+5 ) ELSE IF ( itssnra.ne.0 ) THEN CTHUNDTMP = CRR ( itssnra:itssnra+5 ) ELSE IF ( itsshra.ne.0 ) THEN CTHUNDTMP = CRR ( itsshra:itshnra+5 ) ELSE IF ( itsra.ne.0 ) THEN CTHUNDTMP = CRR ( itsra:itsra+3 ) ELSE IF ( itssn.ne.0 ) THEN CTHUNDTMP = CRR ( itssn:itssn+3 ) END IF if ( lchout ) + print*,' after setting CTHUNDTMP = ',CTHUNDTMP C----------------------------------------------------------------------| C SCAN FOR REMARKS C----------------------------------------------------------------------| DO K = 1,40 ORM(K) = OBLK enddo lremark = .false. DO K = 1,400 IF (ORR(K) .EQ. 'R') THEN IF (ORR(K+1) .EQ. 'M') THEN IF (ORR(K+2) .EQ. 'K') THEN lremark = .true. DO I = 1,40 ORM(I) = ORR(K+2+I) do l = 0,5 if (orm(i+l) .ne. orf(1+l) ) then go to 2877 endif enddo go to 30 2877 continue enddo GO TO 30 endif endif ELSE if (k .lt. 395) then do l = 0,5 if (orr(k+l) .ne. orf(1+l) ) then go to 2977 endif enddo go to 30 2977 continue endif endif enddo 30 CONTINUE C----------------------------------------------------------------------| C RETRIEVE THE DATA PARAMETERS C----------------------------------------------------------------------| K = 0 J = 0 DO WHILE (K .LT. INUMP) IST = 50 J = J + 1 do i = 1,10 do ii = 1,10 ary(i,ii) = fmiss enddo enddo IF ( CATA(J) .EQ. 'VSSO ' ) THEN CALL UFBINT (LUBFR, ARY, 10, 10, NRET2, CATB) DO I = 1,NRET2 DO II = 1,3 ARR(J+II-1,I) = ARY(II,I) NRET1(J+II-1) = NRET2 enddo enddo J = J + 2 K = K + 3 ELSE CALL UFBINT (LUBFR, ARY, 10, 10, NRET1(J), CATA(J)) IF (NRET1(J) .EQ. 0) then ARR(J,1) = FMISS else do i = 1,10 arr(j,i) = ary(1,i) enddo endif K = K + 1 endif enddo if(lchout) PRINT *,' PRES WX IS ',ARR(9,1) C----------------------------------------------------------------------| c blank out temporary output storage string. put array data c into desired output format and return in crep. C----------------------------------------------------------------------| DO K = 1,130 CREP(K) = CBLK ENDDO CALL FORSFC (HDR, ARR, IHR, NRET1, lremark, ORM, * lchout, CREP, lrep, IRET3) if(lchout) print*,' iret3 from forsfc = ',iret3 IF(IRET3 .EQ. 0) THEN C----------------------------------------------------------------------| C STORE THE REPORT (crep) INTO AN ARRAY. C ALSO STORE CTHUND STRING INTO A CORRESPONDING ARRAY. C----------------------------------------------------------------------| ICOUNT = ICOUNT + 1 CCCCC CCCCC if (icount .gt. metar_counts) then write(6,9001) icount-1 9001 format('***** NON-FATAL ERROR: Number of Metar reports & exceeded - skip the remaining reports',i8) irtn = 8 go to 9998 endif CCCCC CCCCC if(lchout) print*,' icount = ',icount,' lrep = ',lrep DO K = 1,lrep CREPS(icount)(K:K) = CREP(K) enddo CTHUND(icount)(1:6) = CTHUNDTMP(1:6) if(lchout) print 558,creps(icount)(1:65) 558 format(' creps1 = ',a65) if(lchout) print 559,creps(icount)(66:130) 559 format(' creps2 = ',a65) lenrep(icount) = lrep ENDIF endif if(iret2.eq.0) go to 170 endif go to 160 9998 continue CCCC if ( irtn .eq. 8) then PRINT 1003,ICOUNT-1 write(97,'('' ***** NON-FATAL ERROR in WXPXPLOT: * Number of Metar reports exceeded & return code * are='',2i5)')metar_counts,irtn else PRINT 1003,ICOUNT endif CCCC 1003 FORMAT(i8,' STATIONS SAVED to CREPS') if (icount.eq.0) then print *,' in WXPXDATA: error exit 41, no stations written' irtn = 41 go to 9999 endif C----------------------------------------------------------------------| C 3a. WE HAVE REACHED THE END-OF-FILE. PRINT THAT FACT AND RETURN | C----------------------------------------------------------------------| C PRINT *, ' ' PRINT *, ' NORMAL END OF WXPXDATA EXECUTED' 9999 continue return END c*********************************************************************** SUBROUTINE CONTRL (idatcunit, RLIMS, CATBA, INUMP, IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: CONTRL READ PROGRAM CONTROL CARDS C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: CONTRL READS THE PROGRAM CONTROL CARD FILE FOR THE C REGION TO DUMP, PARAMETERS TO PROCESS AND MANDATORY C LEVELS TO PROCESS. C C PROGRAM HISTORY LOG: C 96-09-17 LARRY SAGER C 97-01-24 RICHARD WOBUS - INCORPORATE IN WX DEPICTION JOB c 98-05-26 Chris Caruso - remove cdir$ integer=64 from c top of this program C C USAGE: CALL CONTRL (RLIMS, CATBA, INUMP, IRET) C INPUT ARGUMENT LIST: c idatcunit- integer logical unit number of control file C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C RLIMS - GEOGRAPHIC LIMITS TO DUMP C CATBA - MNEMONICS TO DUMP C INUMP - NUMBER OF MNEMONICS TO DUMP C IRET - RETURN CODE C C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) C FT05F001 - CONTROL CARD FILE C C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM C C$$$ CHARACTER*8 CFLN CHARACTER*8 CTEMP CHARACTER*5 CATBA(48) integer idatcunit C REAL RLIMS(4) C save C C READ IN THE FIRST CONTROL CARD: FILE TYPE C IRET = 0 READ(idatcunit,100,END=80) CFLN 100 FORMAT(A8) C C READ IN THE SECOND C.C.: LAT/LON AREA TO PROCESS C 1- MOST N LAT 2- MOST S LAT 3- MOST W LON 4- MOST E LON C READ(idatcunit,102,END=80) RLIMS 102 FORMAT(4F6.0) C PRINT 103, RLIMS 103 FORMAT(' AREA TO PROCESS: ',4F10.0) C C READ IN THE BUFR PARAMETERS TO PROCESS C K = 0 IPAR = 1 DO WHILE (K .EQ. 0) READ(idatcunit,104) CTEMP 104 FORMAT(A8) IF (CTEMP .EQ. '********') THEN K = 1 IPAR = IPAR - 1 ELSE CATBA (IPAR) = CTEMP IPAR = IPAR + 1 ENDIF ENDDO IF ( IPAR .EQ. 0 ) THEN PRINT *,' NO BUFR PARAMETERS FOUND-JOB STOPPED' IRET = -1 RETURN ENDIF C C STORE THE START OF DATA POINTER C INUMP = IPAR RETURN C C ERROR -- END OF FILE ENCOUNTERED WHERE DATA CARD C SHOULD HAVE BEEN. C 80 PRINT *,' ERROR READING CONTROL CARDS' IRET = -1 RETURN END c********************************************************************* SUBROUTINE FORSFC (HDR, ARR, IHR, NRET, lremark, * ORM, lchout, OREP, lenrep, IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FORSFC FORM THE GRAPHICS FORMAT. C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: FORSFC TAKES UNPACKED BUFR FORMAT AND CONVERTS IT C INTO A SIMPLE FORMAT FOR USE IN GRAPHICS PROGRAMS. C C PROGRAM HISTORY LOG: C 96-09-17 LARRY SAGER C 97-01-24 RICHARD WOBUS - INCORPORATE IN WX DEPICTION JOB c 98-05-26 Chris Caruso - remove cdir$ integer=64 from c top of this program c C USAGE: CALL FORSFC (HDR, ARR, ihr, NRET, lremark, c * orm, lchout, orep, lenrep, IRET) C INPUT ARGUMENT LIST: C HDR - UNPACKED BUFR HEADING INFORMATION (ID, LAT/LON ...) C ARR - UNPACKED BUFR METAR REPORTS c ihr - 2 digit hour to determine whether to save max temp or c min temp into orep C NRET - NUMBER OF REPEATS FOR EACH PARAMETER c lremark - logical. if true, found remarks, so they will be included. c orm - remarks section of metar report c lchout - logical. if true, print is on. C C OUTPUT ARGUMENT LIST: c orep - character array containing needed metar info c lenrep - length of orep C IRET - RETURN CODE C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM C C$$$ C C THIS SUBROUTINE CONVERTS THE BUFR DATA AND STORES INTO C A FORMATED ARRAY. C REAL ARR(50,11) real rtemp real rlat, rlon C CHARACTER*8 CTEMP character*2 clam character*5 chocb C CHARACTER*1 OREP(130) CHARACTER*1 OTEMP(8) CHARACTER*1 ORM(40) CHARACTER*1 OZERO data ozero/'0'/ logical lremark logical lchout C integer ilat, ilon integer lenrep INTEGER NRET (*) DIMENSION HDR (10) C EQUIVALENCE (OTEMP,RTEMP) C save C----------------------------------------------------------------------| C START BY INITIALIZING THE OUTPUT ARRAY TO BLANKS | C----------------------------------------------------------------------| do k = 1,130 orep(k) = ' ' enddo clam(1:2) = ' ' chocb(1:5) = ' ' IRET = 0 C C STORE THE STATION ID C RTEMP = HDR(3) DO K = 1,4 OREP(K) = OTEMP(K) enddo C C STORE ELEVATION, LATITUDE AND LONGITUDE C IELV = HDR(6) IF (IELV .GT. 999998) THEN ctemp(1:4) = '9999' ELSE if(ielv.ge.0) then if(ielv.lt.10) then ctemp(1:3) = '000' write(ctemp(4:4),fmt='(i1)') ielv elseif(ielv.lt.100) then ctemp(1:2) = '00' write(ctemp(3:4),fmt='(i2)') ielv elseif(ielv.lt.1000) then ctemp(1:1) = '0' write(ctemp(2:4),fmt='(i3)') ielv else write(ctemp(1:4),fmt='(i4)') ielv endif elseif(ielv.lt.0) then if(ielv.gt.-10) then ctemp(1:3) = '-00' jelv = abs(ielv) write(ctemp(4:4),fmt='(i1)') jelv elseif(ielv.gt.-100) then ctemp(1:2) = '-0' jelv = abs(ielv) write(ctemp(3:4),fmt='(i2)') jelv else !elev le -100 ctemp(1:1) = '-' jelv = abs(ielv) write(ctemp(2:4),fmt='(i3)') jelv endif endif endif DO K = 1,4 OREP(K+4) = CTEMP(K:K) enddo IF (HDR(4) .GT. 999998.) THEN ctemp(1:5) = '99999' ELSE IF (HDR(4) .LT. 0) then ctemp(5:5) = 'S' else ctemp(5:5) = 'N' endif rlat = 100. * hdr(4) ILAT = nint(rlat) if(ilat.lt.1000) then ctemp(1:1) = '0' write(ctemp(2:4),fmt='(i3)') ilat else write(ctemp(1:4),fmt='(i4)') ilat endif endif do k = 1,5 orep(K+8) = ctemp(k:k) enddo IF (HDR(5) .GT. 999998.) THEN ctemp(1:6) = '999999' ELSE c c change long to be positive for all cases with c E or W indicating hemisphere. c IF (HDR(5) .GT. 0) then ctemp(6:6) = 'E' else ctemp(6:6) = 'W' hdr(5) = -hdr(5) endif rlon = 100. * hdr(5) ilon = nint(rlon) if(ilon.lt.10000) then ctemp(1:1) = '0' write(ctemp(2:5),fmt='(i4)') ilon else write(ctemp(1:5),fmt='(i5)') ilon endif endif do k = 1,6 orep(k+13) = ctemp(k:k) enddo C C HOUR AND MINUTE OF OBSERVATION C Itime = HDR(7)*100. + HDR(8) if(itime.lt.10) then ctemp(1:3) = '000' write(ctemp(4:4),fmt='(i1)') iTIME elseif(itime.lt.100) then ctemp(1:2) = '00' write(ctemp(3:4),fmt='(i2)') iTIME elseif(itime.lt.1000) then ctemp(1:1) = '0' write(ctemp(2:4),fmt='(i3)') iTIME else write(ctemp(1:4),fmt='(i4)') iTIME endif IF((CTEMP(3:3) .EQ. '2') .OR. * (CTEMP(3:3) .EQ. '3')) THEN if ( lchout ) print*,' invalid obs time for wxdep' IRET = 1 RETURN endif DO K = 1,4 OREP(K+19) = CTEMP(K:K) enddo C C MONTH AND DAY C ITime = HDR(9)*100. + HDR(10) if(itime.lt.1000) then ctemp(1:1) = '0' WRITE(CTEMP(2:4),FMT='(I3)') ITIME else WRITE(CTEMP(1:4),FMT='(I4)') ITIME endif DO K = 1,4 OREP(K+23) = CTEMP(K:K) enddo if(lchout) then print 668,arr(1,1),arr(2,1),arr(3,1),arr(4,1) print 669,arr(5,1),arr(6,1),arr(7,1),arr(8,1) print 670,arr(9,1),arr(10,1),arr(11,1),arr(12,1) print 671,arr(13,1) endif 668 format(' arr1 = ',f10.2,' arr2 = ',f10.2,' arr3 = ',f10.2, * ' arr4 = ',f10.2) 669 format(' arr5 = ',f10.2,' arr6 = ',f10.2,' arr7 = ',f10.2, * ' arr8 = ',f10.2) 670 format(' arr9 = ',f10.2,' arr10 = ',f10.2, * ' arr11 = ',f10.2,' arr12 = ',f10.2) 671 format(' arr13 = ',f10.2) C C STORE THE DATA INTO THE OUTPUT ARRAY. C START WITH MEAN SEA LEVEL PRESSURE C IF (ARR(1,1) .LT. 999998.) THEN IARR = nint(ARR(1,1)/10.) if(lchout) print*,' slp = ',iarr if(iarr.lt.10000) then ctemp(1:1) = '0' write(ctemp(2:5),fmt='(i4)') iarr else WRITE(CTEMP(1:5),FMT='(I5)') IARR endif else ctemp(1:5) = '99999' endif do k = 1,5 OREP(k+27) = CTEMP(k:k) enddo C C WIND DIRECTION AND SPEED C IF (ARR(2,1) .LT. 999998.) THEN IF (ARR(3,1) .LT. 999998.) THEN IARR = nint(ARR(2,1)) if(iarr.lt.10) then ctemp(1:2) = '00' WRITE(CTEMP(3:3),FMT='(I1)') IARR elseif(iarr.lt.100) then ctemp(1:1) = '0' WRITE(CTEMP(2:3),FMT='(I2)') IARR else WRITE(CTEMP(1:3),FMT='(I3)') IARR endif do k = 1,3 OREP(k+32) = CTEMP(k:k) enddo IARR = nint(ARR(3,1) * 1.9425) if(lchout) print*,' wind spd = ',iarr if(iarr.lt.10) then ctemp(1:2) = '00' WRITE(CTEMP(3:3),FMT='(I1)') IARR elseif(iarr.lt.100) then ctemp(1:1) = '0' WRITE(CTEMP(2:3),FMT='(I2)') IARR else WRITE(CTEMP(1:3),FMT='(I3)') IARR endif do k = 1,3 OREP(k+35) = CTEMP(k:k) enddo else ctemp(1:6) = '999999' do k = 1,6 OREP(k+32) = CTEMP(k:k) enddo endif else ctemp(1:6) = '999999' do k = 1,6 OREP(k+32) = CTEMP(k:k) enddo endif C C TEMPERATURE, DEW POINT, MAX/MIN C IF (ARR(4,1).LT.999998.) THEN TEMP = ARR(4,1) - 273.16 IARR = nint(1.8 * TEMP + 32.) if(lchout) print*,' temp = ',iarr if(iarr.ge.0) then if(iarr.lt.10) then ctemp(1:3) = '000' WRITE(CTEMP(4:4),FMT='(I1)') IARR elseif(iarr.lt.100) then ctemp(1:2) = '00' WRITE(CTEMP(3:4),FMT='(I2)') IARR else ctemp(1:1) = '0' WRITE(CTEMP(2:4),FMT='(I3)') IARR endif else ctemp(1:1) = '-' if(iarr.gt.-10) then ctemp(2:3) = '00' WRITE(CTEMP(4:4),FMT='(I1)') IARR else ctemp(2:2) = '0' WRITE(CTEMP(3:4),FMT='(I2)') IARR endif endif do k = 1,4 orep(k+38) = ctemp(k:k) enddo c c dew point c IF (ARR(5,1).LT.999998.) THEN TEMP = ARR(5,1) - 273.16 IARR = nint(1.8 * TEMP + 32.) if(lchout) print*,' dew pt. temp = ',iarr if(iarr.ge.0) then if(iarr.lt.10) then ctemp(1:3) = '000' WRITE(CTEMP(4:4),FMT='(I1)') IARR elseif(iarr.lt.100) then ctemp(1:2) = '00' WRITE(CTEMP(3:4),FMT='(I2)') IARR else ctemp(1:1) = '0' WRITE(CTEMP(2:4),FMT='(I3)') IARR endif else ctemp(1:1) = '-' if(iarr.gt.-10) then ctemp(2:3) = '00' WRITE(CTEMP(4:4),FMT='(I1)') IARR else ctemp(2:2) = '0' WRITE(CTEMP(3:4),FMT='(I2)') IARR endif endif do k = 1,4 orep(k+42) = ctemp(k:k) enddo else do k = 1,4 orep(k+42) = '9' enddo endif else do k = 1,8 orep(k+38) = '9' enddo endif c c max temp. c IF (ARR(6,1).LT.999998.) THEN TEMP = ARR(6,1) - 273.16 IARR = nint(1.8 * TEMP + 32.) if(lchout) print*,' max. temp = ',iarr if(iarr.ge.0) then if(iarr.lt.10) then ctemp(1:3) = '000' WRITE(CTEMP(4:4),FMT='(I1)') IARR elseif(iarr.lt.100) then ctemp(1:2) = '00' WRITE(CTEMP(3:4),FMT='(I2)') IARR else ctemp(1:1) = '0' WRITE(CTEMP(2:4),FMT='(I3)') IARR endif else ctemp(1:1) = '-' if(iarr.gt.-10) then ctemp(2:3) = '00' WRITE(CTEMP(4:4),FMT='(I1)') IARR else ctemp(2:2) = '0' WRITE(CTEMP(3:4),FMT='(I2)') IARR endif endif do k = 1,4 orep(k+46) = ctemp(k:k) enddo else do k = 1,4 orep(k+46) = '9' enddo endif c c min temp. c IF (ARR(7,1).LT.999998.) THEN TEMP = ARR(7,1) - 273.16 IARR = nint(1.8 * TEMP + 32) if(lchout) print*,' min. temp = ',iarr if(iarr.ge.0) then if(iarr.lt.10) then ctemp(1:3) = '000' WRITE(CTEMP(4:4),FMT='(I1)') IARR elseif(iarr.lt.100) then ctemp(1:2) = '00' WRITE(CTEMP(3:4),FMT='(I2)') IARR else ctemp(1:1) = '0' WRITE(CTEMP(2:4),FMT='(I3)') IARR endif else ctemp(1:1) = '-' if(iarr.gt.-10) then ctemp(2:3) = '00' WRITE(CTEMP(4:4),FMT='(I1)') IARR else ctemp(2:2) = '0' WRITE(CTEMP(3:4),FMT='(I2)') IARR endif endif IF((IHR .GE. 6) .AND. (IHR .LT. 15)) THEN do k = 1,4 orep(k+46) = ctemp(k:k) enddo endif else IF((IHR .GE. 6) .AND. (IHR .LT. 15)) THEN do k = 1,4 orep(k+46) = '9' enddo endif endif C C HORIZONTAL VISIBILITY C if(lchout) PRINT *,' VIS IS ',ARR(8,1) IF(ARR(8,1).LT.999998.) THEN iarr = nint(arr(8,1)) !HOVI in meters if(iarr.lt.10) then ctemp(1:4) = '0000' write(ctemp(5:5),fmt='(i1)') iarr elseif(iarr.lt.100) then ctemp(1:3) = '000' write(ctemp(4:5),fmt='(i2)') iarr elseif(iarr.lt.1000) then ctemp(1:2) = '00' write(ctemp(3:5),fmt='(i3)') iarr elseif(iarr.lt.10000) then ctemp(1:1) = '0' write(ctemp(2:5),fmt='(i4)') iarr else write(ctemp(1:5),fmt='(i5)') iarr endif else ctemp(1:5) = '99999' endif do k = 1,5 orep(k+50) = ctemp(k:k) enddo c IARR = nint(ARR(8,1) * .06215) C C PRESENT WEATHER C IF(ARR(9,1).LT.999998.) THEN IARR = nint(ARR(9,1)) if(iarr.lt.10) then ctemp(1:2) = '00' write(ctemp(3:3),fmt='(i1)') iarr elseif(iarr.lt.100) then ctemp(1:1) = '0' write(ctemp(2:3),fmt='(i2)') iarr else write(ctemp(1:3),fmt='(i3)') iarr endif else ctemp(1:3) = '999' endif do k = 1,3 orep(k+55) = ctemp(k:k) enddo C C FRACTION OF THE CELESTIAL DOME C if(lchout) print*,' checking cloud amount (clam)' if(lchout) print 239, nret(11),arr(11,1) 239 FORMAT(' VALUE OF N ',I6,' parameter ',f10.1) iarrc = 2 ISD = 60 if(nret(11).gt.3) then inret = 3 else inret = nret(11) endif write(ctemp(1:1),fmt='(i1)') inret orep(59) = ctemp(1:1) IF(NRET(11) .NE. 0 ) THEN ncsave = 0 c c look for up to 3 layers marked as significant c DO KK = 1,NRET(11) if(arr(11,kk).gt.999999..or.(arr(11,kk).gt.0..and. * arr(12,kk).gt.999999.)) then if(lchout) then print*,' non 0 arr11 with too high arr12' print 954,orep(1),orep(2),orep(3),orep(4),arr(11,kk), * arr(12,kk) 954 format(' station = ',4a1,' clam = ',f10.2, * ' hocb = ',f10.2) print*,' isd = ',isd endif if(ncsave.lt.3) then do k = 0,6 orep(isd+k) = '9' enddo ncsave = ncsave + 1 isd = isd + 7 endif else if (arr(10,kk) .lt. 4.5) then IARR = nint(ARR(11,KK)) if(iarr.eq.0) then iarrco = iarrc iarrc = iarr elseif(iarr.gt.0) then IF (IARR .EQ. 11) IARR = 3 IF (IARR .EQ. 12) IARR = 6 IF (IARR .EQ. 13) IARR = 2 IF(IARR .LT. 99) THEN if(lchout) then print*,' new clam = ',iarr,' for nret = ',kk print*,' previous clam was ',iarrc endif iarrco = iarrc iarrc = iarr if(iarr.lt.10) then ctemp(1:1) = '0' WRITE(CTEMP(2:2),FMT='(I1)') IARR else WRITE(CTEMP(1:2),FMT='(I2)') IARR endif clam(1:2) = CTEMP(1:2) !CLAM iarr = nint(arr(12,kk)) !HOCB in meters if(lchout) print*,' new hocb = ',iarr, * ' for nret = ',kk if(iarr.lt.10) then ctemp(1:4) = '0000' WRITE(CTEMP(5:5),FMT='(I1)') IARR elseif(iarr.lt.100) then ctemp(1:3) = '000' WRITE(CTEMP(4:5),FMT='(I2)') IARR elseif(iarr.lt.1000) then ctemp(1:2) = '00' WRITE(CTEMP(3:5),FMT='(I3)') IARR elseif(iarr.lt.10000) then ctemp(1:1) = '0' WRITE(CTEMP(2:5),FMT='(I4)') IARR else WRITE(CTEMP(1:5),FMT='(I5)') IARR endif chocb(1:5) = CTEMP(1:5) endif endif c c save only layers significant to the weather depiction c to allow 3 layers + cb layers to be processed. c When a layer cover is few, c overwrite this layer if another level with higher clam is present. c Don't overwrite a level if next level is a repeat. c Don't overwrite if existing level is gt 2 and next level is c higher clam than existing level c if (ncsave.lt.3) then if (kk.eq.1) then !1st time thru loop if(iarrc.le.2) then if(iarrc.gt.0) then OREP(ISD) = clam(1:1) !clam orep(isd+1) = CLAM(2:2) !CLAM do i = 1,5 OREP(ISD+1+i) = Chocb(i:i) !hocb enddo elseif(iarrc.eq.0) then if(lchout) print*,' found clear sky' OREP(ISD) = ' ' OREP(ISD+1) = ' ' OREP(ISD+2) = 'C' OREP(ISD+3) = 'L' OREP(ISD+4) = 'E' OREP(ISD+5) = 'A' OREP(ISD+6) = 'R' endif c if(nret(11).eq.1) isd = isd + 7 ncsave = ncsave + 1 isd = isd + 7 elseif(iarrc.gt.2) then !increment isd position OREP(ISD) = clam(1:1) !clam orep(isd+1) = CLAM(2:2) !CLAM do i = 1,5 OREP(ISD+1+i) = Chocb(i:i) !hocb enddo ncsave = ncsave + 1 ISD = ISD + 7 endif elseif(kk.gt.1) then if(iarrc.gt.iarrco) then if(iarrco.le.2) then ncsave = ncsave - 1 isd = isd - 7 endif OREP(ISD) = clam(1:1) !clam orep(isd+1) = CLAM(2:2) !CLAM do i = 1,5 OREP(ISD+1+i) = Chocb(i:i) !hocb enddo ncsave = ncsave + 1 ISD = ISD + 7 endif endif endif else if(lchout) print*,' vsso gt 4.5... isd = ',isd do k = 0,6 orep(isd+k) = '9' enddo if (ncsave.lt.3) then ncsave = ncsave + 1 ISD = ISD + 7 endif endif endif enddo icnt = isd else do k = 0,6 orep(isd+k) = '9' enddo icnt = isd + 7 endif if(lchout) print*,' after clouds...icnt = ',icnt c c check value of icnt to determine how many cloud levels/hocb's c we just wrote out. c if(icnt.eq.60) then orep(59) = '0' elseif(icnt.eq.67) then orep(59) = '1' elseif(icnt.eq.74) then orep(59) = '2' elseif(icnt.eq.81) then orep(59) = '3' endif C C ALTIMETER SETTING C IF (ARR(13,1).LT.999998.) THEN IARR = nint(ARR(13,1) * 0.029530201) if(iarr.lt.10) then ctemp(1:3) = '000' WRITE(CTEMP(4:4),FMT='(I1)') IARR elseif(iarr.lt.100) then ctemp(1:2) = '00' WRITE(CTEMP(3:4),FMT='(I2)') IARR elseif(iarr.lt.1000) then ctemp(1:1) = '0' WRITE(CTEMP(2:4),FMT='(I3)') IARR else WRITE(CTEMP(1:4),FMT='(I4)') IARR endif else ctemp(1:4) = '9999' endif do k = 1,4 orep(icnt+k-1) = ctemp(k:k) enddo icnt = icnt + 4 if(lchout) print*,' after alse...icnt = ',icnt C C FINALLY, COPY IN THE REMARKS C if(lchout) print*,' lremark = ',lremark if(lremark) then DO K = 1,37 OREP(icnt+k-1) = ORM(K) enddo icnt = icnt + k endif lenrep = icnt if(lchout) print*,' in forsfc...lenrep = ',lenrep if(lchout) print 778,orep 778 format(' orep = ',130a1) 50 CONTINUE RETURN END