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* J. Ator/NCEP 06/23 Call ISETPRM as function *
C* J. Ator/NCEP 06/23 Use new decod_ut library routines, *
C* clean up and simplify logic *
C* J. Ator/NCEP 03/25 Process CrIS from INS *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BRIDGE.PRM'
INCLUDE 'eacmn.cmn'
CHARACTER*(*) cldt, bufrtn
CHARACTER bull*(DCMXBF), cbull*(DCMXBF),
+ seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8,
+ bfstin*8, bfstot*8,
+ ctag*8, ctagp*8, ctagpr*10, drptag*10,
+ cdesc(MXDSC)*6, meastyp*3, cval*8,
+ bufrdn*(DCMXLN), bufrbn*(DCMXLN)
INTEGER irundt (5), irptdt (5), ibull ( DCMXBF / 4 ),
+ ndrp2 (3), idxtmbr ( MXBMSE )
LOGICAL bullok, msgok, crisn20
REAL*8 r8ary ( MXVAL ), GETBMISS
EQUIVALENCE ( cbull (1:4), ibull (1) )
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* 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.
IF ( ( ISETPRM ( 'NFILES', 4 ) .ne. 0 ) .or.
+ ( ISETPRM ( 'MXMSGL', 2000000 ) .ne. 0 ) .or.
+ ( ISETPRM ( 'MAXMEM', 100000 ) .ne. 0 ) .or.
+ ( ISETPRM ( 'MAXMSG', 100 ) .ne. 0 ) .or.
+ ( ISETPRM ( 'MXDXTS', 5 ) .ne. 0 ) .or.
+ ( ISETPRM ( 'MXLCC', 8 ) .ne. 0 ) .or.
+ ( ISETPRM ( 'MXCDV', 6000 ) .ne. 0 ) ) RETURN
C* Open the tables file for the output stream.
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 messages file for the input stream.
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 )
CALL MTINFO ( bufrdn, 98, 99 )
C* Open the messages file for the output stream.
CALL FL_GLUN ( iubfmn, iergln )
IF ( iergln .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg )
RETURN
END IF
C* Connect the tables and messages files for the output stream.
CALL OPENBF ( iubfmn, 'NUL', iubftn )
r8bfms = GETBMISS()
C* Specify that output messages are to be compressed, edition 4
C* and up to 199.9K bytes in size.
CALL CMPMSG ('Y')
CALL PKVS01 ( 'BEN', 4 )
CALL MAXOUT ( 199900 )
C* Close the tables file for the output stream.
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 ( iubfme )
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
nrept = 0
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* Print the type and number of reports processed.
WRITE ( UNIT = logmsg, FMT = '( 2A, I4, A )' )
+ bfstot, ': ', nrept,' reports'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
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.
CALL UT_WBFR ( iubfmn, 'ears', 1, ierwbf )
bullok = .false.
CYCLE
END IF
cbull = bull ( istart : ibptr )
C* Open the BUFR message for reading.
CALL READERME ( ibull, iubfme, bfstin, ibfdt, ierrme )
IF ( ierrme .ne. 0 ) CYCLE
C* Check the contents of Section 3 of the message along
C* with the bulletin header to verify the data type.
ii = 1
bfstot = '????????'
crisn20 = .false.
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", "INS" ) ! 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", "INSI" ) ! 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* Print any unknown or extra descriptors to the decoder log.
CALL EA_PUED ( cdesc, ndesc, bfstot, crisn20, ierued )
IF ( bfstot(6:8) .eq. '???' ) CYCLE
msgok = .true.
DO WHILE ( msgok )
C* Get the next report from this BUFR message.
IF ( IREADSB ( iubfme ) .ne. 0 ) THEN
C* There are no more reports in this message.
msgok = .false.
CYCLE
ENDIF
nrept = nrept + 1
IF ( nrept .eq. 1 ) THEN
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.
SELECT CASE ( buhd (1:3) )
CASE ( "INC" )
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.
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 .ge. 224 ) .or.
+ ( isaid .le. 226 ) ) THEN
bfstot = 'NC021212'
idxyear = 5
drptag = '(CRCHNM)'
ctag = 'SRAD'
crisn20 = .true.
END IF
END IF
END SELECT
SELECT CASE ( bfstot(6:8) )
CASE ( "037", "038", "039",
+ "212", "213", "239", "249" )
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.
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* Compute the expected indices of all of the
C* TMBRST values within each input subset.
idxtmbrf = 43 ! expected index of first one
DO ii = 1, ntmbr
idxtmbr (ii) = idxtmbrf + (ii-1)*6
END DO
END SELECT
C* Calculate the total number of data values in
C* the subset, based on all of the delayed
C* replication counts.
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
C* Read all of the main data values from this report.
CALL UFBSEQ ( iubfme, r8ary, MXVAL, 1, ierusq, bfstin )
C* Read any supplemental values from this report.
CALL EA_SUPP ( iubfme, bfstot, ntmbr, idxtmbr,
+ r8ary, nr8in, nr8ot, ieresp )
C* Append the bulletin ID and receipt time data to
C* the end of the data values array.
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* Do not create BUFR output for reports that are more than
C* NHOURS before or more than 3 hours after the run time.
CALL UT_CHECK_BUFRRPTDT ( 2, irundt, r8ary(idxyear),
+ r8ary(idxyear+1), r8ary(idxyear+2), r8ary(idxyear+3),
+ r8ary(idxyear+4), nhours, 180, irptdt, iercrt )
IF ( iercrt .ne. 0 ) CYCLE
C* Open a BUFR message for output.
ibfdt = ( irptdt (1) * 1000000 ) + ( irptdt (2) * 10000 )
+ + ( irptdt (3) * 100 ) + irptdt (4)
CALL OPENMB ( iubfmn, bfstot, ibfdt )
C* Write all of the data values for this report.
SELECT CASE ( bfstot(6:8) )
CASE( "037", "038", "039",
+ "212", "213", "239", "249" )
CALL DRFINI ( iubfmn, ndrp, 1, drptag )
END SELECT
IF ( crisn20 ) THEN
SELECT CASE( bfstot(6:8) )
CASE( "037", "212" )
CALL DRFINI ( iubfmn, 1, 1, '<CRISN20>' )
CALL DRFINI ( iubfmn, ndrp12, 1, '{GCRCHN}' )
END SELECT
END IF
SELECT CASE ( bfstot(6:8) )
CASE( "039", "239" ) ! IASI only
CALL DRFINI ( iubfmn, ndrp2, 3, '(IASIPCS)' )
END SELECT
CALL UFBSEQ ( iubfmn, r8ary, nr8ot, 1, ierusq, bfstot )
CALL UT_WBFR ( iubfmn, 'ears', 0, ierwbf )
END DO
END DO
END DO
RETURN
END