SUBROUTINE CG_DCOD ( curtim, stntbl, bufrtb, nhours, iret ) C************************************************************************ C* CG_DCOD * C* * C* This subroutine reads bulletins containing Coast Guard reports in * C* the Coast Guard format, decodes the report data, and create BUFR * C* output from the decoded data. * C* * C* CG_DCOD ( CURTIM, STNTBL, BUFRTB, NHOURS, IRET ) * C* * C* INPUT PARAMETERS: * C* CURTIM CHAR* Date/time from command line * C* STNTBL CHAR* Coast Guard station table * C* BUFRTB CHAR* BUFR tables file * C* NHOURS INTEGER Max number of hours before run * C* time for creating BUFR output * C* * C* Output parameters: * C* RIVALS(IRCORN) REAL Correction indicator * C* 1. = corrected * C* 0. = not corrected * C* RIVALS(IRTOST) REAL Type of station * C* 1. = manned * C* 0. = automatic * C* IRET INTEGER Return code * C* 0 = Normal return * C* * C** * C* Log: * C* R. Hollern/NCEP 6/96 * C* R. Hollern/NCEP 2/97 Added code to display program version * C* number in LOG file * C* K. Tyle/GSC 4/97 Cleaned up * C* D. Kidwell/NCEP 4/97 Changed interface * C* K. Tyle/GSC 5/97 Additional error logging * C* D. Kidwell/NCEP 10/97 New interface, cleaned up, merged MADBLT* C* R. Hollern/NCEP 12/97 Removed GEMPAK calls, Added BUFR calls * C* R. Hollern/NCEP 1/98 Added code to close BUFR files * C* R. Hollern/NCEP 8/98 Added the version number to log file * C* R. Hollern/NCEP 1/99 Renamed INCLUDE block ma.bufr.prm to * C* mabufr.cmn * C* R. Hollern/NCEP 12/99 Made a major revision to the program by * C* removing the code which processes * C* drifting buoy reports. * C* R. Hollern/NCEP 3/00 Modified routine to make it conform to * C* the standards for the NWS/IWT decoders. * C* C. Caruso Magee/NCEP 4/00 Modifying for Coast Guard data. * C* C. Caruso Magee/NCEP 6/00 Remove multi-lev cloud and wave refs. * C* C. Caruso Magee/NCEP 8/00 Add ircorn back in and check bbb for COR* 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 06/01 Change to check for non-missing data * C* starting w/ 1st mnemonic after TOST * C* (type of station). If all data after * C* that point is missing, don't write out * C* to BUFR. * C* C. Caruso Magee/NCEP 02/02 Rename orign to cborg; lunbfr to iunbfo;* C* CG_BUFA to CG_BUFR; cgbufr.cmn to * C* cgcmn_bufr.cmn. * C* C. Caruso Magee/NCEP 06/04 Fixed error numbers passed to DC_WLOG * C* J. Ator/NCEP 08/04 SS_GTIM -> CSS_GTIM * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'cgcmn.cmn' INCLUDE 'cgcmn_bufr.cmn' C* CHARACTER*(*) curtim, stntbl, bufrtb C* INTEGER istarr(5) C CHARACTER bulltn*(DCMXBF), sysdt*12, dattmp*12, + errstr*80, cgrpt*(DCMXBF), + cmdif*8, cdate*8, ctime*4, cdattm*15, + rimnem ( NRIMN )*8, cimnem ( NCIMN )*8 CHARACTER cgrpto*(DCMXBF) C LOGICAL more, good, ibufr, last LOGICAL gotdata, corbul C DATA last / .false. / C----------------------------------------------------------------------- iret = 0 C C* Open the station table file. C CALL FL_TBOP ( stntbl, 'stns', lunstb, ier ) IF ( ier .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ier, stntbl, ierr ) RETURN END IF C C* Read the Coast Guard station table data, which contains lat/long C* and elevation data for Coast Guard stations. C CALL CG_STBL ( lunstb, kret ) C C* Set the pointers for the interface arrays. C CALL CG_IFSP ( rimnem, cimnem, ier ) IF ( ier .ne. 0 ) THEN CALL DC_WLOG ( 0, 'DCCGRD', -8, ' ', ierr ) RETURN END IF C C* Loop until a timeout occurs. C iperr = 0 ibufr = .false. C DO WHILE ( iperr .eq. 0 ) C C* Get the bulletin. Blank out the bulltn array before refilling. C jpos = 0 lenb = 0 DO k = 1, DCMXBF bulltn(k:k) = ' ' END DO CALL DC_GBUL( bulltn, lenb, ifdtyp, iperr ) 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, 'DCCGRD', 3, errstr, ier ) more = .false. ELSE C C* Initialize logicals to missing for new bulletin. C CALL CG_INIT ( jret ) C C* Reject SXUS82 bulletin if KTBW is originator. C* Reject SXUS86 bulletin if KSFO is originator. C* Reject all SXUS81 and SXUS83 bulletins. C IF ((( buhd (1:6) .eq. 'SXUS82' ) .and. + cborg(1:4) .eq. 'KTBW' ) .or. + (( buhd(1:6) .eq. 'SXUS86' ) .and. + cborg(1:4) .eq. 'KSFO' ) .or. + ( buhd(1:6) .eq. 'SXUS81' ) .or. + ( buhd(1:6) .eq. 'SXUS83' )) THEN CALL DC_WLOG ( 4, 'DC', ierr, ' ', ier ) CALL ST_UNPR ( bulltn(:72), 72, errstr, * len1, ier ) CALL DC_WLOG ( 4, 'DCCGRD', 3, errstr, ier ) more = .false. END IF 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 END IF ELSE C C* Write out timeout message to the log. C CALL DC_WLOG ( 0, 'DC', iperr, ' ' , ier ) more = .false. END IF IF ( more ) THEN jpos = 1 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 CALL TI_STAN ( curtim, sysdt, dattmp, ier ) END IF CALL TI_CTOI ( dattmp, istarr, ier ) C C* Set receipt time significance to 0. C rctim (1) = 0.0 C C* Save receipt time in cgcmn.cmn. C DO i = 1, 5 rctim ( i+1 ) = FLOAT ( istarr ( i ) ) END DO C IF ( lenb .ge. 60 ) THEN C C* Write bulletin header data to decoder log. C logmsg = seqnum // buhd // cborg // btime // bbb CALL DC_WLOG (2, 'DCCGRD', 2, logmsg(1:36),ier) ELSE C C* Reject bulletins less than 60 characters long. C more = .false. END IF END IF C C* Clean up the bulletin as much as possible before processing. C IF ( more ) THEN C C* Convert lower case characters in the bulletin to C* upper case first. C CALL ST_LCUC ( bulltn(1:lenb), bulltn(1:lenb), iret) C CALL CG_CLUP( lenb, bulltn, iret) c lenb = lenb - nchrd jpos = jpos + nchrd END IF C C* Loop through reports. C DO WHILE ( more ) good = .true. C C* Get next report from bulletin. C CALL CG_GRPT ( lenb, bulltn, jpos, mszrpt, cgrpt, jret) C IF ( jret .eq. 2 ) THEN C C* No more reports in bulletin. C IF ( .not. gothdr ) THEN WRITE ( UNIT = logmsg, FMT = '( A )' ) * ' Missing header line! Skip this bulletin.' CALL DC_WLOG ( 2, 'CG', 1, logmsg, ierwlg ) END IF 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, 'cgrd', 1, ierwbf ) C END IF C more = .false. good = .false. ELSE IF ( jret .ne. 0 ) THEN good = .false. ELSE C C* First check cgrpt to see if it's a valid report line. C CALL CG_CKLN ( cgrpt, mszrpt, jpos, jret ) IF ( jret .ne. 0 ) THEN good = .false. ELSE C C* Initialize report parameters to missing. C CALL CG_IFIV ( jret ) C C* Set report date/time array using system date and i C* bulletin header info. C CALL CG_DATM ( jret ) IF ( jret .ne. 0 ) THEN more = .false. 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, 'DCCGRD', 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, 'DCCGRD', 4, errstr, ier ) C END IF C IF ( good ) THEN C C* Write raw report to LOG file. C c isz = MIN ( 60, mszrpt ) loglvl = 2 CALL DC_WLOG ( loglvl, ' ', 1, * cgrpt ( 1:mszrpt ), ierwlg ) C C* set correction flag if bulletin header indicates C* this is part of a corrected bulletin. C IF ( corbul ) rivals ( ircorn ) = 1. C C* set type of station (assume manned for now). C rivals ( irtost ) = 1. C C* Decode the bulletin report and write the data C* to the output file. C CALL CG_DCD1 ( mszrpt, cgrpt, ipt, jret ) 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 ) CALL ST_UNPR ( cgrpt, mszrpt, cgrpto, + mszrpto, ier ) DO i = 1, mszrpto, 50 msz = MIN ( mszrpto, i+49 ) CALL DC_WLOG ( loglvl, 'DC', 2, + cgrpto ( i:msz ), ierw ) END DO C CALL CG_IFPT ( rimnem, cimnem, ierr ) C logmsg = '<-----END INTERFACE OUTPUT----->' CALL DC_WLOG ( loglvl, 'DC', 2, + logmsg (1:50), ierwlg ) C C* Check for presence of any data other C* than date/time, position, correction C* indicator, or station type. If any C* other data is not missing, then write C* to BUFR. Start the do loop at position C* 11 of the rivals array (just after TOST) C* and check all the single level variables C* (don't have any multi-layer variables in C* this decoder). C gotdata = .false. DO l = 11, NRSLMN IF ( rivals(l) .ne. RMISSD ) THEN gotdata = .true. END IF END DO C C* Convert current report data to BUFR format C IF ( gotdata ) THEN CALL CG_BUFR( bufrtb, last, cgrpt, + mszrpt, jret ) ibufr = .true. END IF END IF END IF END IF END DO END DO C C* Close BUFR files C IF ( ibufr ) THEN last = .true. CALL CG_BUFR( bufrtb, last, cgrpt, mszrpt, jret ) END IF C* RETURN END