SUBROUTINE AT_DCOD ( cldt, bufrtn, nhours, iret )
C************************************************************************
C* AT_DCOD *
C* *
C* This program decodes bulletins containing altimeter BUFR data into *
C* NCEP BUFR format. *
C* *
C* AT_DCOD ( CLDT, BUFRTN, NHOURS, IRET ) *
C* *
C* Input parameters: *
C* CLDT CHAR* Date-time from command line *
C* BUFRTN CHAR* NCEP altimeter BUFR table *
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* S. Guan/NCEP 11/08 Initial version *
C* J. Ator/NCEP 11/08 Use CRBMG to read BUFR msgs from a file *
C* J. Ator/NCEP 09/10 Add UT_CBS3 check *
C* S. Guan/NCEP 03/10 Add new BUFR Jason2 sequence (3-40-010) *
C* Change in the format of the Jason-2 *
C* OGDR-BUFR products to be introduced *
C* April 14 201 *
C* S. Guan/NCEP 04/10 Rewrite: creating NC031115 sequence and *
C * adding "RCPTIM CORN" *
C* J. Ator/NCEP 12/12 Use IO='INUL' in OPENBF call to *
C* preclude use of .dummy file *
C* J. Ator/NCEP 10/15 Restructured to read GTS bulletins *
C* instead of system files and to add *
C* processing of Cryosat and SARAL/Altika *
C* J. Ator/NCEP 07/16 Add processing of Jason-3 *
C* J. Ator/NCEP 03/20 Add processing of Sentinel 3A and 3B *
C* M. Weiss/NCEP 03/21 Add processing of updated Cryosat-2 *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BRIDGE.PRM'
C*
CHARACTER*(*) cldt, bufrtn
C*
PARAMETER ( MXDSC = 10 )
C*
CHARACTER bull*(DCMXBF), cbull*(DCMXBF),
+ seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8,
+ rundt*12, sysdt*12,
+ bfstin*8, bfstot*8, satstg*8,
+ logmsg*200, cdesc(MXDSC)*6,
+ bufrdn*(DCMXLN), bufrbn*(DCMXLN)
CHARACTER bfstyp*8,
+ cstaq*20, csoftv*12, cnumid*16, cpcid*8
C*
INTEGER irundt (5), irptdt (5), ibull ( DCMXBF / 4 )
C*
LOGICAL bullok
C*
PARAMETER ( MXVAL = 1500 )
C*
REAL*8 r8ary ( MXVAL )
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* Open the tables file for the
C* NCEP altimeter 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 input BUFR messages stream.
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/dcaltm',
+ FORM = 'UNFORMATTED' )
CALL OPENBF ( iubfme, 'SEC3', iubftn )
CALL MTINFO ( bufrdn, 98, 99 )
C
C* Open the messages file for the
C* NCEP altimeter 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 altimeter BUFR (i.e. output) stream.
C
CALL OPENBF ( iubfmn, 'NUL', iubftn )
C
C* Specify that NCEP altimeter BUFR (i.e. output) messages are
C* to be compressed, edition 4 and up to 100K bytes in size.
C
CALL CMPMSG ( 'Y' )
CALL PKVS01 ( 'BEN', 4 )
CALL MAXOUT ( 100000 )
CALL PKVS01 ( 'MTV', 33 )
C
C* Close the tables file for the
C* NCEP altimeter 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
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
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 altimeter 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* 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 altimeter 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
corn = FLOAT ( IUPBS01 ( ibull, 'USN' ) )
IF ( corn .gt. 0.0 ) corn = 1.0
C
C* Check the contents of Section 3 of the message to
C* determine the data type.
C
CALL UPDS3 ( ibull, MXDSC, cdesc, ndesc )
IF ( ( ndesc .eq. 1 ) .and.
+ ( cdesc(1)(1:6) .eq. '340010' ) ) THEN
bfstot = 'NC031115'
satstg = 'JASON-2 '
idxyear = 8
nr8in = 104
ELSE IF ( ( ndesc .eq. 1 ) .and.
+ ( cdesc(1)(1:6) .eq. '340011' ) ) THEN
bfstot = 'NC031122'
satstg = 'SARALATK'
idxyear = 8
nr8in = 78
ELSE IF ( ( ndesc .eq. 2 ) .and.
+ ( cdesc(1)(1:6) .eq. '312071' ) ) THEN
bfstot = 'NC031123'
satstg = 'CRYOST-2'
idxyear = 11
nr8in = 119
ELSE IF ( ( ndesc .eq. 1 ) .and.
+ ( cdesc(1)(1:6) .eq. '340017' ) ) THEN
bfstot = 'NC031134'
satstg = 'SNTNL-3A'
idxyear = 12
nr8in = 846
ELSE
bullok = .false.
logmsg = 'message contains unknown descriptors:'
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
END IF
END IF
C
DO WHILE ( bullok )
C
C* Get the next report from this altimeter 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 a count of the number of reports processed.
C
WRITE ( UNIT = logmsg, FMT = '( 3A, I4, A )' )
+ 'found ', satstg, ' BUFR message with ',
+ 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, 'altm', 1, ierwbf )
ELSE
nrept = nrept + 1
C
C* Read all of the data values from this report.
C
CALL UFBSEQ ( iubfme, r8ary, MXVAL, 1, ierusq,
+ bfstin )
CALL READLC ( iubfme, cstaq, 'STAQ' )
CALL READLC ( iubfme, csoftv, 'SOFTV' )
IF ( ( satstg(1:5) .eq. 'JASON' ) .or.
+ ( satstg(1:5) .eq. 'SARAL' ) )
+ CALL READLC ( iubfme, cnumid, 'NUMID' )
IF ( ( satstg(1:5) .eq. 'CRYOS' ) .or.
+ ( satstg(1:5) .eq. 'SNTNL' ) )
+ CALL UT_BFCI ( iubfme, 'PCID', cpcid, ier )
IF ( bfstot .eq. 'NC031115' ) THEN
isaid = IDNINT( r8ary(1) )
IF ( isaid .eq. 262 ) THEN
bfstot = 'NC031124'
satstg(7:7) = '3'
END IF
ELSE IF ( bfstot .eq. 'NC031134' ) THEN
isaid = IDNINT( r8ary(1) )
IF ( isaid .eq. 65 ) THEN
bfstot = 'NC031135'
satstg(8:8) = 'B'
END IF
END IF
C
C* Append the bulletin header, receipt time and
C* correction indicator to the end of the data
C* values array.
C
CALL UT_C2R8 ( seqnum, 8, r8ary(nr8in+1), nr8, ier )
CALL UT_C2R8 ( buhd, 8, r8ary(nr8in+2), nr8, ier )
CALL UT_C2R8 ( cborg, 8, r8ary(nr8in+3), nr8, ier )
CALL UT_C2R8 ( bulldt, 8, r8ary(nr8in+4), nr8, ier )
CALL UT_C2R8 ( bbb, 8, r8ary(nr8in+5), nr8, ier )
r8ary ( nr8in + 6 ) = FLOAT ( 0 )
r8ary ( nr8in + 7 ) = FLOAT ( irundt (1) )
r8ary ( nr8in + 8 ) = FLOAT ( irundt (2) )
r8ary ( nr8in + 9 ) = FLOAT ( irundt (3) )
r8ary ( nr8in + 10 ) = FLOAT ( irundt (4) )
r8ary ( nr8in + 11 ) = FLOAT ( irundt (5) )
r8ary ( nr8in + 12 ) = corn
nr8ot = nr8in + 12
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
CALL UFBSEQ ( iubfmn, r8ary, nr8ot, 1, ierusq,
+ bfstot )
IF ( ( satstg(1:5) .eq. 'CRYOS' ) .or.
+ ( satstg(1:5) .eq. 'SNTNL' ) ) THEN
CALL AT_CKST ( cpcid )
CALL UT_CIBF ( iubfmn, 'PCID', cpcid, 6, ier )
END IF
CALL UT_WBFR ( iubfmn, 'altm', 0, ierwbf )
CALL AT_CKST ( cstaq )
CALL WRITLC ( iubfmn, cstaq, 'STAQ' )
CALL AT_CKST ( csoftv )
CALL WRITLC ( iubfmn, csoftv, 'SOFTV' )
IF ( ( satstg(1:5) .eq. 'JASON' ) .or.
+ ( satstg(1:5) .eq. 'SARAL' ) ) THEN
CALL AT_CKST ( cnumid )
CALL WRITLC ( iubfmn, cnumid, 'NUMID' )
END IF
END IF
END IF
END DO
END DO
C*
RETURN
END