SUBROUTINE LS_DCOD ( curtim, stntbl, bufrtb, r40fl, + nhours, iret ) C********************************************************************** * C* LS_DCOD * C* * C* This routine will read the WMO FM12 fixed land station and FM14 mobil* C* land station surface Observational data bulletins from standard * C input, decode the bulletin report data, and create BUFR output. * C* * C* LS_DCOD( CURTIM, STNTBL, BUFRTB, R40FL, NHOURS, IRET ) * C* * C* INPUT PARAMETERS: * C* CURTIM CHAR* Date/time from command line * C* STNTBL CHAR* Land synoptic world station * C* table * C* BUFRTB CHAR* BUFR table * C* R40FL CHAR* Table file of WMO Resolution 40 * C* bulletin headers * C* NHOURS INTEGER Number of hours before system * C* time * C* * C* Output parameters: * C* IRET INTEGER Return code * C* 0; Normal return * C* * C** * C* Log: * C* R. Hollern/NCEP 04/96 * C* R. Hollern/NCEP 01/98 New interface, merged LSDBLT, cleaned * C* up, removed GEMPAK calls * C* R. Hollern/NCEP 02/98 Changed check on min size of bulletin * C* R. Hollern/NCEP 05/98 Added new version number to log file * C* R. Hollern/NCEP 01/99 Renamed INCLUDE block ls.bufr.prm to * C* lsbufr.cmn * C* R. Hollern/NCEP 04/00 Modified the routine to make it conform * C* to the NWS/IWT decoders standards. Also,* C* removed check for ' SM ' in FAA reports * C* and added Include 'lscmn.stntbl.cmn'. * C* C. Caruso Magee/NCEP 06/01 Replace calls to STATUS, WRITSA, and * C* DBN_BUFR with new s/r UT_WBFR. * C* R. Hollern/NCEP 06/02 Added call to LS_AAXX * C* J. Ator/NCEP 06/02 Added check for WMO Res. 40 bulletins * C* R. Hollern/NCEP 08/02 Added the code to decode the FM 14 * C* mobil land station reports. Renamed * C* LS_AAXX TO LS_YYGG and array iaaxx to * C* yyggi. * C* J. Ator/NCEP 08/04 SS_GTIM -> CSS_GTIM * C* M. Weiss 05/17 Updated lsfc.tbl (v3.6.0) elevations * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'lscmn.cmn' INCLUDE 'lscmn_stntbl.cmn' INCLUDE 'lscmn_bufr.cmn' C* CHARACTER*(*) curtim, stntbl, bufrtb, r40fl C* INTEGER istarr(5) C* CHARACTER bulltn*(DCMXBF), sysdt*12, dattmp*12, + errstr*80, lsfrpt*(DCMXBF), cmdif*8, + cdate*8, ctime*4, cdattm*15, + rimnem ( NRIMN )*8, cimnem ( NCIMN )*8, + yyggi*5 C* LOGICAL more, good, last, ibufr C------------------------------------------------------------------------ iret = 0 C C* Open, read, and close the file of WMO Resolution 40 bulletin headers. C CALL FL_TBOP ( r40fl, 'rs40', ir40fl, iertop ) IF ( iertop .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iertop, r40fl, ierr ) RETURN END IF C iostat = 0 nr40b = 0 DO WHILE ( ( nr40b .lt. MXR40B ) .and. ( iostat .eq. 0 ) ) READ ( ir40fl, FMT = '(A)', IOSTAT = iostat ) + cr40b ( nr40b + 1 ) IF ( iostat .eq. 0 ) THEN nr40b = nr40b + 1 END IF END DO C CALL FL_CLOS ( ir40fl, iercls ) 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, 'DCLSFC', 2, errstr, ierr ) CALL DC_WLOG ( 0, 'FL', ier, stntbl, ierr ) RETURN END IF C C* Read the station table data, which contains the C* lat/long and elevation data for the stations. C CALL LS_STBL ( lunstb, kret ) C C* Set the pointers for the interface arrays. C CALL LS_IFSP ( rimnem, cimnem, ier ) IF ( ier .ne. 0 ) THEN CALL DC_WLOG ( 0, 'DCLSFC', -8, ' ', ierr ) RETURN END IF C C* Loop until timeout occurs. C iperr = 0 ibufr = .false. C DO WHILE ( iperr .eq. 0 ) C C* Get the next bulletin. C CALL DC_GBUL ( bulltn, lenb, ifdtyp, iperr ) C IF ( iperr .eq. 0 ) THEN C C* Parse the header info from the bulletin. C more = .true. CALL DC_GHDR ( bulltn, lenb, seqnum, buhd, cborg, + btime, bbb, nchrd, ierr ) IF ( ierr .ne. 0) THEN CALL DC_WLOG ( 2, 'DC', ierr, ' ', ier ) CALL ST_UNPR ( bulltn(:72), 72, errstr, len1, ier ) CALL DC_WLOG ( 2, 'DCLSFC', 7, errstr, ier ) more = .false. END IF ELSE C C* Write timeout message to the log. C CALL DC_WLOG ( 0, 'DC', iperr, ' ', ier ) more = .false. END IF IF ( more ) THEN 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 ) IF ( curtim .eq. 'SYSTEM' ) THEN dattmp = sysdt ELSE C C* Convert the user's input time into the standard C* GEMPAK time. C CALL TI_STAN ( curtim, sysdt, dattmp, ier ) END IF C C* Convert GEMPAK time to integer time. C CALL TI_CTOI ( dattmp, istarr, ier ) C C* Set receipt time significance to 0. C rctim (1) = 0.0 C DO i = 1, 5 rctim ( i + 1 ) = FLOAT ( istarr ( i ) ) END DO C C* Remove control characters from bulletin. C CALL ST_UNPR ( bulltn, lenb, bulltn, lennew, ier ) lenb = lennew C IF ( lenb .ge. 40 ) THEN C C* Check that bulletin contains land synoptic reports. C CALL LS_BTYP ( lenb, bulltn, jpos, yyggi, jret ) C IF ( ibrtyp .eq. 1 .or. ibrtyp .eq. 2 ) THEN C C* Write bulletin header data to the decoder log. C logmsg = seqnum // buhd // cborg // btime // bbb CALL DC_WLOG ( 2, 'DCLSFC', 2, logmsg(1:36),ier) ELSE more = .false. END IF ELSE C C* Reject bulletins less than 40 characters long. C more = .false. END IF END IF C C* Loop through reports. C DO WHILE ( more ) good = .true. C C* Get next report from bulletin. C CALL LS_GRPT ( lenb, bulltn, jpos, lszrpt, lsfrpt, jret) C IF ( jret .eq. 3 ) THEN C C* Found another set of AAXX YYGGI(w) groups in C* bulletin. C yyggi(1:5) = bulltn(jpos-5:jpos-1) CALL LS_YYGG ( yyggi, istarr, nret ) END IF C IF ( jret .eq. 2 ) THEN C C* There are no more reports in bulletin. C C* Make sure that all BUFR output for this bulletin C* has been written out before going back to DC_GBUL C* and waiting for a new bulletin on the input pipe. C IF ( ibufr ) THEN C CALL UT_WBFR ( iunbfo, 'lsfc', 1, ierwbf ) C END IF C more = .false. good = .false. ELSE IF ( jret .ne. 0 ) THEN good = .false. ELSE C C* Write raw report to LOG file. C isz = MIN ( 50, lszrpt ) loglvl = 2 CALL DC_WLOG ( loglvl, 'LS', 1, lsfrpt ( 1:isz ), + ierwlg ) C C* C* Initialize report parameters to missing. C CALL LS_IFIV ( jret ) CALL LS_INIT ( jret ) C C* Check length of groups in report. C CALL LS_CKRP ( lsfrpt, 6, lszrpt, jret ) C IF ( jret .ne. 0 ) THEN good = .false. ELSE C C* Decode section 0 of land synoptic report. C IF ( ibrtyp .eq. 1 ) THEN CALL LS_AST0 ( lszrpt, lsfrpt, yyggi, + istarr, ipt, jret) C IF ( jret .eq. 0 ) THEN C C* Get station data, such as location and C* elevation, from station table C CALL LS_STBD ( kret ) IF ( kret .ne. 0 ) good = .false. ELSE good = .false. END IF END IF C C* Decode section 0 of synoptic mobil report. C IF ( ibrtyp .eq. 2 ) THEN CALL LS_OST0 ( lszrpt, lsfrpt, istarr, + ipt, jret) IF ( jret .ne. 0 ) good = .false. END IF END IF END IF C IF ( good ) THEN C C* Compute difference between observation C* and system times. C CALL TI_MDIF ( irptdt, istarr, imdif, ier1) C C* Check that the time is within NHOURS before the C* system time. C C* Report time for BUFR must not be more than nhours C* before the system time, and not more than C* 60 minutes after. C IF ( ( ier1 .ne. 0 ) .or. ( imdif .gt. 60 ) + .or. ( imdif .lt. -60 * nhours ) ) THEN good = .false. errstr = buhd // cborg // btime CALL DC_WLOG ( 2, 'DCLSFC', 3, errstr, ier ) CALL ST_INCH ( imdif, cmdif, ier ) idate = irptdt(1) * 10000 + irptdt(2) * 100 + + irptdt(3) itime = irptdt(4)*100 + irptdt(5) CALL ST_INCH ( idate, cdate, ier ) CALL ST_INCH ( itime, ctime, ier ) cdattm = cdate(3:) // '/' // ctime errstr = cdattm // dattmp // cmdif CALL DC_WLOG ( 2, 'DCLSFC', 4, errstr, ier ) C END IF C IF ( good ) THEN C C* Decode the bulletin report and write the C* data to the output file. C IF ( ibrtyp .eq. 1 .or. ibrtyp .eq. 2 ) THEN CALL LS_DCD1 ( lszrpt, lsfrpt, ipt, jret ) END IF C C* Output decoded report. C IF ( jret .eq. 0 ) THEN C C* Output decoded report to LOG file C loglvl = 3 logmsg ='<-----BEGIN INTERFACE OUTPUT----->' CALL DC_WLOG ( loglvl, 'DC', 2, + logmsg (1:50), ierwlg ) C C* Print the raw report. C CALL DC_WLOG ( loglvl, 'DC', 2, + 'RAW REPORT:', ierw ) DO i = 1, lszrpt, 50 msz = MIN ( lszrpt, i+49 ) CALL DC_WLOG ( loglvl, 'DC', 2, + lsfrpt ( i:msz ), ierw ) END DO C C* Write decoded values to the decoder log. C CALL LS_IFPT ( rimnem, cimnem, ier ) C logmsg = '<-----END INTERFACE OUTPUT----->' CALL DC_WLOG ( loglvl, 'DC', 2, + logmsg (1:50), ierwlg ) C C* Convert current report data to BUFR format C CALL LS_BUFR( bufrtb, last, lsfrpt, + lszrpt, jret ) ibufr = .true. END IF END IF END IF END DO END DO C IF ( ibufr ) THEN last = .true. CALL LS_BUFR( bufrtb, last, lsfrpt, lszrpt, jret ) END IF C* RETURN END