SUBROUTINE CS_DCOD ( cldt, bufrta, bufrtn, nhours, iret )
C************************************************************************
C* CS_DCOD *
C* *
C* This routine decodes bulletins containing EUMETSAT CSR SEVIRI *
C* BUFR messages into NCEP BUFR format. *
C* *
C* CS_DCOD ( CLDT, BUFRTA, BUFRTN, NHOURS, IRET ) *
C* *
C* Input parameters: *
C* CLDT CHAR* Date-time from command line *
C* BUFRTA CHAR* EUMETSAT CSR SEVIRI *
C* BUFR tables file *
C* BUFRTN CHAR* NCEP 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 09/10 *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BRIDGE.PRM'
C*
CHARACTER*(*) cldt, bufrta, bufrtn
C*
C* Number of expected descriptors within Section 3 for each
C* EUMETSAT CSR SEVIRI BUFR message.
C*
PARAMETER ( NXDSC = 51 )
C*
C* The following array will hold the list of expected descriptors
C* within Section 3 for each EUMETSAT CSR SEVIRI BUFR message.
C*
CHARACTER cxdsc( NXDSC )*6
C*
CHARACTER bull*(DCMXBF), cbull*(DCMXBF), bfstyp*8,
+ seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8,
+ rundt*12, sysdt*12,
+ logmsg*200
C*
INTEGER irundt ( 5 ), irptdt ( 5 ),
+ ibull ( DCMXBF / 4 )
C*
LOGICAL bullok
C*
REAL*8 r8in ( 642 ), r8out1 ( 6 ),
+ r8out2 ( 11, 12 ), r8out3 ( 2, 48 )
C*
EQUIVALENCE ( cbull (1:4), ibull (1) )
C*
C*
DATA ( cxdsc ( ii ), ii = 1, NXDSC )
+ / '310023',
+ '222000', '236000', '101185', '031031',
+ '001031', '001032', '101036', '033007',
+ '222000', '237000',
+ '001031', '001032', '008033', '101036', '033007',
+ '222000', '237000',
+ '001031', '001032', '008033', '101036', '033007',
+ '222000', '237000',
+ '001031', '001032', '008033', '101036', '033007',
+ '222000', '237000',
+ '001031', '001032', '008033', '101036', '033007',
+ '224000', '237000',
+ '001031', '001032', '008023', '101036', '224255',
+ '224000', '237000',
+ '001031', '001032', '008023', '101036', '224255' /
C*
INCLUDE 'ERMISS.FNC'
C*-----------------------------------------------------------------------
iret = 0
C
C* Open the EUMETSAT CSR SEVIRI BUFR tables file.
C
CALL FL_SOPN ( bufrta, iubfta, ierspn )
IF ( ierspn .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', ierspn, bufrta, ierwlg )
RETURN
END IF
C
C* Open the EUMETSAT CSR SEVIRI BUFR messages file.
C
CALL FL_GLUN ( iubfma, iergln )
IF ( iergln .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg )
RETURN
END IF
C
C* Connect the EUMETSAT CSR SEVIRI BUFR tables and
C* messages files.
C
CALL OPENBF ( iubfma, 'INUL', iubfta )
C
C* Close the EUMETSAT CSR SEVIRI BUFR tables file.
C
CALL FL_CLOS ( iubfta, iercls )
IF ( iercls .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg )
END IF
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 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
C* to be compressed and up to 20K bytes in size.
C
CALL CMPMSG ('Y')
C
CALL MAXOUT (20000)
C
C* Close the tables file for the NCEP 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 ( iubfma )
CALL CLOSBF ( iubfmn )
CALL FL_CLAL ( iercal )
RETURN
END IF
C
bullok = .true.
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 next BUFR message within the bulletin,
C* and store it within an 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* Retrieve the Section 3 descriptors from the message
C* and compare it with the list of expected descriptors.
C
CALL UT_CBS3 ( 2, ibull, cxdsc, NXDSC, iercs3 )
IF ( iercs3 .ne. 0 ) THEN
bullok = .false.
logmsg = 'message has unknown format'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
END IF
END IF
IF ( bullok ) THEN
C
C* Open the BUFR message.
C
CALL READERME ( ibull, iubfma, bfstyp, ibfdt, ierrme )
IF ( ierrme .ne. 0 ) THEN
bullok = .false.
END IF
END IF
C
nrept = 0
C
DO WHILE ( bullok )
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
bullok = .false.
C
C* Print a count of the number of reports processed.
C
WRITE ( UNIT = logmsg, FMT = '( A, I6, A )' )
+ 'contained ', 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, 'cseviri', 1, ierwbf )
ELSE
nrept = nrept + 1
C
CALL UFBSEQ ( iubfma, r8in, 642, 1, ier, 'FN005040')
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 ( r8in (6) )
rptmo = UT_BMRI ( r8in (7) )
rptdy = UT_BMRI ( r8in (8) )
rpthr = UT_BMRI ( r8in (9) )
rptmi = UT_BMRI ( r8in (10) )
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, 'NC021043', ibfdt )
C
C* Write all of the data values for this report.
C
C* Satellite identification.
C
CALL UFBSEQ ( iubfmn, r8in, 13, 1, ier,
+ 'SIDENSEQ')
C
C* Pixel counts, zenith angles and geopotential.
C
DO i = 1, 6
r8out1 ( i ) = r8in ( i + 13 )
END DO
CALL UFBINT ( iubfmn, r8out1, 6, 1, ier,
+ 'NPPR NPPC LSQL SAZA SOZA HITE' )
C
C* Clouds, brightness temperatures and standard
C* deviation values.
C
DO j = 1, 12
DO i = 1, 5
r8out2 ( i, j ) = r8in ( 19 + ((j-1)*5) + i)
END DO
DO i = 6, 8
r8out2 ( i, j ) = r8in ( 84 + ((j-1)*8) + i)
END DO
r8out2 ( 9, j ) = r8in ( 89 + (j*8) )
r8out2 ( 10, j ) = r8in ( 567 + (j*3) )
r8out2 ( 11, j ) = r8in ( 372 + (j*3) )
END DO
CALL UFBREP ( iubfmn, r8out2, 11, 12, ier,
+ 'SCCF SCBW CLDMNT NCLDMNT CLTP SIDP '//
+ 'RDTP RDCM TMBRST SDTB PCCF' )
C
C* Percent confidences.
C
DO j = 1, 12
DO i = 1, 4
r8out3 ( 1, ((j-1)*4) + i ) =
+ r8in ( 372 + (i*39) )
r8out3 ( 2, ((j-1)*4) + i ) =
+ r8in ( 411 + (j*3) + ((i-1)*39) )
END DO
END DO
CALL UFBREP ( iubfmn, r8out3, 2, 48, ier,
+ 'MDPC PCCF' )
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* Write the BUFR output to the BUFR output
C* stream.
C
CALL UT_WBFR ( iubfmn, 'cseviri', 0, ierwbf )
END IF
END IF
END DO
END DO
C*
RETURN
END