SUBROUTINE MT_DCOD ( curtim, stntbl, bufrtb, nhours, iret ) C************************************************************************ C* MT_DCOD * C* * C* This routine will read METAR/SPECI OR SAO bulletins from standard * C* input, decode the bulletin report data, and create BUFR output. * C* * C* MT_DCOD ( CURTIM, STNTBL, BUFRTB, NHOURS, IRET ) * C* * C* Input parameters: * C* CURTIM CHAR* Current time for input data * C* STNTBL CHAR* Metar world station table * C* BUFRTB CHAR* BUFR table * C* NHOURS INTEGER Number hours before system time * C* * C* Output parameters: * C* RIVALS(IRCORN) REAL Report correction indicator * C* RIVALS(IRSLAT) REAL Report latitude * C* RIVALS(IRSLON) REAL Report longitude * C* RIVALS(IRSELV) REAL Report elevation * C* CIVALS(ICSTID) CHAR* SAO station id * C* IRET INTEGER Return code * C* 0; Normal return * C* * C** * C* Log: * C* D. Kidwell/NCEP 1/96 * C* D. Kidwell/NCEP 2/96 Added METAR weather codes, hourly prec, * C* correction flag check and NCO flag * C* D. Kidwell/NCEP 3/96 Integrated DC_WLOG calls * C* D. Kidwell/NCEP 4/96 Cleaned up code; renamed from DCMDCD * C* D. Kidwell/NCEP 5/96 Modified cloud processing; added BUFR * C* K. Tyle/GSC 11/96 Added SAO decoding; write SPECI's * C* K. Tyle/GSC 1/97 Use new packing table vars; decode AFOS * C* bulletins; change calls to DC_WLOG; MT_RTIM* C* -> RA_RTIM; remove BUFR-related conditional* C* compilation; remove call to IN_BDTA; * C* MT_TMST -> RA_TMST * C* K. Tyle/GSC 2/97 Changed error processing * C* K. Tyle/GSC 4/97 Cleaned up; changed logging and SPECI write* C* R. Hollern/NCEP 9/97 Added the STNTB1 parameter and logic * C* D. Kidwell/NCEP 6/97 ST_LSTR -> INDEX; use explicit char length * C* D. Kidwell/NCEP 4/98 Removed bufr/nco references; new interface;* C* removed iasos flag; cleaned up; added vrsn * C* R. Hollern/NCEP 6/98 Added new interface, removed GEMPAK calls, * C* and added new BUFR routines. * C* R. Hollern/NCEP 8/98 Defined countr variable * C* R. Hollern/NCEP 10/98 Write bulletin header to LOG file * C* R. Hollern/NCEP 1/99 Added interface mnemonic arrays to call * C* sequences * C* R. Hollern/NCEP 3/99 Set the automatic station flag for SAO's * C* to 0.0 to indicate automatic station * C* R. Hollern/NCEP 5/99 Added saoflg to MT_BUFD calling sequence * C* R. Hollern/NCEP 4/00 Stopped writing version number to log file * C* C. C. Magee/NCEP 06/00 Modify to use rivals instead of irptdt * C* array for date/time handling. Changed * C* irhour to irephr and irmin to irepmin to * C* avoid conflict with rivals. * C* C. C. Magee/NCEP 08/00 Moved LOG prints from MT_IFPT into here. * C* Also removed 2 input args from MT_IFPT (no * C* longer needed as input since LOG prints * C* were moved to this routine). * C* C. C. Magee/NCEP 05/01 Deleted code which removed 1st char from * C* station id prior to call to mtstbd.f. This* C* code was left over from previous version of* C* this subroutine and was no longer used. * C* C. Caruso Magee/NCEP 06/01 Replace calls to STATUS, WRITSA, and * C* DBN_BUFR with new s/r UT_WBFR. * C* C. Caruso Magee/NCEP 02/02 Rename oristn to cborg; bultim to btime; * C* lunbfr to iunbfo; MT_BUFA to MT_BUFR; * C* mtbufr.cmn to mtcmn_bufr.cmn. Replace * C* int array irctm with real array rctim. * C* C. Caruso Magee/NCEP 02/02 Rename wmohdr to buhd. * C* J. Ator/NCEP 08/04 SS_GTIM -> CSS_GTIM * C* C. Caruso Magee/NCEP 10/05 Remove logical usrpt (obsolete). Add * C* corflg to calling sequence for MT_GRPT. * C* C. Caruso Magee/NCEP 09/06 Add corflg to calling sequence for * C* MT_SHDR and add missing code to store * C* corflg into rivals elsewhere. * C* J. Ator/NCEP 09/16 Correct spurious "AUTO M " in reports. * C************************************************************************ C C* If successful, stores seqnum, buhd, cborg, btime, bbb C* and rctim (1) - (6) in COMMON /outrec/ C INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'mtcmn.cmn' INCLUDE 'mtcmn_bufr.cmn' C CHARACTER*(*) curtim, stntbl, bufrtb C* CHARACTER bultin*(DCMXBF), report*(DCMXBF), + sysdt*12, dattmp*12, errstr*80, + dattim*15, rpttyp*4, stid*8, bultyp*4, stnm*8, + autop*4, countr*4, + tmstr*4, coun*2, strnew*80, cmdif*8, + rimnem (NRIMN)*8, cimnem( NCIMN )*8 INTEGER istarr (5) LOGICAL more, good, corflg, last, + corbul, badtim, specl, saoflg, ibufr C* C----------------------------------------------------------------------- iret = 0 C C* Open the station table file. C CALL FL_TBOP ( stntbl, 'stns', lunstb, ier ) IF ( ier .ne. 0 ) THEN errstr = 'NOT ABLE TO OPEN STATION TABLE FILE' CALL DC_WLOG ( 0, 'DCMETR', 2, errstr(1:35), ierr ) CALL DC_WLOG ( 0, 'FL', ier, stntbl, ierr ) RETURN END IF C C* Read the World Metar Station Table. C CALL MT_STBL ( lunstb, kret ) C C* Set the pointers for the interface arrays. C CALL MT_IFSP ( rimnem, cimnem, ier ) IF ( ier .ne. 0 ) THEN CALL DC_WLOG ( 0, 'DCMETR', -8, ' ', ierr ) RETURN END IF C C* Loop until a timeout occurs. C ibufr = .false. last = .false. C DO WHILE ( .true. ) C C* Get the bulletin. C CALL DC_GBUL ( bultin, lenbul, ifdtyp, iperr ) IF ( iperr .ne. 0 ) THEN C C* A time-out occurred while waiting for a new bulletin C* on the input pipe. Shut down the decoder and exit. C CALL DC_WLOG ( 0, 'DC', iperr, ' ', iret ) C C* Close BUFR files. C IF ( ibufr ) THEN last = .true. CALL MT_BUFR( bufrtb, saoflg, last, report, + lenr, jret ) END IF C RETURN END IF C C* Decode the header information from this bulletin. C more = .true. C IF ( ifdtyp .eq. 0 ) THEN CALL DC_GHDR ( bultin ( :lenbul ), lenbul, seqnum, + buhd, cborg, btime, bbb, nchar, ierr ) C IF ( ierr .ne. 0 ) THEN CALL DC_WLOG ( 2, 'DC', ierr, ' ', ier ) CALL ST_UNPR ( bultin(:72), 72, errstr, len1, + ier ) CALL DC_WLOG ( 2, 'DCMETR', 2, errstr, ier ) more = .false. ELSE C C* Write bulletin header to the log file. C isz = MIN ( 39, lenbul ) CALL ST_UNPR ( bultin(:isz), isz, errstr, len1, + ier ) CALL DC_WLOG ( 2, 'DCMETR', 2, errstr, ier ) END IF END IF C coun = buhd (3:4) C C* Check for a correction as part of bulletin header. C IF ( bbb ( 1:1 ) .eq. 'C' ) THEN corbul = .true. ELSE corbul = .false. END IF C C* Set pointer to skip over header. C CALL ST_UNPR (bultin(:nchar), nchar, strnew, ibpnt, ier) C C* Get the system time, and make a standard GEMPAK time C* from the "current" time. C itype = 1 CALL CSS_GTIM ( itype, sysdt, ier ) C IF ( curtim .eq. 'SYSTEM' ) THEN dattmp = sysdt ELSE CALL TI_STAN ( curtim, sysdt, dattmp, ier ) END IF C CALL TI_CTOI ( dattmp, istarr, ier ) C C* Save receipt time in common. C* Set receipt time significance to 0. C rctim ( 1 ) = 0.0 DO i = 1, 5 rctim ( i + 1 ) = FLOAT ( istarr ( i ) ) END DO C C* Check for header of form METAR, SPECI, or MTR. C IF ( ( nchar + 6 ) .gt. lenbul ) THEN more = .false. END IF IF ( more ) THEN CALL MT_FIND ( bultin ( :lenbul ), nchar, ibpnt, + bultyp, mhr, mmin, iret ) IF ( iret .lt. 0 ) more = .false. END IF C C* Remove control characters from entire bulletin. C CALL ST_UNPR ( bultin ( :lenbul ), lenbul, + bultin ( :lenbul ), lenb, iret ) C DO WHILE ( more ) C C* Get next report. C CALL MT_GRPT ( bultin ( :lenb), lenb, bultyp, ibpnt, + rpttyp, report ( :lenb), lenr, + corflg, iret ) C IF ( iret .ne. -2 ) THEN C C* Write report to the log. C isz = MIN ( 50, lenr ) CALL DC_WLOG ( 2, 'DCMETR', 2, report(1:isz), ier ) END IF C irpntr = 1 good = .true. IF ( .not. corflg ) corflg = corbul IF ( corflg ) rivals ( ircorn ) = 1. C C* Check for SAO format. C IF ( rpttyp .eq. 'SA' ) THEN saoflg = .true. specl = .false. ELSE IF ( rpttyp .eq. 'SX' ) THEN saoflg = .true. specl = .true. ELSE saoflg = .false. specl = .false. END IF C IF ( iret .ne. 0 ) THEN good = .false. IF ( iret .eq. -2 ) THEN C C* There are no more reports in this bulletin. C C* Make sure that all BUFR output for this C* bulletin has been written out before going C* back to DC_GBUL and waiting for a new C* bulletin on the input pipe. C IF ( ibufr ) THEN C CALL UT_WBFR ( iunbfo, 'metar', + 1, ierwbf ) C END IF C more = .false. ELSE IF ( iret .eq. -1 ) THEN CALL DC_WLOG ( 4, 'DCMETR', 5, + report(:lenr), ier ) END IF ELSE C C* Check for spurious visibility as "AUTO M ", and C* if found correct to "AUTO / ". C iautom = INDEX ( report(1:lenr), 'AUTO M ' ) IF ( iautom .ne. 0 ) THEN report( iautom : iautom+6 ) = 'AUTO / ' END IF C C* Check for SAO's. C IF ( saoflg ) THEN CALL RA_GFLD ( report ( :lenr), lenr, iret ) IF ( iret .eq. 0 ) THEN CALL RA_RHDR ( irpntr, stnm, rpttyp, + corflg, autop, irephr, + irepmin, iret ) stid = stnm C C* Make Canadian SA ID be 4 characters. C IF ( stid(4:4) .eq. ' ' ) THEN IF ( cborg(1:2) .eq. 'CW' ) THEN stid(4:4) = stid(3:3) stid(3:3) = stid(2:2) stid(2:2) = stid(1:1) stid(1:1) = 'C' ELSE C C* Skip report. C iret = -1 END IF END IF civals ( icstid ) = stid IF ( corflg ) rivals ( ircorn ) = 1. END IF IF ( iret .ne. 0 ) good = .false. ELSE C C* This is METAR format. Get the report time. C CALL MT_SHDR ( report ( :lenr), irpntr, + irday, ihour, iminit, + corflg, iret ) irephr = ihour irepmin = iminit IF ( corflg ) rivals ( ircorn ) = 1. END IF END IF C C* Get the time to assign to this bulletin. C IF ( good ) THEN C C* Get observation time. C IF ( .not. saoflg ) THEN C C* Some METAR reports only have the C* bulletin time, and no report time. C IF ( irephr .lt. 0 ) THEN tmstr = btime(3:4) CALL ST_NUMB ( tmstr, irephr, ier ) END IF IF ( irepmin .lt. 0 ) THEN tmstr = btime(5:6) CALL ST_NUMB ( tmstr, irepmin, ier ) END IF END IF CALL RA_RTIM ( istarr, btime, irephr, + irepmin, irtarr, dattim, ier1 ) ihhmm = irephr * 100 + irepmin IF ( ier1 .ne. 0 ) THEN CALL DC_WLOG ( 2, 'RA', ier1, ' ', ier ) END IF C C* Compute difference between observation and C* system times. C CALL TI_MDIF ( irtarr, istarr, imdif, ier2 ) badtim = .false. C C* Check that the time is within NHOURS before C* the system time. C IF ( ( ier1 .ne. 0 ) .or. ( ier2 .ne. 0 ) .or. + ( imdif .gt. 60 ) .or. + ( imdif .lt. -60 * nhours ) ) THEN good = .false. badtim = .true. END IF C C* Write an error message if the time is invalid. IF ( badtim ) THEN errstr = buhd // cborg // btime CALL DC_WLOG ( 2, 'DCMETR', 3, errstr, ier ) CALL ST_INCH ( imdif, cmdif, ier ) errstr = dattim // dattmp // cmdif CALL DC_WLOG ( 2, 'DCMETR', 4, errstr, ier ) END IF END IF C C* Open the output file. C IF ( good ) THEN C C* Get the report observation time to store in C* the real interface (rivals) array and the BUFR C* message. (irephr, irepmin, irtarr passed into C* MT_OBST via mtcmn.cmn). C CALL MT_OBST ( ier3 ) END IF C C* Check for correction flag within report. C IF ( good .and. ( .not. corflg ) ) THEN indxcr = 0 IF ( coun .ne. 'CN' ) THEN indxcr = INDEX ( report ( :lenr ), ' COR ' ) ELSE indxcr = INDEX ( report ( :lenr ), ' CC' ) END IF C IF ( ( indxcr .gt. 10) .and. (indxcr .lt. 20 ) ) + corflg = .true. IF ( corflg ) rivals ( ircorn ) = 1. END IF C IF ( good ) THEN C C* Get station information from station table. C CALL MT_STBD ( iret ) C C* Check for an error. C IF ( iret .ne. 0 ) THEN good = .false. END IF END IF C C* Decode the report data. C IF ( good ) THEN IF ( saoflg ) THEN IF ( .not. specl ) THEN countr = contry CALL MT_DSAO ( irpntr, countr, + irtarr ( 4 ), iret) C C* Set the automatic station flag to C* 0.0 to indicate automatic report. C rivals ( irauto ) = 0.0 ELSE iret = -10 END IF ELSE CALL MT_DECD ( report ( :lenr ), lenr, + irpntr, iret ) END IF IF ( iret .eq. 0 ) THEN C loglvl = 3 C logmsg = '<-----BEGIN INTERFACE OUTPUT----->' CALL DC_WLOG ( loglvl, 'DC', 2, + logmsg (1:50), ierw ) C C* Write decoded values to decoder log. C CALL MT_IFPT ( rimnem, cimnem, iret ) C logmsg = '<-----END INTERFACE OUTPUT----->' CALL DC_WLOG ( loglvl, 'DC', 2, + logmsg (1:50), ierw ) C C* Convert current report data to BUFR format. C CALL MT_BUFR ( bufrtb, saoflg, last, report, + lenr, jret ) ibufr = .true. END IF END IF END DO END DO C* RETURN END