SUBROUTINE TG_DCOD ( curtim, stntbl, crextblb, crextbld, bufrtb, + nhours, iret ) C************************************************************************ C* TG_DCOD * C* * C* This subroutine reads bulletins containing tide gauge data reports * C* in the CREX format, decodes the report data, and creates BUFR output * C* from the decoded data. * C* * C* TG_DCOD ( CURTIM, STNTBL, CREXTBLB, CREXTBLD, BUFRTB, NHOURS, IRET ) * C* * C* INPUT PARAMETERS: * C* CURTIM CHAR* Date/time from command line * C* STNTBL CHAR* Tide station location table file* C* CREXTBL CHAR* CREX Table B Elements file * C* CREXTBLD CHAR* CREX Table D Sequences file * C* BUFRTB CHAR* Marine BUFR table file * C* NHOURS INTEGER Max number of hours before run * C* time for creating BUFR output * C* LENMSG INTEGER CREX message length * C* CREXMSG CHAR* CREX message * C* * C* Output parameters: * C* LUTBLB INTEGER CREX Table B logical unit number* C* LUTBLD INTEGER CREX Table D logical unit number* C* MXNDESC INTEGER Maximum number of descriptors * C* expected in Section 1 of message* C* MXRPT INTEGER Maximum number of reports * C* expected in message * C* MXRPTSZ INTEGER Maximum report size expected * C* MXDATV REAL Maximum number of data values * C* expected * C* CTBLA CHAR* 3-digit CREX table A reference * C* CTBLDS CHAR* CREX table descriptor * C* NDESC INTEGER Number of data descriptors in * C* Section 1 of CREX message * C* DATADESC (MXNDESC) * C* CHAR* List of descriptors in Sec 1 * C* * C* NMRPTS INTEGER Number of reports in CREX msg * C* * C* NMDESC INTEGER Number of descriptors in expdesc* C* * C* EXPDESC (MXDATV) * C* CHAR* List of the expanded Section 1 * C* descriptors. The expansion * C* consists of replacing the * C* sequence and non-delayed * C* replication descriptors with the* C* list they correspond to. The * C* final list will be close to a * C* one-to-one correspondence with * C* the data values in Section 2. * C* LENRPTS (NMRPTS) * C* INTEGER Array to store the length of * C* each report * C* RAWRPT (MXRPT, MXRPTSZ) * C* CHAR* Array to hold subsets in message* C* * C* NMDATVAL INTEGER Number of data values in * C* Section 2 of CREX message * C* * C* DATAVAL (MXRPT,MXDATV) * C* REAL Array to hold the Section 2 * C* decoded data values * C* IRET INTEGER Return code * C* 0 = Normal return * C* * C** * C* Log: * C* R. Hollern/NCEP 08/00 * C* C. Caruso Magee/NCEP 03/01 Corrected code so that if any report in * C* a bulletin sets good to F, reset good to* C* T prior to getting next report in * C* bulletin; otherwise, that report won't * C* be processed even if it's ok. * 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 orign to cborg. * C* R. Hollern/NCEP 08/03 The program was modified to use the * C* CREX decoder. This was a major revision * C* to the program. * C* J. Ator/NCEP 08/04 SS_GTIM -> CSS_GTIM * C* M. Weiss/NCEP IMSG 03/20 The CREX routine cxgtv1.f was updated * C* to properly read tide gauge values * C* greater than 5 characters in length. * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'tgcmn.cmn' INCLUDE 'tgcmn_stntbl.cmn' INCLUDE 'tgcmn_bufr.cmn' C* C* Define the maximum number of data values expected in a report C* and the maximum number of descriptors after expansion of C* descriptor set in Section 1. C* PARAMETER ( mxdatv = 200, mxndesc = 100 ) C* C* Define the maximum number of reports expected in a message and C* the maximum report size in characters. C* PARAMETER ( mxrpt = 75, mxrptsz = 500 ) C* REAL*8 dataval ( mxrpt, mxdatv ) C* CHARACTER*(*) curtim, stntbl, bufrtb, crextblb, crextbld C* INTEGER tszrpt, istarr(5) INTEGER lenrpts ( mxrpt ) C* CHARACTER bulltn*(DCMXBF), sysdt*12, dattmp*12, + errstr*80, tidrpt*(DCMXBF), + ctbla*4, ctblds*7, cmdif*8, cdate*8, ctime*4, + cdattm*15, + rimnem ( NRIMN )*8, cimnem ( NCIMN )*8 C* CHARACTER datadesc ( mxndesc )*6 CHARACTER expdesc ( mxdatv )*6 C* C* The subset/report will be saved in character*8 array. C* CHARACTER rawrpt ( mxrpt, mxrptsz )*8 C* LOGICAL more, good, ibufr, last 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 tide gauge station table data, which contain lat/long C* locations and elevation heights for these sites. C CALL TG_STBL ( lunstb, ierr ) C IF ( ierr .eq. -2 ) THEN RETURN END IF C C* Open the CREX table D. C CALL FL_TBOP ( crextbld, 'tbld', lutbld, ier ) C IF ( ier .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ier, crextbld, ierwlg ) iret = 1 RETURN END IF C C* Open the CREX table B. C CALL FL_TBOP ( crextblb, 'tblb', lutblb, ier ) C IF ( ier .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ier, crextblb, ierwlg ) iret = 1 RETURN END IF C C* Set the pointers for the interface arrays. C CALL TG_IFSP ( rimnem, cimnem, ierr ) IF ( ierr .ne. 0 ) THEN CALL DC_WLOG ( 0, 'DCTIDG', -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 next bulletin. C CALL DC_GBUL( bulltn, lenb, ifdtyp, iperr ) C IF ( iperr .eq. 0 ) THEN C C* Parse the header information 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 TG_UNP1 ( bulltn(:72), 72, errstr, len1, ier ) CALL DC_WLOG ( 2, 'DCTIDG', 2, errstr, ier ) more = .false. END IF ELSE C C* Write timeout message to the LOG file. C CALL DC_WLOG ( 0, 'DC', iperr, ' ' , ier ) more = .false. END IF C 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 CALL TI_STAN ( curtim, sysdt, dattmp, ier ) END IF C 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 tgcmn.cmn. C DO i = 1, 5 rctim ( i+1 ) = FLOAT ( istarr ( i ) ) END DO C C* Remove control characters from bulletin. C CALL TG_UNP1 ( bulltn, lenb, bulltn, lennew, ier ) lenb = lennew C IF ( lenb .ge. 60 ) THEN C C* Write bulletin header data to decoder LOG file. C logmsg = seqnum // buhd // cborg // btime // bbb CALL DC_WLOG (2, 'DCTIDG', 2, logmsg(1:36),ier) ELSE C C* Reject bulletin if less than 60 characters long. C more = .false. END IF END IF C IF ( more ) THEN C C* Decode the CREX message. C CALL CX_DCOD ( lutblb, lutbld, mxndesc, mxrpt, mxrptsz, + mxdatv, lenb, bulltn, ctbla, ctblds, + ndesc, datadesc, nmrpts, nmdesc, expdesc, + lenrpts, rawrpt, nmdatval, dataval, iret ) C IF ( iret .eq. 1 .or. nmrpts .eq. 0 ) THEN C C* Problems -- Get next bulletin. C more = .false. good = .false. END IF DO 5000 nr = 1, nmrpts C IF ( more ) THEN C C* Reset good to true each time in case the previous C* report was bad. C good = .true. END IF C C* Store report in tidrpt array and write it to log C* message file. C CALL TG_SRPT ( nr, mxrpt, lenrpts, mxrptsz, rawrpt, + tszrpt, tidrpt, iret ) C IF ( good ) THEN C C* Initialize interface parameters to missing. C CALL TG_IFIV ( jret ) C C* Get Section 2 data. C CALL TG_DCD2 ( mxrpt, mxrptsz, mxdatv, expdesc, + nmrpts, lenrpts, nmdatval, dataval, + nr, iret ) C C* If iret is not zero, then either station id/time C* was bad, station wasn't in station table, or tide C* elevation data couldn't be decoded, so skip the C* rest of this report and go get the next one. C IF ( iret .ne. 0 ) good = .false. C 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* Report time for BUFR must not be more than nhours C* before the system time and not more than C* 60 minutes after it. C IF ( ( ier1 .ne. 0 ) .or. ( imdif .gt. 60 ) + .or. ( imdif .lt. -60 * nhours ) ) THEN good = .false. CALL DC_WLOG ( 2, 'DCTIDG', 8, ' ', 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, 'DCTIDG', 4, errstr, ier ) END IF C IF ( good ) THEN C C* Output decoded report to LOG file if verbosity C* level is 3. 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 ) C DO i = 1, tszrpt, 50 msz = MIN ( tszrpt, i+49 ) CALL DC_WLOG ( loglvl, 'DC', 2, + tidrpt ( i:msz ), ierw ) END DO C CALL TG_IFPT ( rimnem, cimnem, ierr ) C logmsg = '<-----END INTERFACE OUTPUT----->' C CALL DC_WLOG ( loglvl, 'DC', 2, + logmsg (1:50), ierwlg ) C C* Convert current report data to BUFR format. C CALL TG_BUFR( bufrtb, last, tidrpt, tszrpt, + jret ) ibufr = .true. END IF END IF 5000 END DO C C* 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 CALL UT_WBFR ( iunbfo, 'tidg', 1, ierwbf ) END IF C END IF END DO C C* Close BUFR files. C IF ( ibufr ) THEN last = .true. CALL TG_BUFR( bufrtb, last, tidrpt, tszrpt, jret ) END IF C* RETURN END