SUBROUTINE EA_DCOD ( cldt, bufrtn, nhours, iret ) C************************************************************************ C* EA_DCOD * C* * C* This routine decodes bulletins containing EARS (EUMETSAT ATOVS * C* Retransmission Service) BUFR messages into NCEP BUFR format. * C* * C* EA_DCOD ( CLDT, BUFRTN, NHOURS, IRET ) * C* * C* Input parameters: * C* CLDT CHAR* Date-time from command line * C* BUFRTN CHAR* NCEP EARS BUFR tables file * C* NHOURS INTEGER Max # of hours before run time * C* for creating BUFR output * C* * C* Output parameters: * C* IRET INTEGER Return code: * C* 0 = normal return * C* * C** * C* Log: * C* J. Ator/NCEP 03/05 * C* J. Ator/NCEP 11/09 Add capability for MHS * C* J. Ator/NCEP 09/15 Restructured to use IO='SEC3' and add * C* capability for CrIS and ATMS * C* J. Ator/NCEP 02/16 Add capability for IASI * C* M. Weiss/IMSG 03/17 1. Modified the order in which the * C* contents of Section 3 messages/bulletin * C* headers via data type are checked. * C* 2. Inserted DO WHILE to prevent * C* declaring bullok = false when the * C* number of descriptors (ndesc) is > 1 * C* 3. As a result of (2), added the * C* following log file message: * C* "message contains extra descriptors" * C* which is not flagged by Big Brother. * C* J. Ator/NCEP 09/17 Store GSES for CrIS and IASI subtypes. * C* J. Ator/NCEP 08/18 Remove GSES from CRIS and IASI subtypes,* C* and add dynamic allocation with MXMSGL. * C* M. Weiss/IMSG 09/18 Changed MXDSC (Max # of descriptors) * C* from 10 to 200 * C* M. Weiss/IMSG 10/18 Added Direct Broadcast (DB) CrIS, ATMS, * C* and IASI subtypes. * C* M. Weiss/IMSG 06/19 Added NOAA-20 full spectral CrIS * C* M. Weiss/IMSG 08/19 CrIS NPP DB NSR uses CRCHN and * C* CrIS NOAA-20 DB FSR uses CRCHNM. * C* M. Weiss/IMSG 09/19 For RARS IASI data add INQX GTS header * C* M. Weiss/IMSG 12/19 For RARS IASI data add INQI and bypass * C* INQX AMMC GTS headers * C* M. Weiss/IMSG 01/20 Optimized case statements to be able to * C* process future IASI and CrIS headers. * C* M. Weiss/IMSG 04/20 Updates related to NPP CrIS FSR feeds * C* J. Ator/NCEP 08/20 Store NEDTQW values when available for * C* AMSU-A/B, HIRS and MHS data * C* J. Ator/NCEP 08/20 Add capability for AIRS data * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'eacmn.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, + bfstin*8, bfstot*8, + ctag*8, ctagp*8, ctagpr*10, drptag*10, + cdesc(MXDSC)*6, meastyp*3, cval*8, + bufrdn*(DCMXLN), bufrbn*(DCMXLN) C* INTEGER irundt (5), irptdt (5), ibull ( DCMXBF / 4 ), + ndrp2 (3), idxtmbr ( MXBMSE ) C* LOGICAL bullok, crisn20 C* REAL*8 r8ary ( MXVAL ), GETBMISS C* EQUIVALENCE ( cbull (1:4), ibull (1) ) 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* Set any configurable BUFRLIB parameters to optimize them for C* the needs of this program. This includes setting any C* parameters associated with BUFRLIB features that we won't be C* using in this program to artificially low values, which in turn C* will prevent the unnecessary allocation of a lot of memory that C* will never be used. C CALL ISETPRM ( 'NFILES', 4 ) CALL ISETPRM ( 'MXMSGL', 2000000 ) CALL ISETPRM ( 'MAXMEM', 100000 ) CALL ISETPRM ( 'MAXMSG', 100 ) CALL ISETPRM ( 'MXDXTS', 5 ) CALL ISETPRM ( 'MXLCC', 8 ) CALL ISETPRM ( 'MXCDV', 6000 ) C C* Open the tables file for the C* NCEP EARS 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 EUMETSAT EARS BUFR messages file. C CALL FL_GLUN ( iubfme, iergln ) IF ( iergln .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg ) RETURN END IF OPEN ( UNIT = iubfme, FILE = '.dummy/dcears', + FORM = 'UNFORMATTED' ) CALL OPENBF ( iubfme, 'SEC3', iubftn ) C CALL MTINFO ( bufrdn, 98, 99 ) C C* Open the messages file for the C* NCEP EARS 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 EARS BUFR (i.e. output) stream. C CALL OPENBF ( iubfmn, 'NUL', iubftn ) r8bfms = GETBMISS() C C* Specify that NCEP EARS BUFR (i.e. output) messages are C* to be compressed, edition 4 and up to 199.9K bytes in size. C CALL CMPMSG ('Y') CALL PKVS01 ( 'BEN', 4 ) CALL MAXOUT ( 199900 ) C C* Close the tables file for the C* NCEP EARS BUFR (i.e. output) stream. C CALL FL_CLOS ( iubftn, iercls ) IF ( iercls .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg ) END IF C 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 ( iubfme ) CALL CLOSBF ( iubfmn ) CALL FL_CLAL ( iercal ) RETURN END IF bullok = .true. nrept = 0 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 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 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 IF ( bullok ) THEN C C* If a date-time was entered on the command line, then C* use it as the run date-time. Otherwise, use the C* system time as 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 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 IF ( bullok ) THEN C C* Locate the EUMETSAT EARS BUFR message C* within the bulletin, and store it within an C* equivalenced integer array. C ipt1 = INDEX ( bull ( ibptr : lenb ), 'BUFR' ) IF ( ipt1 .ne. 0 ) THEN istart = ibptr + ipt1 - 1 cbull = bull ( istart : lenb ) ELSE bullok = .false. END IF END IF IF ( bullok ) THEN C C* Check for a corrupt BUFR message. C msglen = IUPBS01 ( ibull, 'LENM' ) IF ( ( msglen .gt. lenb ) .or. + ( cbull ( msglen-3 : msglen ) .ne. '7777' ) ) THEN bullok = .false. logmsg = 'ERROR: corrupt BUFR message' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) END IF END IF IF ( bullok ) THEN C C* Open the EUMETSAT EARS BUFR message. C CALL READERME ( ibull, iubfme, bfstin, ibfdt, ierrme ) IF ( ierrme .ne. 0 ) THEN bullok = .false. END IF END IF IF ( bullok ) THEN C C* Check the contents of Section 3 of the message along C* with the bulletin header to verify the data type. C ii = 1 bfstot = '????????' crisn20 = .false. CALL UPDS3 ( ibull, MXDSC, cdesc, ndesc ) C DO WHILE ( ( bfstot(6:8) .eq. '???' ) .and. + ( ii .le. ndesc ) ) SELECT CASE ( cdesc(ii)(1:6) ) CASE ( "310009" ) SELECT CASE ( buhd (1:3) ) CASE ( "INA" ) ! AMSU-A bfstot = 'NC021033' idxyear = 16 ntmbr = 15 nr8in = 127 END SELECT CASE ( "310010" ) SELECT CASE ( buhd (1:3) ) CASE ( "INB" ) ! AMSU-B bfstot = 'NC021034' idxyear = 16 ntmbr = 5 nr8in = 67 CASE ( "INM" ) ! MHS bfstot = 'NC021036' idxyear = 16 ntmbr = 5 nr8in = 67 END SELECT CASE ( "310008" ) SELECT CASE ( buhd (1:3) ) CASE ( "INH" ) ! HIRS bfstot = 'NC021035' idxyear = 16 ntmbr = 19 nr8in = 156 END SELECT CASE ( "310060" ) ! CrIS SELECT CASE ( buhd (1:4) ) CASE ( "INCX" ) ! RARS CrIS bfstot = 'NC021037' idxyear = 5 drptag = '(CRCHN)' ctag = 'SRAD' CASE ( "INCT" ) ! DB CrIS NSR bfstot = 'NC021212' idxyear = 5 drptag = '(CRCHN)' ctag = 'SRAD' END SELECT CASE ( "001007" ) ! NOTE: No Table D descriptor IF ( ndesc .ge. 73 ) THEN SELECT CASE ( buhd (1:3) ) CASE ( "INC" ) ! DB CrIS FSR bfstot = 'NC021212' idxyear = 5 drptag = '(CRCHNM)' ctag = 'SRAD' crisn20 = .true. END SELECT END IF CASE ( "310061" ) ! ATMS SELECT CASE ( buhd (1:4) ) CASE ( "INSX" ) ! RARS ATMS bfstot = 'NC021038' idxyear = 6 drptag = '(ATMSCH)' ctag = 'TMBR' CASE ( "INST" ) ! DB ATMS bfstot = 'NC021213' idxyear = 6 drptag = '(ATMSCH)' ctag = 'TMBR' END SELECT CASE ( "340008" ) ! IASI SELECT CASE ( buhd (1:3) ) CASE ( "IEQ", "INQ" ) IF ( buhd (1:4) .eq. 'INQT' ) THEN bfstot = 'NC021239' ! DB IASI ELSE bfstot = 'NC021039' ! RARS IASI END IF idxyear = 5 drptag = '(IASICHN)' ctag = 'SCRA' END SELECT CASE ( "310050" ) ! AIRS SELECT CASE ( buhd (1:4) ) CASE ( "INRT" ) bfstot = 'NC021249' idxyear = 27 drptag = '(SCBTSEQN)' ctag = 'TMBR' END SELECT END SELECT ii = ii + 1 END DO C C* Print any unknown or extra descriptors to the decoder log. C CALL EA_PUED ( cdesc, ndesc, bfstot, crisn20, ierued ) C IF ( bfstot(6:8) .eq. '???' ) bullok = .false. END IF C DO WHILE ( bullok ) C C* Get the next report from this EUMETSAT EARS C* BUFR message. C IF ( IREADSB ( iubfme ) .ne. 0 ) THEN C C* There are no more reports in this message. C bullok = .false. C C* Print the type and number of reports processed. C WRITE ( UNIT = logmsg, FMT = '( 2A, I4, A )' ) + bfstot, ': ', nrept,' reports' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) 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, 'ears', 1, ierwbf ) ELSE nrept = nrept + 1 C IF ( nrept .eq. 1 ) THEN C C* Finish up some final checks and other calculations C* that couldn't be done earlier, because we needed C* some data values from within the first report of C* the BUFR message, and we hadn't yet called IREADSB C* to read in that first report. C SELECT CASE ( buhd (1:3) ) CASE ( "INC" ) C C* For CrIS, do an additional sanity check for C* FSR content, to ensure that such reports are C* processed correctly even if they start using C* a Table D descriptor at some future point, C* and in which case the previous logic would C* have mistakenly labeled them as NSR. C CALL UT_BFRI ( iubfme, 'SAID', rval, iret ) isaid = NINT ( rval ) CALL UT_BFCI ( iubfme, 'MTYP', cval, iret ) meastyp = cval(1:3) IF ( meastyp .eq. "FSR" ) THEN IF ( ( isaid .eq. 225 ) .or. + ( isaid .eq. 224 ) ) THEN bfstot = 'NC021212' idxyear = 5 drptag = '(CRCHNM)' ctag = 'SRAD' crisn20 = .true. END IF END IF END SELECT C SELECT CASE ( bfstot(6:8) ) CASE ( "037", "038", "039", + "212", "213", "239", "249" ) C C* Get the number of delayed replication levels C* for each subset in the message. The message C* is compressed, so the number of replications C* will be identical for each subset. C CALL GETTAGPR ( iubfme, ctag, 1, ctagp, + ierptg ) CALL ST_LSTR ( ctagp, lctagp, ier ) ctagpr = '(' // ctagp(1:lctagp) // ')' CALL UFBINT ( iubfme, r8ary, MXVAL, 1, + ierusg, ctagpr ) ndrp = IDINT ( r8ary (1) ) ndrp1 = ndrp + 1 CASE ( "033", "034", "035", "036" ) C C* Compute the expected indices of all of the C* TMBRST values within each input subset. C idxtmbrf = 43 ! expected index of first one DO ii = 1, ntmbr idxtmbr (ii) = idxtmbrf + (ii-1)*6 END DO END SELECT C C* Calculate the total number of data values in C* the subset, based on all of the delayed C* replication counts. C SELECT CASE ( bfstot(6:8) ) CASE ( "037", "212" ) ! CrIS IF ( .NOT. crisn20 ) THEN nr8in = ( ndrp * 2 ) + 56 ELSE CALL GETTAGPR ( iubfme, ctag, ndrp1, ctagp, + ierptg ) CALL ST_LSTR ( ctagp, lctagp, ier ) ctagpr = '{' // ctagp(1:lctagp) // '}' CALL UFBINT ( iubfme, r8ary, MXVAL, 1, + ierusg, ctagpr ) ndrp12 = IDINT ( r8ary (1) ) nr8in = ( ndrp * 2 ) + ( ndrp12 * 2 ) + 641 END IF CASE ( "038", "213" ) ! ATMS nr8in = ( ndrp * 9 ) + 25 CASE ( "039", "239" ) ! IASI CALL GETTAGPR ( iubfme, 'NNPCS', 1, + ctagp, ierptg ) CALL ST_LSTR ( ctagp, lctagp, ier ) ctagpr = '(' // ctagp(1:lctagp) // ')' CALL UFBREP ( iubfme, r8ary, 1, MXVAL, + ierusg, ctagpr ) ndrp2(1) = IDINT ( r8ary (1) ) ndrp2(2) = IDINT ( r8ary (2) ) ndrp2(3) = IDINT ( r8ary (3) ) nr8in = ( ndrp * 2 ) + 322 + + ndrp2(1) + ndrp2(2) + ndrp2(3) CASE ( "249" ) ! AIRS nr8in = ( ndrp * 4 ) + 174 END SELECT END IF ! nrept .eq. 1 C C* Read all of the main data values from this report. C CALL UFBSEQ ( iubfme, r8ary, MXVAL, 1, ierusq, + bfstin ) C C* Read any supplemental values from this report. C CALL EA_SUPP ( iubfme, bfstot, ntmbr, idxtmbr, + r8ary, nr8in, nr8ot, ieresp ) C C* Append the bulletin ID and receipt time data to C* the end of the data values array. C CALL UT_C2R8 ( seqnum, 8, r8ary(nr8ot+1), nr8, ier ) CALL UT_C2R8 ( buhd, 8, r8ary(nr8ot+2), nr8, ier ) CALL UT_C2R8 ( cborg, 8, r8ary(nr8ot+3), nr8, ier ) CALL UT_C2R8 ( bulldt, 8, r8ary(nr8ot+4), nr8, ier ) CALL UT_C2R8 ( bbb, 8, r8ary(nr8ot+5), nr8, ier ) r8ary ( nr8ot + 6 ) = FLOAT ( 0 ) r8ary ( nr8ot + 7 ) = FLOAT ( irundt (1) ) r8ary ( nr8ot + 8 ) = FLOAT ( irundt (2) ) r8ary ( nr8ot + 9 ) = FLOAT ( irundt (3) ) r8ary ( nr8ot + 10 ) = FLOAT ( irundt (4) ) r8ary ( nr8ot + 11 ) = FLOAT ( irundt (5) ) nr8ot = nr8ot + 11 C C* Do not create BUFR output for reports that are C* more than NHOURS before or more than 3 hours C* after the run time. C rptyr = UT_BMRI ( r8ary (idxyear) ) rptmo = UT_BMRI ( r8ary (idxyear+1) ) rptdy = UT_BMRI ( r8ary (idxyear+2) ) rpthr = UT_BMRI ( r8ary (idxyear+3) ) rptmi = UT_BMRI ( r8ary (idxyear+4) ) 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 C C* Open a BUFR message for output. C ibfdt = ( irptdt (1) * 1000000 ) + + ( irptdt (2) * 10000 ) + + ( irptdt (3) * 100 ) + irptdt (4) CALL OPENMB ( iubfmn, bfstot, ibfdt ) C C* Write all of the data values for this report. C SELECT CASE ( bfstot(6:8) ) CASE( "037", "038", "039", + "212", "213", "239", "249" ) CALL DRFINI ( iubfmn, ndrp, 1, drptag ) END SELECT C IF ( crisn20 ) THEN SELECT CASE( bfstot(6:8) ) CASE( "037", "212" ) CALL DRFINI ( iubfmn, 1, 1, + '' ) CALL DRFINI ( iubfmn, ndrp12, 1, + '{GCRCHN}' ) END SELECT END IF C SELECT CASE ( bfstot(6:8) ) CASE( "039", "239" ) ! IASI only CALL DRFINI ( iubfmn, ndrp2, 3, + '(IASIPCS)' ) END SELECT C CALL UFBSEQ ( iubfmn, r8ary, nr8ot, 1, ierusq, + bfstot ) CALL UT_WBFR ( iubfmn, 'ears', 0, ierwbf ) ENDIF END IF ! IREADSB ( iubfme ) .ne. 0 END DO END DO C* RETURN END