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* J. Ator/NCEP 12/22 Comment out setting of RSRD and EXPRSRD * C* for commercial RO providers * C* J. Ator/NCEP 07/23 Use new decod_ut library routines, * C* clean up and simplify logic * C* J. Ator/NCEP 12/23 Decode SASBID if present * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'BUFR.CMN' CHARACTER*(*) cldt, bufrtn C* Maximum number of descriptors within Section 3 of a radio C* occultation message. PARAMETER ( MXDSC = 100 ) CHARACTER bull*(DCMXBF), cbull*(DCMXBF), + seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8, + logmsg*200, cdesc( MXDSC )*6, + bufrdn*(DCMXLN), bufrbn*(DCMXLN), + bfstyp*8, subtyp*8, tagpr*8, tagprp*10 C* Maximum number of data values in a radio occultation subset. PARAMETER ( MXMN = 125000 ) REAL*8 r8in ( MXMN ) INTEGER irundt (5), irptdt (5), ibull ( DCMXBF / 4 ), + ndrps2 (MXBFLV16), RC_NDRP LOGICAL bullok, msgok EQUIVALENCE ( cbull (1:4), ibull (1) ) INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 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. CALL FL_PATH ( bufrtn, bufrdn, bufrbn, ierpth ) C* Open the BUFR tables file. CALL FL_SOPN ( bufrtn, iubftn, ierspn ) IF ( ierspn .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ierspn, bufrtn, ierwlg ) RETURN END IF C* Open the BUFR messages file. 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 ) CALL MTINFO ( bufrdn, 98, 99 ) C* Open the BUFR output file. CALL FL_GLUN ( iubfmn, iergln ) IF ( iergln .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg ) RETURN END IF C* Connect the BUFR tables file to the BUFR output file. CALL OPENBF ( iubfmn, 'NUL', iubftn ) C* Specify that BUFR output messages are to be encoded using C* edition 4 and up to 200K bytes in size. CALL PKVS01 ( 'BEN', 4 ) CALL MAXOUT ( 199900 ) C* Close the BUFR tables file. CALL FL_CLOS ( iubftn, iercls ) IF ( iercls .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg ) END IF DO WHILE ( .true. ) C* Get a new bulletin from the input pipe. CALL DC_GBUL ( bull, lenb, ifdtyp, iergbl ) IF ( iergbl .ne. 0 ) THEN C* A time-out occurred while waiting for a new bulletin C* on the input pipe. Shut down the decoder and exit. CALL DC_WLOG ( 0, 'DC', iergbl, ' ', ierwlg ) CALL CLOSBF ( iubfma ) CALL CLOSBF ( iubfmn ) CALL FL_CLAL ( iercal ) RETURN END IF C* Do not decode AFOS products. IF ( ifdtyp .ne. 0 ) CYCLE C* Decode the header information from this bulletin. CALL DC_GHDR ( bull, lenb, seqnum, buhd, cborg, + bulldt, bbb, ibptr, ierghd ) IF ( ierghd .ne. 0 ) THEN CALL DC_WLOG ( 2, 'DC', ierghd, ' ', ierwlg ) CYCLE END IF C* Start an entry for this bulletin in the decoder log. logmsg = '########################################' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) logmsg = seqnum // buhd // cborg // bulldt // bbb CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) C* Get the run date-time. CALL UT_GET_RUNDT ( cldt, irundt, iergrd ) IF ( iergrd .ne. 0 ) CYCLE bullok = .true. DO WHILE ( bullok ) C* Locate the next BUFR message within the bulletin, and store C* it within an equivalenced integer array. CALL UT_GET_BUFRMG ( bull, lenb, ibptr, istart, msglen, + mtyp, msbti, MXDSC, cdesc, ndesc, ierbmg ) IF ( ierbmg .ne. 0 ) THEN C* Make sure that all BUFR output for this bulletin has been C* written to the BUFR output stream before going back to C* DC_GBUL and waiting for a new bulletin on the input pipe. CALL UT_WBFR ( iubfmn, 'rocc', 1, ierwbf ) bullok = .false. CYCLE END IF cbull = bull ( istart : ibptr ) msgok = .false. C* Review the Section 3 descriptors from the message to ensure C* it contains radio occultation data. ii = 1 DO WHILE ( ( ii .le. ndesc ) .and. ( .not. msgok ) ) IF ( cdesc(ii) .eq. '310026' ) THEN msgok = .true. ELSE ii = ii + 1 END IF END DO IF ( .not. msgok ) THEN logmsg = 'message does not follow WMO template:' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) DO ii = 1, ndesc WRITE ( logmsg, FMT = '(I6, A, A)' ) ii, ': ', cdesc(ii) CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) END DO CYCLE END IF C* Open the BUFR message for reading. CALL READERME ( ibull, iubfma, bfstyp, ibfdt, ierrme ) IF ( ierrme .ne. 0 ) CYCLE icmp = IUPBS3 ( ibull, 'ICMP' ) nrept = 0 DO WHILE ( msgok ) C* Get the next report from this BUFR message. IF ( IREADSB ( iubfma ) .ne. 0 ) THEN C* There are no more reports in this message. msgok = .false. CYCLE END IF C* Don't create BUFR output for reports that are more than C* NHOURS before or more than 3 hours after the run time. CALL UFBINT ( iubfma, r8in, MXMN, 1, nlv, + 'YEAR MNTH DAYS HOUR MINU' ) CALL UT_CHECK_BUFRRPTDT ( 2, irundt, r8in(1), + r8in(2), r8in(3), r8in(4), r8in(5), + nhours, 180, irptdt, iercrt ) IF ( iercrt .ne. 0 ) CYCLE nrept = nrept + 1 C* If the message is uncompressed, or if this is the first C* subset in the message, then get the delayed replication C* counts. 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 subtyp = 'NC003010' C* Open a BUFR message for output. ibfdt = ( irptdt (1) * 1000000 ) + ( irptdt (2) * 10000 ) + + ( irptdt (3) * 100 ) + irptdt (4) CALL OPENMB ( iubfmn, subtyp, ibfdt ) C* Set the delayed replication counts. 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* Read and write the main report sequence. CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, 'RAOCSEQ' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'RAOCSEQ' ) C* Log the subtype and satellite ID. Also log and store the C* satellite subID if it exists. CALL UT_BFRI ( iubfma, 'SAID', said, ier ) isaid = INT ( said ) CALL UT_BFRI ( iubfma, 'SASBID', sasbid, ier ) IF ( .not. ERMISS ( sasbid ) ) THEN CALL UT_RIBF ( iubfmn, 'SASBID', sasbid, ier ) WRITE ( logmsg, FMT = '(2A, I4, A, I4)' ) + subtyp, ': satellite ID =', isaid, + ', satellite subID = ', INT ( sasbid ) ELSE WRITE ( logmsg, FMT = '(2A, I4)' ) + subtyp, ': satellite ID =', isaid END IF CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) C* Bulletin header. 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* Receipt time. 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* Correction indicator. 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* Restrictions on redistribution. CCC IF ( ( isaid .ge. 265 ) .and. ( isaid .le. 269 ) ) THEN CCC CALL UT_RIBF ( iubfmn, 'RSRD', 128., ier ) CCC CALL UT_RIBF ( iubfmn, 'EXPRSRD', 24., ier ) CCC END IF C* Write the BUFR output to the BUFR output stream. CALL UT_WBFR ( iubfmn, 'rocc', 0, ierwbf ) END DO END DO END DO RETURN END