SUBROUTINE AF_BUFR ( iunbfo, irundt, irptdt, + seqnum, buhd, cborg, bulldt, bbb, + report, lenr, iret ) C************************************************************************ C* AF_BUFR * C* * C* This subroutine retrieves interface-stored data, converts it into * C* BUFR output, and then writes the BUFR output to the BUFR output * C* stream. * C* * C* AF_BUFR ( IUNBFO, IRUNDT, IRPTDT, * C* SEQNUM, BUHD, CBORG, BULLDT, BBB, * C* REPORT, LENR, IRET ) * C* * C* Input parameters: * C* IUNBFO INTEGER BUFR output file unit number * C* IRUNDT (5) INTEGER Run date-time * C* (YYYY, MM, DD, HH, MM ) * C* IRPTDT (5) INTEGER Report date-time * C* (YYYY, MM, DD, HH, MM ) * C* SEQNUM CHAR* Bulletin sequence number * C* BUHD CHAR* Bulletin header * C* CBORG CHAR* Bulletin originator * C* BULLDT CHAR* Bulletin date-time * C* BBB CHAR* Bulletin BBB indicator * C* REPORT CHAR* Report * C* LENR INTEGER Length of report * C* * C* Output parameters: * C* IRET INTEGER Return code * C* 0 = normal return * C** * C* Log: * C* J. Ator/NP12 09/96 * C* J. Ator/NP12 10/96 Add "CORN", add "/IC", "/WX" for PIREP * C* J. Ator/NP12 11/96 EXIST -> AF_EXST, add logic for RECCO * C* J. Ator/NP12 01/97 GPGRAV -> GRAVTY, VGVL -> MDEVG, add * C* icing, SST, sfc wind, clouds for RECCO * C* J. Ator/NP12 08/97 New interface format, style changes * C* J. Ator/NCEP 12/97 AF_C2R8 -> UT_C2R8 * C* J. Ator/NCEP 01/98 Add calls to UT_CIBF and UT_RIBF, * C* remove calls to AF_BFOT * C* J. Ator/NCEP 12/98 Move init. of mbstr, lmbstr into code * C* J. Ator/NCEP 08/99 New /INTF tables for DAYW, AFIC, DGOT, * C* /INTF base and top heights now in feet * C* J. Ator/NCEP 09/99 Convert PIREP cloud data * C* J. Ator/NCEP 06/01 Use UT_WBFR and BUFR.CMN, clean up * C* J. Ator/NCEP 01/02 Use simplified UT_CIBF * C* J. Ator/NCEP 02/02 Store YRXX85 bulletin data as NC004007 * C* J. Ator/NCEP 06/02 Add mnemonics RSRD and EXPRSRD to * C* NC004007 output * C* J. Ator/NCEP 02/03 Add mnemonics RSRD and EXPRSRD to * C* NC004003 output * C* J. Cahoon/NCEP 01/12 Added HDOB bulletin data as NC004015 * C* J. Cahoon/NCEP 06/12 HDOB qual marks from code to flag tbl * C* J. Ator/NCEP 10/12 Use GETBMISS() to get BUFR missing value* C* M. Weiss/IMSG 03/2017 For HDOB processing; * C* 1. Inserted UT_RIBF call for mean sea * C* level pressure (PMSL) * C* 2a. Inserted UT_RIBF call for aircraft * C* flight level(FLVL), but without PR_HGFM.* C* 2b. Inserted if statement excluding * C* HDOB for general UT_RIBF FLVL which * C* includes PR_HGFM. * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BUFR.CMN' INCLUDE 'afcmn.cmn' INCLUDE 'afcmn_bufr.cmn' C* INTEGER irundt (*), irptdt (*) C* CHARACTER*(*) report, seqnum, buhd, cborg, bulldt, bbb C* CHARACTER cdata*8, bfstyp*8 C* REAL*8 r8cld ( NCCLD, MXNLYR ), r8trb ( NCTRB, MXNLYR ), + r8icg ( NCICG, MXNLYR ), r8pwx ( NCPWX, MXPRWE ), + UT_RIBM, PKFTBV C* INTEGER iprpct / 0 / C* SAVE iprpct C* INCLUDE 'ERMISS.FNC' C----------------------------------------------------------------------- iret = 0 C C* Do not create BUFR if the latitude or longitude is missing. C IF ( ( ERMISS ( rivals ( irslat ) ) ) .or. + ( ERMISS ( rivals ( irslon ) ) ) ) THEN RETURN END IF C IF ( bultyp .eq. AMDAR ) THEN C C* Do not create BUFR if both the flight level and the C* pressure altitude are missing. C IF ( ( ERMISS ( rivals ( irpsal ) ) ) .and. + ( ERMISS ( rivals ( irflvl ) ) ) ) THEN RETURN END IF ELSE IF ( ( bultyp .eq. AIREP ) .or. + ( bultyp .eq. PIREP ) ) THEN C C* Do not create BUFR if the flight level is missing. C IF ( ERMISS ( rivals ( irflvl ) ) ) THEN RETURN END IF ELSE IF ( bultyp .eq. RECCO ) THEN C C* Do not create BUFR if the pressure altitude is missing. C IF ( ERMISS ( rivals ( irpsal ) ) ) THEN RETURN END IF END IF C C* Set the BUFR message subtype. C IF ( buhd (1:6) .eq. 'YRXX85' ) THEN bfstyp = 'NC004007' ELSE IF ( bultyp .eq. AIREP ) THEN bfstyp = 'NC004001' ELSE IF ( bultyp .eq. PIREP ) THEN bfstyp = 'NC004002' ELSE IF ( bultyp .eq. AMDAR ) THEN bfstyp = 'NC004003' ELSE IF ( bultyp .eq. RECCO ) THEN bfstyp = 'NC004005' ELSE IF ( bultyp .eq. HDOBB ) THEN bfstyp = 'NC004015' END IF C C* Set the BUFR message date-time. C ibfdt = ( irptdt (1) * 1000000 ) + ( irptdt (2) * 10000 ) + + ( irptdt (3) * 100 ) + irptdt (4) C C* Open a BUFR message for output. C CALL OPENMB ( iunbfo, bfstyp, ibfdt ) C C* Initialize BUFR output arrays. C DO jj = 1, MXNLYR DO ii = 1, NCCLD r8cld ( ii, jj ) = r8bfms END DO END DO DO jj = 1, MXNLYR DO ii = 1, NCTRB r8trb ( ii, jj ) = r8bfms END DO END DO DO jj = 1, MXNLYR DO ii = 1, NCICG r8icg ( ii, jj ) = r8bfms END DO END DO DO jj = 1, MXPRWE DO ii = 1, NCPWX r8pwx ( ii, jj ) = r8bfms END DO END DO C C* Bulletin ID information. C CALL UT_CIBF ( iunbfo, 'SEQNUM', seqnum, 8, iercbf ) CALL UT_CIBF ( iunbfo, 'BUHD', buhd, 8, iercbf ) CALL UT_CIBF ( iunbfo, 'BORG', cborg, 8, iercbf ) CALL UT_CIBF ( iunbfo, 'BULTIM', bulldt, 8, iercbf ) CALL UT_CIBF ( iunbfo, 'BBB', bbb, 8, iercbf ) C C* Raw report. C IF ( lenr .gt. MXBFRR ) THEN WRITE ( UNIT = logmsg, FMT = '( A, I4, A )' ) + 'Only stored first ', MXBFRR, ' bytes of raw report' CALL DC_WLOG ( 4, 'AF', 1, logmsg, ierwlg ) END IF CALL UT_CIBF ( iunbfo, 'RRSTG', report, lenr, iercbf ) C C* Report date-time. C CALL UT_RIBF ( iunbfo, 'YEAR', FLOAT ( irptdt (1) ), ierrbf ) CALL UT_RIBF ( iunbfo, 'MNTH', FLOAT ( irptdt (2) ), ierrbf ) CALL UT_RIBF ( iunbfo, 'DAYS', FLOAT ( irptdt (3) ), ierrbf ) CALL UT_RIBF ( iunbfo, 'HOUR', FLOAT ( irptdt (4) ), ierrbf ) CALL UT_RIBF ( iunbfo, 'MINU', FLOAT ( irptdt (5) ), ierrbf ) IF ( bultyp .eq. HDOBB ) THEN CALL UT_RIBF ( iunbfo, 'SECO', rivals ( irseco ), ierrbf ) END IF C C* Receipt date-time. C CALL UT_RIBF ( iunbfo, 'RCYR', FLOAT ( irundt (1) ), ierrbf ) CALL UT_RIBF ( iunbfo, 'RCMO', FLOAT ( irundt (2) ), ierrbf ) CALL UT_RIBF ( iunbfo, 'RCDY', FLOAT ( irundt (3) ), ierrbf ) CALL UT_RIBF ( iunbfo, 'RCHR', FLOAT ( irundt (4) ), ierrbf ) CALL UT_RIBF ( iunbfo, 'RCMI', FLOAT ( irundt (5) ), ierrbf ) CALL UT_RIBF ( iunbfo, 'RCTS', FLOAT ( 0 ), ierrbf ) C IF ( ( bfstyp .eq. 'NC004003' ) .or. + ( bfstyp .eq. 'NC004007' ) ) THEN C C* Restrictions on redistribution. C CALL UT_RIBF ( iunbfo, 'RSRD', 128., ierrbf ) CALL UT_RIBF ( iunbfo, 'EXPRSRD', 48., ierrbf ) END IF C IF ( bultyp .eq. PIREP ) THEN C C* Type of aircraft. C CALL UT_CIBF ( iunbfo, 'ACTP', civals ( icactp ), 8, iercbf) C C* Report ID. C IF ( iprpct .eq. 9999 ) THEN iprpct = 1 ELSE iprpct = iprpct + 1 END IF cdata (1:6) = 'P P' WRITE ( UNIT = cdata (2:5), FMT = '(I4.4)', IOSTAT = ier ) + iprpct IF ( ier .ne. 0 ) THEN cdata (2:5) = ' ' END IF CALL UT_CIBF ( iunbfo, 'RPID', cdata, 6, iercbf ) ELSE IF ( ( bultyp .eq. RECCO ) .or. + ( bultyp .eq. HDOBB ) ) THEN C C* RECCO or HDOB identifier. C CALL UT_CIBF ( iunbfo, 'RPID', civals ( icrpid ), 8, iercbf) ELSE C C* Aircraft identifier. C CALL UT_CIBF ( iunbfo, 'ACID', civals ( icacid ), 8, iercbf) CALL UT_CIBF ( iunbfo, 'RPID', civals ( icacid ), 8, iercbf) END IF C C* Latitude. C CALL UT_RIBF ( iunbfo, 'CLAT', rivals ( irslat ), ierrbf ) C C* Longitude. C CALL UT_RIBF ( iunbfo, 'CLON', rivals ( irslon ), ierrbf ) C C* Flight level. C IF ( bultyp .ne. HDOBB ) THEN CALL UT_RIBF ( iunbfo, 'FLVL', + PR_HGFM ( rivals ( irflvl ) ), ierrbf ) ENDIF C C* Pressure altitude. C CALL UT_RIBF ( iunbfo, 'PSAL', + PR_HGFM ( rivals ( irpsal ) ), ierrbf ) C C* Corrected report indicator. C corn = 0.0 IF ( bbb (1:1) .eq. 'C' ) THEN corn = 1.0 END IF CALL UT_RIBF ( iunbfo, 'CORN', corn, ierrbf ) C C* Temperature. C CALL UT_RIBF ( iunbfo, 'TMDB', + PR_TMCK ( rivals ( irtmpc ) ), ierrbf ) C C* Wind direction. C CALL UT_RIBF ( iunbfo, 'WDIR', rivals ( irdrct ), ierrbf ) C C* Wind speed. C CALL UT_RIBF ( iunbfo, 'WSPD', + PR_KNMS ( rivals ( irsknt ) ), ierrbf ) C IF ( ( bultyp .eq. AMDAR ) .or. + ( bultyp .eq. RECCO ) .or. + ( bultyp .eq. HDOBB ) ) THEN C C* Dewpoint temperature. C CALL UT_RIBF ( iunbfo, 'TMDP', + PR_TMCK ( rivals ( irdwpc ) ), ierrbf ) C C* Relative humidity. C CALL UT_RIBF ( iunbfo, 'REHU', rivals ( irrelh ), ierrbf ) END IF C IF ( bultyp .eq. AMDAR ) THEN C C* Phase of aircraft flight. C CALL UT_RIBF ( iunbfo, 'POAF', rivals ( irpoaf ), ierrbf ) C C* Aircraft navigational system. C CALL UT_RIBF ( iunbfo, 'ACNS', rivals ( iracns ), ierrbf ) C C* Type of aircraft data relay system. C CALL UT_RIBF ( iunbfo, 'TADR', rivals ( irtadr ), ierrbf ) C C* Temperature precision. C pcat = rivals ( irpcat ) IF ( INT ( pcat ) .eq. 0 ) THEN bfpcat = 2.0 ELSE bfpcat = pcat END IF CALL UT_RIBF ( iunbfo, 'PCAT', bfpcat, ierrbf ) C C* Maximum derived equivalent vertical gust speed. C CALL UT_RIBF ( iunbfo, 'MDEVG', rivals ( irmdvg ), ierrbf ) END IF C C* Turbulence. C ntrb = INT ( rivals ( irntrb ) ) IF ( ntrb .gt. 0 ) THEN DO jj = 1, ntrb bfdgot = RMISSD idgot = INT ( rivals ( irdgot ( jj ) ) ) itpot = INT ( rivals ( irtpot ( jj ) ) ) IF ( idgot .eq. 8 ) THEN IF ( itpot .eq. 1 ) THEN bfdgot = 12.0 ELSE IF ( itpot .eq. 4 ) THEN bfdgot = 13.0 ELSE bfdgot = 14.0 END IF ELSE IF ( idgot .eq. 0 ) THEN bfdgot = 8.0 ELSE IF ( idgot .eq. 2 ) THEN bfdgot = 9.0 ELSE IF ( ( idgot .eq. 3 ) .or. + ( idgot .eq. 4 ) ) THEN bfdgot = 10.0 ELSE IF ( ( idgot .eq. 5 ) .or. + ( idgot .eq. 6 ) ) THEN bfdgot = 11.0 END IF IF ( .not. ERMISS ( bfdgot ) ) THEN IF ( itpot .eq. 1 ) THEN bfdgot = bfdgot - 4.0 ELSE IF ( itpot .eq. 4 ) THEN bfdgot = bfdgot - 8.0 END IF END IF END IF IF ( bultyp .eq. PIREP ) THEN r8trb ( LUDGOT, jj ) = UT_RIBM ( bfdgot ) r8trb ( LUHBOT, jj ) = + UT_RIBM ( PR_HGFM ( rivals ( irhbot ( jj ) ) ) ) r8trb ( LUHTOT, jj ) = + UT_RIBM ( PR_HGFM ( rivals ( irhtot ( jj ) ) ) ) END IF END DO IF ( bultyp .eq. PIREP ) THEN CALL UFBINT ( iunbfo, r8trb, NCTRB, ntrb, ierufb, + CTRBST ) ELSE CALL UT_RIBF ( iunbfo, 'DGOT', bfdgot, ierrbf ) END IF END IF C IF ( bultyp .eq. RECCO ) THEN C C* Mandatory level pressure and height. C CALL UT_RIBF ( iunbfo, 'VSIG', rivals ( irvsig ), ierrbf ) CALL UT_RIBF ( iunbfo, 'PRLC', + PR_M100 ( rivals ( irpres ) ), ierrbf ) hgtm = rivals ( irhgtm ) IF ( .not. ERMISS ( hgtm ) ) THEN C C* Convert HGTM (meters) to GP10 ((meters/second)**2). C gp10 = hgtm * GPGRAV CALL UT_RIBF ( iunbfo, 'GP10', gp10, ierrbf ) END IF C C* Surface wind direction. C CALL UT_RIBF ( iunbfo, 'WDIR1', rivals ( irwdr1 ), ierrbf ) C C* Surface wind speed. C CALL UT_RIBF ( iunbfo, 'WSPD1', + PR_KNMS ( rivals ( irwsk1 ) ), ierrbf ) C C* Mean sea level pressure. C C* PMSL is in units of millibars within the interface C* format, but it needs to be in units of Pascals within C* the BUFR format. C CALL UT_RIBF ( iunbfo, 'PMSL', + PR_M100 ( rivals ( irpmsl ) ), ierrbf ) C C* Sea-surface temperature. C CALL UT_RIBF ( iunbfo, 'SST1', + PR_TMCK ( rivals ( irsstc ) ), ierrbf ) C C* Day of the week. C dayw = rivals ( irdayw ) IF ( .not. ERMISS ( dayw ) ) THEN bfdayw = dayw - 1 CALL UT_RIBF ( iunbfo, 'DAYW', bfdayw, ierrbf ) END IF END IF C IF ( bultyp .eq. HDOBB ) THEN C C* HDOB Flight level. "High Altitude: <= 550 mb" C C* NOTE: PR_HGFM not needed, FLVL already in meters CCC CALL UT_RIBF ( iunbfo, 'FLVL', CCC + PR_HGFM ( rivals ( irflvl ) ), ierrbf ) CALL UT_RIBF ( iunbfo, 'FLVL', rivals ( irflvl ), ierrbf ) C C* HDOB Mean sea level pressure. "Low Altitude: > 550 mb" C C* PMSL is in units of millibars within the interface C* format, but it needs to be in units of Pascals within C* the BUFR format. C CALL UT_RIBF ( iunbfo, 'PMSL', + PR_M100 ( rivals ( irpmsl ) ), ierrbf ) C C* Pressure in mb C CALL UT_RIBF ( iunbfo, 'PRLC', + PR_M100 ( rivals ( irpres ) ), ierrbf ) C C* GPH from irgphm is in meters, so convert to meters/sec^2 C hgtm = rivals ( irgphm ) gp10 = hgtm * GPGRAV CALL UT_RIBF ( iunbfo, 'GP10', gp10, ierrbf ) C C* Peak 10s avg wind and surface speeds in encoding interval C wndinterval = 10.0 CALL UT_RIBF ( iunbfo, '.DTSPKWD', wndinterval, ierrbf ) CALL UT_RIBF ( iunbfo, 'PKWDSP', + PR_KNMS ( rivals ( irpkwd ) ), ierrbf ) CALL UT_RIBF ( iunbfo, '.DTSPKSW', wndinterval, ierrbf ) CALL UT_RIBF ( iunbfo, 'PKSWSP', + PR_KNMS ( rivals ( irpksw ) ), ierrbf ) C C* Total rain rate from SFMR decoded in HDOB C CALL UT_RIBF ( iunbfo, 'TRRT', rivals (irsfmr), ierrbf ) C C* Quality control flags for positional and meterological C* First sets the right bits then sets the bufr C ihdsp = INT ( rivals (irhdsp)) ihdsm = INT ( rivals (irhdsm)) IF ( ihdsp .eq. 0 ) THEN qdop = PKFTBV (7,1) ELSE IF ( ihdsp .eq. 1 ) THEN qdop = PKFTBV (7,2) ELSE IF ( ihdsp .eq. 2 ) THEN qdop = PKFTBV (7,3) ELSE IF ( ihdsp .eq. 3 ) THEN qdop = PKFTBV (7,2) + PKFTBV (7,3) END IF IF ( ihdsm .eq. 0 ) THEN qdom = PKFTBV (15,1) ELSE IF ( ihdsm .eq. 1 ) THEN qdom = PKFTBV (15,2) ELSE IF ( ihdsm .eq. 2 ) THEN qdom = PKFTBV (15,3) ELSE IF ( ihdsm .eq. 3 ) THEN qdom = PKFTBV (15,4) ELSE IF ( ihdsm .eq. 4 ) THEN qdom = PKFTBV (15,2) + PKFTBV (15,3) ELSE IF ( ihdsm .eq. 5 ) THEN qdom = PKFTBV (15,2) + PKFTBV (15,4) ELSE IF ( ihdsm .eq. 6 ) THEN qdom = PKFTBV (15,3) + PKFTBV (15,4) ELSE IF ( ihdsm .eq. 9 ) THEN qdom = PKFTBV (15,2) + PKFTBV (15,3) + PKFTBV (15,4) END IF CALL UT_RIBF ( iunbfo, 'QHDOP', qdop, ierrbf ) CALL UT_RIBF ( iunbfo, 'QHDOM', qdom, ierrbf ) END IF C IF ( ( bultyp .eq. PIREP ) .or. ( bultyp .eq. RECCO ) ) THEN C C* Present weather. C CALL AF_BFWX ( iunbfo, r8pwx, ierfpw ) C C* Airframe icing. C nicg = INT ( rivals ( irnicg ) ) IF ( nicg .gt. 0 ) THEN DO jj = 1, nicg bfafic = RMISSD iafic = INT ( rivals ( irafic ( jj ) ) ) itpoi = INT ( rivals ( irtpoi ( jj ) ) ) IF ( iafic .eq. 0 ) THEN bfafic = 0.0 ELSE IF ( iafic .eq. 1 ) THEN bfafic = 10.0 ELSE IF ( ( iafic .eq. 2 ) .or. + ( iafic .eq. 3 ) ) THEN bfafic = 1.0 ELSE IF ( ( iafic .eq. 4 ) .or. + ( iafic .eq. 5 ) ) THEN bfafic = 4.0 ELSE IF ( ( iafic .eq. 7 ) .or. + ( iafic .eq. 8 ) ) THEN bfafic = 7.0 END IF IF ( INT ( bfafic ) .gt. 0 ) THEN IF ( ( itpoi .ge. 4 ) .and. + ( itpoi .le. 6 ) ) THEN bfafic = bfafic + 1.0 ELSE IF ( ( itpoi .ge. 7 ) .and. + ( itpoi .le. 9 ) ) THEN bfafic = bfafic + 2.0 END IF END IF r8icg ( LIAFIC, jj ) = UT_RIBM ( bfafic ) r8icg ( LIHBOI, jj ) = + UT_RIBM ( PR_HGFM ( rivals ( irhboi ( jj ) ) ) ) r8icg ( LIHTOI, jj ) = + UT_RIBM ( PR_HGFM ( rivals ( irhtoi ( jj ) ) ) ) END DO CALL UFBINT ( iunbfo, r8icg, NCICG, nicg, ierufb, + CICGST ) END IF C C* Cloud data. C ncld = INT ( rivals ( irncld ) ) IF ( ncld .gt. 0 ) THEN DO jj = 1, ncld r8cld ( LCCLAM, jj ) = + UT_RIBM ( rivals ( irclam ( jj ) ) ) r8cld ( LCCLTP, jj ) = + UT_RIBM ( rivals ( ircltp ( jj ) ) ) r8cld ( LCHOCB, jj ) = + UT_RIBM ( PR_HGFM ( rivals ( irhcbf ( jj ) ) ) ) r8cld ( LCHOCT, jj ) = + UT_RIBM ( PR_HGFM ( rivals ( irhctf ( jj ) ) ) ) END DO CALL UFBINT ( iunbfo, r8cld, NCCLD, ncld, ierufb, + CCLDST ) END IF C C* Flight visibility. C vsmil = rivals ( irvsby ) IF ( vsmil .gt. 50 ) THEN vsmtr = 81900.0 ELSE vsmtr = PR_HGFM ( PR_HGSF ( vsmil ) ) END IF CALL UT_RIBF ( iunbfo, 'HOVI', vsmtr, ierrbf ) END IF C CALL UT_WBFR ( iunbfo, 'aircraft', 0, ierwbf ) C* RETURN END