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* J. Ator/NCEP 07/23 Use new decod_ut library routines, * C* clean up and simplify logic * C* J. Ator/NCEP 06/24 Process long-duration balloons as * C* NC004030 * C* J. Ator/NCEP 01/25 Add SPFH to NC004030 * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'amcmn.cmn' CHARACTER*(*) cldt, bufrtn CHARACTER bull*(DCMXBF), cbull*(DCMXBF), bfstyp*8, + seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8, + subtyp*8, logmsg*200, lstn*40, + cdesc( MXDSC )*6, cval*8, wkstr*20, wgoslid*16, + bufrdn*(DCMXLN), bufrbn*(DCMXLN) INTEGER irundt ( 5 ), irptdt ( 5 ), + ibull ( DCMXBF / 4 ) LOGICAL bullok, msgok, gotwigos REAL*8 r8in ( MXMN, MXLV ), GETBMISS EQUIVALENCE ( cbull (1:4), ibull (1) ) INCLUDE 'ERMISS.FNC' 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* Open the BUFR tables file. 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 BUFR messages file. 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* Open the BUFR output file. CALL FL_GLUN ( iubfmn, iergln ) IF ( iergln .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg ) RETURN END IF C* Connect the BUFR tables file to the BUFR output file. CALL OPENBF ( iubfmn, 'NUL', iubftn ) r8bfms = GETBMISS() C* Specify that BUFR output messages are to be encoded using C* edition 4 and up to 100K bytes in size. Also specify the C* correct international message subtype and table version number. CALL PKVS01 ( 'BEN', 4 ) CALL PKVS01 ( 'MSBTI', 0 ) CALL PKVS01 ( 'MTV', 40 ) CALL MAXOUT ( 100000 ) C* Close the BUFR tables file. 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 ( iubfma ) 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 C* Set the local message subtype. SELECT CASE ( cborg(1:4) ) CASE ( 'KARP' ) IF (buhd(1:6) .eq. 'IUAX07') THEN subtyp = 'NC004103' ELSE subtyp = 'NC004004' END IF CASE ( 'KWPA' ) IF (buhd(1:6) .eq. 'IUXX41') THEN subtyp = 'NC004030' ELSE subtyp = 'NC004103' END IF CASE ( 'MMMX' ) subtyp = 'NC004004' CASE ( 'EGRR' ) subtyp = 'NC004006' CASE ( 'CWAO' ) subtyp = 'NC004009' CASE ( 'RKSL' ) subtyp = 'NC004011' CASE DEFAULT subtyp = 'NC004103' END SELECT nmsg = 0 nrpt = 0 bullok = .true. DO WHILE ( bullok ) C* Locate the next BUFR message within the bulletin, and C* store 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 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* 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. CALL UT_WBFR ( iubfmn, 'amdr', 1, ierwbf ) END IF bullok = .false. CYCLE END IF cbull = bull ( istart : ibptr ) IF ( subtyp .eq. 'NC004030' ) THEN msgok = .true. ELSE msgok = .false. C* Review the Section 3 descriptors from the message to ensure C* it contains AMDAR/ACARS data. Note that some such messages C* may not have a 311YYY descriptor. 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 ) SELECT CASE ( mainsq ) CASE ( 1:2, 5:10 ) msgok = .true. END SELECT ELSE IF ( ( cdesc(ii)(1:6) .eq. '001110' ) .and. + ( cborg(1:4) .eq. 'BABJ' ) ) THEN msgok = .true. mainsq = 99 END IF ii = ii + 1 END DO IF ( .not. msgok ) THEN 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 CYCLE END IF END IF C* Open the BUFR message for reading. CALL READERME ( ibull, iubfma, bfstyp, ibfdt, ierrme ) IF ( ierrme .ne. 0 ) CYCLE nmsg = nmsg + 1 DO WHILE ( msgok ) C* Get the next report from this BUFR message. IF ( IREADSB ( iubfma ) .ne. 0 ) THEN C* There are no more reports in this message. msgok = .false. CYCLE END IF nrpt = nrpt + 1 C* Don't create BUFR output for reports that are more than C* NHOURS before or more than 3 hours after the run time. CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'YEAR MNTH DAYS HOUR MINU SECO' ) CALL UT_CHECK_BUFRRPTDT ( 2, irundt, r8in(1,1), + r8in(2,1), r8in(3,1), r8in(4,1), r8in(5,1), + 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, subtyp, ibfdt ) C* Store the date and time. CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'YEAR MNTH DAYS HOUR MINU SECO' ) C* Get and store the WIGOS identifier. 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* Get and store the latitude and longitude. 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 ) IF ( subtyp .eq. 'NC004030' ) THEN C* Get and store the long-duration balloon data. CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'PRLC HGHT TMDB REHU SPFH WDIR WSPD BMFGR' ) CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'PRLC HGHT TMDB REHU SPFH WDIR WSPD BMFGR' ) CALL READLC ( iubfma, lstn, 'LSTN' ) ELSE C* Get and store the phase of flight. 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* Get and store the additional data values. CALL UT_BFCI ( iubfma, 'ACID', cval, ier ) CALL UT_CIBF ( iubfmn, 'ACID', cval, 8, ier ) 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 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 CALL UT_BFRI ( iubfma, 'ACNS', rval, ier ) CALL UT_RIBF ( iubfmn, 'ACNS', rval, ier ) CALL UT_BFRI ( iubfma, 'DGOT', rval, ier ) CALL UT_RIBF ( iubfmn, 'DGOT', rval, ier ) 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 CALL UT_BFRI ( iubfma, 'AFIC', rval, ier ) CALL UT_RIBF ( iubfmn, 'AFIC', rval, ier ) CALL UT_BFRI ( iubfma, 'MDEVG', rval, ier ) CALL UT_RIBF ( iubfmn, 'MDEVG', rval, ier ) CALL UT_BFRI ( iubfma, 'TADR', rval, ier ) CALL UT_RIBF ( iubfmn, 'TADR', rval, ier ) CALL UT_BFRI ( iubfma, 'PCAT', rval, ier ) CALL UT_RIBF ( iubfmn, 'PCAT', rval, ier ) 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 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 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 IF ( ( subtyp .eq. 'NC004103' ) .or. + ( subtyp .eq. 'NC004016' ) ) THEN C* Get and store the aircraft multi-level data. CALL AM_LVSQ ( iubfma, iubfmn, mainsq, iret ) ELSE C* Other data values specific to NC0040xx subtypes. CALL UT_BFRI ( iubfma, 'HEIT', rval, ier ) CALL UT_RIBF ( iubfmn, 'HEIT', rval, ier ) CALL UT_BFRI ( iubfma, 'PTRB', rval, ier ) CALL UT_RIBF ( iubfmn, 'PTRB', rval, ier ) CALL UT_BFRI ( iubfma, 'MIXR', rval, ier ) CALL UT_RIBF ( iubfmn, 'MIXR', rval, ier ) IF ( subtyp .eq. 'NC004004' ) THEN CALL UT_BFRI ( iubfma, 'MSTQ', rval, ier ) CALL UT_RIBF ( iubfmn, 'MSTQ', rval, ier ) END IF CALL UT_BFRI ( iubfma, 'ROLQ', rval, ier ) CALL UT_RIBF ( iubfmn, 'ROLQ', rval, ier ) 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 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 ) CALL UT_BFRI ( iubfma, 'TMDB', rval, ier ) IF ( ERMISS ( rval ) ) + CALL UT_BFRI ( iubfma, 'TMDBST', rval, ier ) CALL UT_RIBF ( iubfmn, 'TMDB', rval, ier ) CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'WDIR WSPD' ) CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, 'WDIR WSPD') END IF END IF C* Store the bulletin header. 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* Store the correction indicator. 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* Store the receipt time. 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* Restrictions on redistribution. CALL UT_RIBF ( iubfmn, 'RSRD', 128., ier ) IF ( subtyp .ne. 'NC004030' ) + CALL UT_RIBF ( iubfmn, 'EXPRSRD', 48., ier ) C* Write the BUFR output to the BUFR output stream. CALL UT_WBFR ( iubfmn, 'amdr', 0, ierwbf ) IF ( gotwigos ) CALL WRITLC ( iubfmn, wgoslid, 'WGOSLID' ) IF ( subtyp .eq. 'NC004030' ) + CALL WRITLC ( iubfmn, lstn, 'LSTN' ) END DO END DO END DO RETURN END