SUBROUTINE AM_DCOD ( cldt, bufrtn, nhours, iret )
C************************************************************************
C* AM_DCOD *
C* *
C* This routine decodes bulletins containing WMO-migrated aircraft *
C* BUFR messages into NCEP BUFR format. *
C* *
C* AM_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 01/13 *
C* J. Ator/NCEP 02/14 Process data from EGRR and CWAO *
C* J. Ator/NCEP 12/14 Store ACID, HBOT, HTOT and AFIC for all *
C* output subtypes, not just NC0040xx *
C* J. Ator/NCEP 08/15 Store RSRD and EXPRSRD for NC004103, *
C* process RKSL and EDZW reports *
C* J. Ator/NCEP 09/15 Process KARP reports which use 311010 *
C* J. Ator/NCEP 03/18 Store IUAX07 KARP reports as NC004103 *
C* J. Ator/NCEP 09/18 Store TASP, ACTH, AVLU and AVLV for *
C* NC004004 and NC004103 *
C* J. Ator/NCEP 10/19 Decode and store WIGOS IDs when present *
C* J. Ator/NCEP 06/20 Process Mode-S reports as NC004016 *
C* M. Weiss/IMSG 04/21 Process BABJ (China) AMDAR reports to *
C* NC004103 *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BRIDGE.PRM'
INCLUDE 'amcmn.cmn'
C*
CHARACTER*(*) cldt, bufrtn
C*
CHARACTER bull*(DCMXBF), cbull*(DCMXBF), bfstyp*8,
+ seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8,
+ rundt*12, sysdt*12, subtyp*8, logmsg*200,
+ cdesc( MXDSC )*6, cval*8, wkstr*20, wgoslid*16,
+ bufrdn*(DCMXLN), bufrbn*(DCMXLN)
C*
INTEGER irundt ( 5 ), irptdt ( 5 ),
+ ibull ( DCMXBF / 4 )
C*
LOGICAL bullok, msgok, gotwigos
C*
REAL*8 r8in ( MXMN, MXLV ), 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* 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 BUFR messages file.
C
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/dcamdr',
+ FORM = 'UNFORMATTED' )
CALL OPENBF ( iubfma, 'SEC3', iubftn )
CALL MTINFO ( bufrdn, 98, 99 )
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 )
r8bfms = GETBMISS()
C
C* Specify that NCEP BUFR (i.e. output) messages are to be
C* encoded using edition 4 and up to 100K bytes in size.
C* Also specify the correct international message subtype
C* and table version number.
C
CALL PKVS01 ( 'BEN', 4 )
CALL PKVS01 ( 'MSBTI', 0 )
CALL PKVS01 ( 'MTV', 18 )
CALL MAXOUT ( 100000 )
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
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
C
IF ( bullok ) THEN
C
C* If a date-time was entered on the command line, then use it
C* as the run date-time. Otherwise, use the system time as
C* 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
C
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.
ELSE
nmsg = 0
nrpt = 0
END IF
END IF
C
DO WHILE ( bullok )
C
C* Locate the next BUFR message within the bulletin, and
C* store it within an equivalenced integer array.
C
ipt1 = INDEX ( bull (ibptr:lenb), 'BUFR' )
IF ( ipt1 .eq. 0 ) THEN
bullok = .false.
IF ( nmsg .eq. 0 ) THEN
IF ( INDEX ( bull (ibptr:lenb), 'NIL' ) .ne. 0 ) THEN
logmsg = 'NIL bulletin'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
END IF
ELSE
WRITE ( logmsg, FMT = '(2A, I3, A, I4, A)' )
+ subtyp, ':', nmsg, ' messages and', nrpt, ' reports'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
C
C* Make sure that all BUFR output for this bulletin has
C* been written to the BUFR output stream before going back
C* to DC_GBUL and waiting for a new bulletin on the pipe.
C
CALL UT_WBFR ( iubfmn, 'amdr', 1, ierwbf )
END IF
ELSE
istart = ibptr + ipt1 - 1
ibptr = istart + 4
cbull = bull ( istart : lenb )
C
msgok = .false.
C
C* Retrieve the Section 3 descriptors from the message to
C* ensure it contains AMDAR/ACARS data. Also retrieve
C* AMDAR BABJ which does not have a 3110 descriptor.
C
CALL UPDS3 ( ibull, MXDSC, cdesc, ndesc )
ii = 1
DO WHILE ( ( ii .le. ndesc ) .and. ( .not. msgok ) )
IF ( cdesc(ii)(1:4) .eq. '3110' ) THEN
CALL ST_INTG ( cdesc(ii)(5:6), mainsq, ier )
IF ( ( ( mainsq .ge. 5 ) .and. ( mainsq .le. 10 ) )
+ .or.
+ ( ( mainsq .ge. 1 ) .and. ( mainsq .le. 2 ) ) )
+ msgok = .true.
ELSE IF ( ( cdesc(ii)(1:6) .eq. '001110' ) .and.
+ ( cborg(1:4) .eq. 'BABJ' ) ) THEN ! BABJ
msgok = .true.
mainsq = 99
END IF
ii = ii + 1
END DO
C
IF ( msgok ) THEN
C
C* Open the BUFR message for reading.
C
CALL READERME ( ibull, iubfma, bfstyp, ibfdt, ierrme )
IF ( ierrme .ne. 0 ) THEN
msgok = .false.
ELSE
nmsg = nmsg + 1
END IF
ELSE
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
END IF
C
DO WHILE ( msgok )
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
msgok = .false.
ELSE
nrpt = nrpt + 1
C
C* Don't create BUFR output for reports that are more
C* than NHOURS before or more than 3 hours after the
C* run time.
C
CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv,
+ 'YEAR MNTH DAYS HOUR MINU' )
rptyr = UT_BMRI ( r8in (1,1) )
rptmo = UT_BMRI ( r8in (2,1) )
rptdy = UT_BMRI ( r8in (3,1) )
rpthr = UT_BMRI ( r8in (4,1) )
rptmi = UT_BMRI ( r8in (5,1) )
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)
C
SELECT CASE ( cborg(1:4) )
CASE ( 'KARP' )
IF (buhd(1:6) .eq. 'IUAX07') THEN
subtyp = 'NC004103'
ELSE IF (buhd(1:6) .eq. 'IUAX96') THEN
subtyp = 'NC004016'
ELSE
subtyp = 'NC004004'
END IF
CASE ( 'MMMX' )
subtyp = 'NC004004'
CASE ( 'EGRR' )
subtyp = 'NC004006'
CASE ( 'CWAO' )
subtyp = 'NC004009'
CASE ( 'RKSL' )
subtyp = 'NC004011'
CASE DEFAULT
subtyp = 'NC004103'
END SELECT
C
CALL OPENMB ( iubfmn, subtyp, ibfdt )
C
C* Store the date and time.
C
CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv,
+ 'YEAR MNTH DAYS HOUR MINU' )
C
C* Get and store the WIGOS identifier.
C
CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv,
+ 'WGOSIDS WGOSISID WGOSISNM' )
IF ( ( IBFMS ( r8in (1,1) ) .eq. 0 ) .or.
+ ( IBFMS ( r8in (2,1) ) .eq. 0 ) .or.
+ ( IBFMS ( r8in (3,1) ) .eq. 0 ) ) THEN
gotwigos = .true.
CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv,
+ 'WIGOSID' )
CALL READLC ( iubfma, wgoslid, 'WGOSLID' )
ELSE
gotwigos = .false.
END IF
C
C* Get and store the latitude and longitude.
C
CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv,
+ 'CLATH CLONH' )
IF ( ( IBFMS ( r8in(1,1) ) .eq. 1 ) .and.
+ ( IBFMS ( r8in(2,1) ) .eq. 1 ) ) THEN
CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv,
+ 'CLAT CLON' )
END IF
IF ( subtyp .eq. 'NC004004' ) THEN
wkstr = 'CLAT CLON'
ELSE
wkstr = 'CLATH CLONH'
END IF
CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, wkstr )
C
C* Get and store the phase of flight.
C
CALL UT_BFRI ( iubfma, 'DPOF', rval, ier )
IF ( ERMISS ( rval ) )
+ CALL UT_BFRI ( iubfma, 'POAF', rval, ier )
IF ( ( subtyp .ne. 'NC004006' ) .and.
+ ( subtyp .ne. 'NC004009' ) ) THEN
wkstr = 'DPOF'
ELSE
wkstr = 'POAF'
IF ( ( rval .ge. 11 ) .and.
+ ( rval .le. 14 ) ) THEN
rval = 6
ELSE IF ( ( rval .ge. 7 ) .and.
+ ( rval .le. 10 ) ) THEN
rval = 5
END IF
END IF
CALL UT_RIBF ( iubfmn, wkstr, rval, ier )
C
C* Get and store the additional data values.
C
CALL UT_BFCI ( iubfma, 'ACID', cval, ier )
CALL UT_CIBF ( iubfmn, 'ACID', cval, 8, ier )
C
IF ( mainsq .eq. 99 ) THEN
CALL UT_BFCI ( iubfma, 'ACTN', cval, ier )
CALL UT_CIBF ( iubfmn, 'ACRN', cval, 8, ier )
ELSE
CALL UT_BFCI ( iubfma, 'ACRN', cval, ier )
CALL UT_CIBF ( iubfmn, 'ACRN', cval, 8, ier )
END IF
C
IF ( ( subtyp .ne. 'NC004009' ) .and.
+ ( subtyp .ne. 'NC004011' ) ) THEN
CALL UT_BFCI ( iubfma, 'OAPT', cval, ier )
CALL UT_CIBF ( iubfmn, 'OAPT', cval, 8, ier )
CALL UT_BFCI ( iubfma, 'DAPT', cval, ier )
CALL UT_CIBF ( iubfmn, 'DAPT', cval, 8, ier )
END IF
C
CALL UT_BFRI ( iubfma, 'ACNS', rval, ier )
CALL UT_RIBF ( iubfmn, 'ACNS', rval, ier )
C
CALL UT_BFRI ( iubfma, 'DGOT', rval, ier )
CALL UT_RIBF ( iubfmn, 'DGOT', rval, ier )
C
IF ( ( subtyp .ne. 'NC004004' ) .and.
+ ( subtyp .ne. 'NC004011' ) ) THEN
CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv,
+ 'HBOT HTOT' )
CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv,
+ 'HBOT HTOT' )
END IF
C
CALL UT_BFRI ( iubfma, 'AFIC', rval, ier )
CALL UT_RIBF ( iubfmn, 'AFIC', rval, ier )
C
CALL UT_BFRI ( iubfma, 'MDEVG', rval, ier )
CALL UT_RIBF ( iubfmn, 'MDEVG', rval, ier )
C
CALL UT_BFRI ( iubfma, 'TADR', rval, ier )
CALL UT_RIBF ( iubfmn, 'TADR', rval, ier )
C
CALL UT_BFRI ( iubfma, 'PCAT', rval, ier )
CALL UT_RIBF ( iubfmn, 'PCAT', rval, ier )
C
CALL UT_BFRI ( iubfma, 'SECO', rval, ier )
CALL UT_RIBF ( iubfmn, 'SECO', rval, ier )
C
IF ( ( subtyp .eq. 'NC004103' ) .or.
+ ( subtyp .eq. 'NC004011' ) .or.
+ ( subtyp .eq. 'NC004016' ) ) THEN
CALL UT_BFRI ( iubfma, 'OSQN', rval, ier )
CALL UT_RIBF ( iubfmn, 'OSQN', rval, ier )
END IF
C
IF ( ( subtyp .ne. 'NC004006' ) .and.
+ ( subtyp .ne. 'NC004009' ) ) THEN
CALL UT_BFRI ( iubfma, 'INTV', rval, ier )
CALL UT_RIBF ( iubfmn, 'INTV', rval, ier )
END IF
C
IF ( ( subtyp .eq. 'NC004103' ) .or.
+ ( subtyp .eq. 'NC004004' ) .or.
+ ( subtyp .eq. 'NC004016' ) ) THEN
CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv,
+ 'TASP AVLU AVLV ACTH' )
CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv,
+ 'TASP AVLU AVLV ACTH' )
END IF
C
IF ( ( subtyp .eq. 'NC004103' ) .or.
+ ( subtyp .eq. 'NC004016' ) ) THEN
C
C* Get and store the aircraft multi-level data.
C
CALL AM_LVSQ ( iubfma, iubfmn, mainsq, iret )
ELSE
C
C* Other data values specific to NC0040xx subtypes.
C
CALL UT_BFRI ( iubfma, 'HEIT', rval, ier )
CALL UT_RIBF ( iubfmn, 'HEIT', rval, ier )
C
CALL UT_BFRI ( iubfma, 'PTRB', rval, ier )
CALL UT_RIBF ( iubfmn, 'PTRB', rval, ier )
C
CALL UT_BFRI ( iubfma, 'MIXR', rval, ier )
CALL UT_RIBF ( iubfmn, 'MIXR', rval, ier )
C
IF ( subtyp .eq. 'NC004004' ) THEN
CALL UT_BFRI ( iubfma, 'MSTQ', rval, ier )
CALL UT_RIBF ( iubfmn, 'MSTQ', rval, ier )
END IF
C
CALL UT_BFRI ( iubfma, 'ROLQ', rval, ier )
CALL UT_RIBF ( iubfmn, 'ROLQ', rval, ier )
C
IF ( subtyp .eq. 'NC004004' ) THEN
CALL UFBREP ( iubfma, r8in, MXMN, MXLV, nlv,
+ '.DTMTRBX TRBXST' )
CALL AM_TRBX ( iubfmn, r8in(2,1), 'TRBX10', ier)
CALL AM_TRBX ( iubfmn, r8in(2,2), 'TRBX21', ier)
CALL AM_TRBX ( iubfmn, r8in(2,3), 'TRBX32', ier)
CALL AM_TRBX ( iubfmn, r8in(2,4), 'TRBX43', ier)
END IF
C
CALL UT_BFRI ( iubfma, 'HMSL', rval, ier )
IF ( ERMISS ( rval ) )
+ CALL UT_BFRI ( iubfma, 'FLVLST', rval, ier )
IF ( ERMISS ( rval ) )
+ CALL UT_BFRI ( iubfma, 'IALT', rval, ier )
IF ( subtyp .eq. 'NC004011' ) THEN
wkstr = 'FLVLST'
ELSE IF ( subtyp .eq. 'NC004004' ) THEN
wkstr = 'IALT'
ELSE
wkstr = 'HMSL'
END IF
CALL UT_RIBF ( iubfmn, wkstr, rval, ier )
C
CALL UT_BFRI ( iubfma, 'TMDB', rval, ier )
IF ( ERMISS ( rval ) )
+ CALL UT_BFRI ( iubfma, 'TMDBST', rval, ier )
CALL UT_RIBF ( iubfmn, 'TMDB', rval, ier )
C
CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv,
+ 'WDIR WSPD' )
CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv,
+ 'WDIR WSPD' )
END IF
C
C* Store the 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* Store the correction indicator.
C
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
C* Store the 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* Restrictions on redistribution.
C
CALL UT_RIBF ( iubfmn, 'RSRD', 128., ier )
CALL UT_RIBF ( iubfmn, 'EXPRSRD', 48., ier )
C
C* Write the BUFR output to the BUFR output stream.
C
CALL UT_WBFR ( iubfmn, 'amdr', 0, ierwbf )
IF ( gotwigos )
+ CALL WRITLC ( iubfmn, wgoslid, 'WGOSLID' )
END IF
END IF
END DO
END IF
END DO
END DO
C*
RETURN
END