SUBROUTINE RC_DCOD ( cldt, bufrtn, nhours, iret ) C************************************************************************ C* RC_DCOD * C* * C* This routine decodes bulletins containing radio occultation data * C* into NCEP BUFR format. * C* * C* RC_DCOD ( CLDT, BUFRTN, NHOURS, IRET ) * C* * C* Input parameters: * C* CLDT CHAR* Date-time from command line * C* BUFRTN CHAR* NCEP BUFR tables file * C* NHOURS INTEGER Max # of hours before run time * C* for creating NCEP BUFR output * C* * C* Output parameters: * C* IRET INTEGER Return code: * C* 0 = normal return * C* * C** * C* Log: * C* J. Ator/NCEP 10/08 * C* J. Ator/NCEP 09/09 Add UT_CBS3 check * C* J. Ator/NCEP 09/20 Redesigned to fully decode input msgs, * C* and to add RSRD, EXPRSRD, BID and RCPTIM* C* to NCEP output stream. * C* M. Weiss/IMSG 05/21 MAXOUT (200000) to (199900) * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'BUFR.CMN' C* CHARACTER*(*) cldt, bufrtn C* CHARACTER bull*(DCMXBF), cbull*(DCMXBF), + seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8, + rundt*12, sysdt*12, logmsg*200, + bufrdn*(DCMXLN), bufrbn*(DCMXLN), + bfstyp*8, subtyp*8, tagpr*8, tagprp*10 C* C* Maximum number of data values in a radio occultation subset. C* PARAMETER ( MXMN = 125000 ) C* REAL*8 r8in ( MXMN ) C* INTEGER irundt (5), irptdt (5), ibull ( DCMXBF / 4 ), + ndrps2 (MXBFLV16), RC_NDRP C LOGICAL bullok C* EQUIVALENCE ( cbull (1:4), ibull (1) ) C* C* Expected descriptors within Section 3 of a radio occultation C* BUFR message. C* PARAMETER ( NXDESC = 1 ) CHARACTER cxdesc(NXDESC)*6 C* DATA cxdesc / '310026' / C* INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 C C* Get the BUFR tables directory from the tables file. This C* directory will be passed to subroutine MTINFO as the location C* in which to search for any needed master table files. C CALL FL_PATH ( bufrtn, bufrdn, bufrbn, ierpth ) C C* Open the tables file for the NCEP BUFR (i.e. output) stream. C CALL FL_SOPN ( bufrtn, iubftn, ierspn ) IF ( ierspn .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ierspn, bufrtn, ierwlg ) RETURN END IF C C* Open the BUFR messages file. C CALL FL_GLUN ( iubfma, iergln ) IF ( iergln .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg ) RETURN END IF OPEN ( UNIT = iubfma, FILE = '.dummy/dcrocc', + FORM = 'UNFORMATTED' ) CALL OPENBF ( iubfma, 'SEC3', iubftn ) C CALL MTINFO ( bufrdn, 98, 99 ) C C* Open the messages file for the NCEP BUFR (i.e. output) stream. C CALL FL_GLUN ( iubfmn, iergln ) IF ( iergln .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg ) RETURN END IF C C* Connect the tables and messages files for the C* NCEP BUFR (i.e. output) stream. C CALL OPENBF ( iubfmn, 'NUL', iubftn ) C C* Specify that NCEP BUFR (i.e. output) messages are to be C* encoded using edition 4 and up to 200K bytes in size. C CALL PKVS01 ( 'BEN', 4 ) CALL MAXOUT ( 199900 ) DO WHILE ( .true. ) C C* Get a new bulletin from the input pipe. C CALL DC_GBUL ( bull, lenb, ifdtyp, iergbl ) IF ( iergbl .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', iergbl, ' ', ierwlg ) CALL CLOSBF ( iubfma ) CALL CLOSBF ( iubfmn ) CALL FL_CLAL ( iercal ) RETURN END IF C C* Decode the header information from this bulletin. C IF ( ifdtyp .eq. 0 ) THEN C C* Decode WMO products. C CALL DC_GHDR ( bull, lenb, seqnum, buhd, cborg, + bulldt, bbb, ibptr, ierghd ) IF ( ierghd .ne. 0 ) THEN CALL DC_WLOG ( 2, 'DC', ierghd, ' ', ierwlg ) bullok = .false. ELSE bullok = .true. C C* Start an entry for this bulletin in the decoder log. C logmsg = '########################################' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) logmsg = seqnum // buhd // cborg // bulldt // bbb CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) END IF ELSE C C* Do not decode AFOS products. C bullok = .false. END IF C IF ( bullok ) THEN C C* Get the system time. C itype = 1 CALL CSS_GTIM ( itype, sysdt, iergtm ) IF ( iergtm .ne. 0 ) THEN CALL DC_WLOG ( 2, 'SS', iergtm, ' ', ierwlg ) bullok = .false. END IF END IF C IF ( bullok ) THEN C C* If a date-time was entered on the command line, then use it C* as the run date-time. Otherwise, use the system time as C* the run date-time. C IF ( cldt .eq. 'SYSTEM' ) THEN rundt = sysdt ELSE CALL TI_STAN ( cldt, sysdt, rundt, ierstn ) IF ( ierstn .ne. 0 ) THEN CALL DC_WLOG ( 2, 'TI', ierstn, ' ', ierwlg ) bullok = .false. END IF END IF END IF C IF ( bullok ) THEN C C* Convert the run date-time to integer. C CALL TI_CTOI ( rundt, irundt, iercto ) IF ( iercto .ne. 0 ) THEN CALL DC_WLOG ( 2, 'TI', iercto, ' ', ierwlg ) bullok = .false. END IF END IF C DO WHILE ( bullok ) C C* Locate the next BUFR message within the bulletin, and store C* it within an equivalenced integer array. C ipt1 = INDEX ( bull ( ibptr : lenb ), 'BUFR' ) IF ( ipt1 .eq. 0 ) THEN bullok = .false. C C* Make sure that all BUFR output for this bulletin C* has been written to the BUFR output stream before C* going back to DC_GBUL and waiting for a new bulletin C* on the input pipe. C CALL UT_WBFR ( iubfmn, 'rocc', 1, ierwbf ) ELSE nrept = 0 istart = ibptr + ipt1 - 1 ibptr = istart + 4 cbull = bull ( istart : lenb ) msglen = IUPBS01 ( ibull, 'LENM' ) IF ( ( msglen .gt. lenb ) .or. + ( cbull ( msglen-3 : msglen ) .ne. '7777' ) ) THEN msgok = .false. logmsg = 'ERROR: corrupt BUFR message' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) ELSE msgok = .true. END IF C IF ( msgok ) THEN C C* Retrieve the Section 3 descriptors from the message C* and compare it with the list of expected descriptors. C CALL UT_CBS3 ( 2, ibull, cxdesc, NXDESC, iercs3 ) IF ( iercs3 .ne. 0 ) THEN msgok = .false. logmsg = 'message does not contain 310026 sequence' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) END IF END IF C IF ( msgok ) THEN C C* Open the BUFR message for reading. C CALL READERME ( ibull, iubfma, bfstyp, ibfdt, ierrme ) IF ( ierrme .ne. 0 ) THEN msgok = .false. ELSE icmp = IUPBS3 ( ibull, 'ICMP' ) END IF END IF C DO WHILE ( msgok ) C C* Get the next report from this BUFR message. C IF ( IREADSB ( iubfma ) .ne. 0 ) THEN C C* There are no more reports in this message. C msgok = .false. ELSE C C* Don't create BUFR output for reports that are more C* than NHOURS before or more than 3 hours after the C* run time. C CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, + 'YYMMDD' ) rptyr = UT_BMRI ( r8in (1) ) rptmo = UT_BMRI ( r8in (2) ) rptdy = UT_BMRI ( r8in (3) ) CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, + 'HHMM' ) rpthr = UT_BMRI ( r8in (1) ) rptmi = UT_BMRI ( r8in (2) ) IF ( ( ERMISS ( rptyr ) ) .or. + ( ERMISS ( rptmo ) ) .or. + ( ERMISS ( rptdy ) ) .or. + ( ERMISS ( rpthr ) ) .or. + ( ERMISS ( rptmi ) ) ) THEN iertmk = -1 ELSE irptdt (1) = INT ( rptyr ) irptdt (2) = INT ( rptmo ) irptdt (3) = INT ( rptdy ) irptdt (4) = INT ( rpthr ) irptdt (5) = INT ( rptmi ) CALL DC_TMCK ( 2, irundt, irptdt, nhours, 180, + iertmk ) END IF C IF ( iertmk .eq. 0 ) THEN nrept = nrept + 1 C C* If the message is uncompressed, or if this is the C* first subset in the message, then get the delayed C* replication counts. C IF ( ( icmp .eq. 0 ) .or. ( nrept .eq. 1 ) ) THEN ndrps1 = RC_NDRP ( iubfma, 'BEARAZ', 2 ) IF ( ndrps1 .gt. 0 ) THEN CALL GETTAGPR ( iubfma, 'MEFR', 1, tagpr, + ierptg ) IF ( ierptg .ne. 0 ) THEN DO ii = 1, ndrps1 ndrps2 (ii) = 0 END DO ELSE CALL ST_LSTR ( tagpr, ltagpr, ier ) tagprp = '{' // tagpr(1:ltagpr) // '}' CALL UFBREP ( iubfma, r8in, 1, MXMN, nrep, + tagprp ) DO ii = 1, ndrps1 ndrps2 (ii) = IDINT ( r8in (ii) ) END DO END IF END IF ndrps3 = RC_NDRP ( iubfma, 'ARFR', 1 ) ndrps4 = RC_NDRP ( iubfma, 'SPFH', 1 ) END IF C C* Log the subtype and satellite ID. C CALL UT_BFRI ( iubfma, 'SAID', said, ier ) isaid = INT ( said ) subtyp = 'NC003010' WRITE ( logmsg, FMT = '(2A, I4)' ) + subtyp, ': satellite ID =', isaid CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) C C* Open a BUFR message for output. C ibfdt = ( irptdt (1) * 1000000 ) + + ( irptdt (2) * 10000 ) + + ( irptdt (3) * 100 ) + irptdt (4) CALL OPENMB ( iubfmn, subtyp, ibfdt ) C C* Set the delayed replication counts. C CALL DRFINI ( iubfmn, ndrps1, 1, '(ROSEQ1)' ) IF ( ndrps1 .gt. 0 ) THEN CALL DRFINI ( iubfmn, ndrps2, ndrps1, + '{ROSEQ2}' ) END IF CALL DRFINI ( iubfmn, ndrps3, 1, '(ROSEQ3)' ) CALL DRFINI ( iubfmn, ndrps4, 1, '(ROSEQ4)' ) C C* Read and write the main report sequence. C CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, + 'RAOCSEQ' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'RAOCSEQ' ) C C* Bulletin header. C CALL UT_CIBF ( iubfmn, 'SEQNUM', seqnum, 8, ier ) CALL UT_CIBF ( iubfmn, 'BUHD', buhd, 8, ier ) CALL UT_CIBF ( iubfmn, 'BORG', cborg, 8, ier ) CALL UT_CIBF ( iubfmn, 'BULTIM', bulldt, 8, ier ) CALL UT_CIBF ( iubfmn, 'BBB', bbb, 8, ier ) C C* Receipt time. C CALL UT_RIBF ( iubfmn, 'RCTS', FLOAT (0), ier ) CALL UT_RIBF ( iubfmn, 'RCYR', + FLOAT ( irundt (1) ), ier ) CALL UT_RIBF ( iubfmn, 'RCMO', + FLOAT ( irundt (2) ), ier ) CALL UT_RIBF ( iubfmn, 'RCDY', + FLOAT ( irundt (3) ), ier ) CALL UT_RIBF ( iubfmn, 'RCHR', + FLOAT ( irundt (4) ), ier ) CALL UT_RIBF ( iubfmn, 'RCMI', + FLOAT ( irundt (5) ), ier ) C C* Correction indicator. C IF ( ( IUPBS01 ( ibull, 'USN' ) .gt. 0 ) .or. + ( bbb(1:1) .eq. 'C' ) ) THEN icorn = 1 ELSE icorn = 0 END IF CALL UT_RIBF ( iubfmn, 'CORN', FLOAT (icorn), ier ) C C* Restrictions on redistribution. C IF ( ( isaid .ge. 265 ) .and. + ( isaid .le. 269 ) ) THEN CALL UT_RIBF ( iubfmn, 'RSRD', 128., ier ) CALL UT_RIBF ( iubfmn, 'EXPRSRD', 24., ier ) END IF C C* Write the BUFR output to the BUFR output stream. C CALL UT_WBFR ( iubfmn, 'rocc', 0, ierwbf ) END IF C END IF C END DO C END IF C END DO C END DO C* RETURN END