SUBROUTINE MN_BUFR ( iunbfo, irundt, cmsobn, iret ) C************************************************************************ C* MN_BUFR * C* * C* This subroutine retrieves data from the interface arrays, converts * C* it into BUFR output, and then writes the BUFR output to the BUFR * C* output stream. * C* * C* MN_BUFR ( IUNBFO, IRUNDT, CMSOBN, 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* CMSOBN CHAR*18 Mesonet data file basename * C* * C* Output parameters: * C* IRET INTEGER Return code: * C* 0 = normal return * C** * C* Log: * C* J. Ator/NCEP 06/01 * C* J. Ator/NCEP 11/01 Add subtype for Iowa DOT * C* J. Ator/NCEP 01/02 Add subtype for Minnesota DOT * C* J. Ator/NCEP 02/02 Add subtype for AWX, fix SPRVSTG test * C* J. Ator/NCEP 03/02 Use BUFR class 255 instead of 000 * C* J. Ator/NCEP 06/02 Add subtypes for NOS-PORTS and APG, * C* add RSRD mnemonic to output * C* J. Ator/NCEP 08/02 Add subtypes for NWS-COOP and HADS * C* C. Caruso Magee/NCEP 12/02 Uncomment code that writes restricted * C* AWS data to b255/xx015. * C* C. Caruso Magee/NCEP 01/03 Add code to save Iowa Enviromental data * C* to b255/xx016. * C* J. Ator/NCEP 02/03 New RSRD values for MesoWest, NOS-PORTS * C* C. Caruso Magee/NCEP 04/03 New RSRD values for MNDOT, AWS. * C* J. Ator/NCEP 10/03 Add subtypes for OK-Meso and CODOT * C* J. Ator/NCEP 11/03 Store CMSOBN in BUFR output, * C* use CLATH, CLONH for lat/long * C* C. Caruso Magee/NCEP 08/04 Add subtypes for WT-Meso, WIDOT, * C* LSU-JSU, and CO_E-470. * C* C. Caruso Magee/NCEP 02/05 Add subtypes for DCNet, INDOT. * C* C. Caruso Magee/NCEP 03/05 Add subtype for FLDOT. Replace calls to* C* UFBINT which immediately precede calls * C* to UFBSEQ with calls to DRFINI. * C* C. Caruso Magee/NCEP 03/05 Add subtype for AKDOT. Add new output * C* for vars SLMT and STEM. * C* C. Caruso Magee/NCEP 04/05 Change RSRD for OK-Meso to 256 (no * C* redistribution allowed) * C* C. Caruso Magee/NCEP 10/05 Add subtypes for GADOT, VADOT, and * C* MOComAgNet. * C* C. Caruso Magee/NCEP 03/06 Change to use BUFRLIB function PKFTBV * C* to set bits for RSRD. * C* C. Caruso Magee/NCEP 10/06 Add road variables; change RSRD for * C* VADOT to 224. * C* C. Caruso Magee/NCEP 04/07 Change RSRD to full distribution for * C* APRSWXNET, IADOT, and NOS-PORTS. Leave * C* VADOT to 224 since road vars are still * C* restricted (even though met are not). * C* J. Ator/NCEP 01/08 Fix bug in storing of roadway levels. * C* J. Ator/NCEP 07/08 Change RSRD for WXforYou mesonet. * C* S. Guan/NCEP 10/14 Add UrbaNet and USouthAL Data * C* M. Weiss/NCEP 01/24 Add RWIS4 subtype SDDOT. Also added a * C* timing filter function to reduce the * C* number of duplicates in the xx030 tank. * C* Same timing filter logic also added to * C* tanks xx015 (AWS) and xx004 (APRSWXNET).* C* M. Weiss/NCEP 02/24 Added the timing filter function call * C* to BUFR tank xx003. * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'mncmn.cmn' C* INTEGER irundt (5) C* CHARACTER bfstyp*8, cmsobn*18 C* REAL*8 r8ary ( 5, MAX0 ( MXPCP, MXSRD ) ), + r8ary1 ( 5, 4 ), + UT_RIBM, PKFTBV C* INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 C* Set the BUFR message subtype and redistribution restriction. C* Use PKFTBV to set rsrd values. Rsrd has bitwidth of 9. If C* bit 1 is set, no redistribution allowed. Bit 2 - redistribute C* to any US govt agency. Bit 3 - redistribute to any US research C* group. Bit 4 - redistribute to any US educational institution. C* Bit 5 - redistribute to any US govt agency within NOAA. Bits C* 6-8 are reserved for now. All 9 bits set indicates missing, C* but we'll use RMISSD for that case. IF ( civals ( icprvid ) .eq. 'UDFCD ' ) THEN bfstyp = 'NC255001' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'RAWS ' ) THEN bfstyp = 'NC255002' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'MesoWest ' ) THEN IF ( MN_SKIPT ( cmsobn (17:18) ) ) RETURN bfstyp = 'NC255003' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'APRSWXNET ' ) THEN IF ( MN_SKIPT ( cmsobn (17:18) ) ) RETURN bfstyp = 'NC255004' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'KSDOT ' ) THEN bfstyp = 'NC255005' rsrd = PKFTBV (9,2) + PKFTBV (9,3) + PKFTBV (9,4) ELSE IF ( civals ( icprvid ) .eq. 'FL-Meso ' ) THEN bfstyp = 'NC255006' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'IADOT ' ) THEN bfstyp = 'NC255007' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'MNDOT ' ) THEN bfstyp = 'NC255008' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'AWX ' ) THEN bfstyp = 'NC255009' rsrd = PKFTBV (9,2) + PKFTBV (9,3) + PKFTBV (9,4) ELSE IF ( civals ( icprvid ) .eq. 'NOS-PORTS ' ) THEN bfstyp = 'NC255010' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'APG ' ) THEN bfstyp = 'NC255011' rsrd = PKFTBV (9,2) + PKFTBV (9,3) + PKFTBV (9,4) ELSE IF ( civals ( icprvid ) .eq. 'WXforYou ' ) THEN bfstyp = 'NC255012' rsrd = PKFTBV (9,2) + PKFTBV (9,3) + PKFTBV (9,4) ELSE IF ( civals ( icprvid ) .eq. 'NWS-COOP ' ) THEN bfstyp = 'NC255013' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'HADS ' ) THEN bfstyp = 'NC255014' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'AWS ' ) THEN IF ( MN_SKIPT ( cmsobn (17:18) ) ) RETURN bfstyp = 'NC255015' rsrd = PKFTBV (9,5) ELSE IF ( civals ( icprvid ) .eq. 'IEM ' ) THEN bfstyp = 'NC255016' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'OK-Meso ' ) THEN bfstyp = 'NC255017' rsrd = PKFTBV (9,1) ELSE IF ( civals ( icprvid ) .eq. 'CODOT ' ) THEN bfstyp = 'NC255018' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'WT-Meso ' ) THEN bfstyp = 'NC255019' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'WIDOT ' ) THEN bfstyp = 'NC255020' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'LSU-JSU ' ) THEN bfstyp = 'NC255021' rsrd = PKFTBV (9,2) + PKFTBV (9,3) + PKFTBV (9,4) ELSE IF ( civals ( icprvid ) .eq. 'CO_E-470 ' ) THEN bfstyp = 'NC255022' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'DCNet ' ) THEN bfstyp = 'NC255023' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'INDOT ' ) THEN bfstyp = 'NC255024' rsrd = PKFTBV (9,2) + PKFTBV (9,3) + PKFTBV (9,4) ELSE IF ( civals ( icprvid ) .eq. 'FLDOT ' ) THEN bfstyp = 'NC255025' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'AKDOT ' ) THEN bfstyp = 'NC255026' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'GADOT ' ) THEN bfstyp = 'NC255027' rsrd = PKFTBV (9,2) + PKFTBV (9,3) + PKFTBV (9,4) ELSE IF ( civals ( icprvid ) .eq. 'VADOT ' ) THEN bfstyp = 'NC255028' rsrd = PKFTBV (9,2) + PKFTBV (9,3) + PKFTBV (9,4) ELSE IF ( civals ( icprvid ) .eq. 'MOComAgNet ' ) THEN bfstyp = 'NC255029' rsrd = RMISSD ELSE IF ( civals ( icprvid ) .eq. 'UrbaNet ' ) THEN bfstyp = 'NC255031' rsrd = PKFTBV (9,2) + PKFTBV (9,3) + PKFTBV (9,4) ELSE IF ( civals ( icprvid ) .eq. 'USouthAL ' ) THEN bfstyp = 'NC255032' rsrd = PKFTBV (9,2) + PKFTBV (9,3) + PKFTBV (9,4) ELSE IF ( civals ( icprvid ) .eq. 'SDDOT ' ) THEN bfstyp = 'NC255034' rsrd = PKFTBV (9,1) ELSE IF ( MN_SKIPT ( cmsobn (17:18) ) ) RETURN bfstyp = 'NC255030' rsrd = PKFTBV (9,1) END IF C* Set the BUFR message date-time. year = rivals ( iryear ) rmth = rivals ( irmnth ) days = rivals ( irdays ) hour = rivals ( irhour ) IF ( ( ERMISS ( year ) ) .or. ( ERMISS ( rmth ) ) .or. + ( ERMISS ( days ) ) .or. ( ERMISS ( hour ) ) ) RETURN ibfdt = ( INT ( year ) * 1000000 ) + ( INT ( rmth ) * 10000 ) + + ( INT ( days ) * 100 ) + INT ( hour ) C* Open a BUFR message for output. CALL OPENMB ( iunbfo, bfstyp, ibfdt ) C* Report date-time. CALL UT_RIBF ( iunbfo, 'YEAR', rivals ( iryear ), ierrbf ) CALL UT_RIBF ( iunbfo, 'MNTH', rivals ( irmnth ), ierrbf ) CALL UT_RIBF ( iunbfo, 'DAYS', rivals ( irdays ), ierrbf ) CALL UT_RIBF ( iunbfo, 'HOUR', rivals ( irhour ), ierrbf ) CALL UT_RIBF ( iunbfo, 'MINU', rivals ( irminu ), ierrbf ) C* Receipt date-time. 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', 0., ierrbf ) C* Station ID. CALL UT_CIBF ( iunbfo, 'RPID', civals ( icstid ), 8, iercbf ) C* Provider ID. CALL ST_LSTR ( civals ( icprvid ), lenp, ierltr ) CALL UT_CIBF ( iunbfo, 'PRVSTG', + civals ( icprvid ), lenp, iercbf ) IF ( civals ( icsprvid ) (1:1) .ne. ' ' ) THEN C* Subprovider ID. CALL ST_LSTR ( civals ( icsprvid ), lensp, ierltr ) CALL UT_CIBF ( iunbfo, 'SPRVSTG', + civals ( icsprvid ), lensp, iercbf ) END IF C* File basename. CALL UT_CIBF ( iunbfo, 'FNSTG', cmsobn, 18, iercbf ) C* Latitude. CALL UT_RIBF ( iunbfo, 'CLATH', rivals ( irslat ), ierrbf ) C* Longitude. CALL UT_RIBF ( iunbfo, 'CLONH', rivals ( irslon ), ierrbf ) C* Elevation. CALL UT_RIBF ( iunbfo, 'SELV', rivals ( irselv ), ierrbf ) C* Wind gust direction. CALL UT_RIBF ( iunbfo, 'MXGD', rivals ( irgudr ), ierrbf ) C* Wind gust speed. CALL UT_RIBF ( iunbfo, 'MXGS', rivals ( irgums ), ierrbf ) C* Soil moisture tension. Convert from KPa to Pascals. CALL UT_RIBF ( iunbfo, 'SLMT', + PR_HGKM ( rivals ( irslmt ) ), ierrbf ) C* Soil temperature CALL UT_RIBF ( iunbfo, 'STEM', rivals ( irsolt ), ierrbf ) C* Pressure (and associated QC values). CALL UT_QIBF ( PR_M100 ( rivals ( irpres ) ), + civals ( icpresqd ), + rivals ( irpresqa ), + rivals ( irpresqr ), + r8ary ( 1, 1 ), r8ary ( 2, 1 ), + r8ary ( 3, 1 ), r8ary ( 4, 1 ), ierqbf ) IF ( ierqbf .eq. 0 ) THEN CALL DRFINI ( iunbfo, 1, 1, '') CALL UFBSEQ ( iunbfo, r8ary, 4, 1, ierusq, 'MNPRESSQ' ) END IF C* Altimeter (and associated QC values). CALL UT_QIBF ( PR_M100 ( rivals ( iraltm ) ), + civals ( icaltmqd ), + rivals ( iraltmqa ), + rivals ( iraltmqr ), + r8ary ( 1, 1 ), r8ary ( 2, 1 ), + r8ary ( 3, 1 ), r8ary ( 4, 1 ), ierqbf ) IF ( ierqbf .eq. 0 ) THEN CALL DRFINI ( iunbfo, 1, 1, '') CALL UFBSEQ ( iunbfo, r8ary, 4, 1, ierusq, 'MNALSESQ' ) END IF C* Temperature (and associated QC values). CALL UT_QIBF ( rivals ( irtmpk ), + civals ( ictmpkqd ), + rivals ( irtmpkqa ), + rivals ( irtmpkqr ), + r8ary ( 1, 1 ), r8ary ( 2, 1 ), + r8ary ( 3, 1 ), r8ary ( 4, 1 ), ierqbf ) IF ( ierqbf .eq. 0 ) THEN CALL DRFINI ( iunbfo, 1, 1, '') CALL UFBSEQ ( iunbfo, r8ary, 4, 1, ierusq, 'MNTMDBSQ' ) END IF C* Dewpoint temperature (and associated QC values). CALL UT_QIBF ( rivals ( irdwpk ), + civals ( icdwpkqd ), + rivals ( irdwpkqa ), + rivals ( irdwpkqr ), + r8ary ( 1, 1 ), r8ary ( 2, 1 ), + r8ary ( 3, 1 ), r8ary ( 4, 1 ), ierqbf ) IF ( ierqbf .eq. 0 ) THEN CALL DRFINI ( iunbfo, 1, 1, '') CALL UFBSEQ ( iunbfo, r8ary, 4, 1, ierusq, 'MNTMDPSQ' ) END IF C* Wind direction (and associated QC values). CALL UT_QIBF ( rivals ( irdrct ), + civals ( icdrctqd ), + rivals ( irdrctqa ), + rivals ( irdrctqr ), + r8ary ( 1, 1 ), r8ary ( 2, 1 ), + r8ary ( 3, 1 ), r8ary ( 4, 1 ), ierqbf ) IF ( ierqbf .eq. 0 ) THEN CALL DRFINI ( iunbfo, 1, 1, '') CALL UFBSEQ ( iunbfo, r8ary, 4, 1, ierusq, 'MNWDIRSQ' ) END IF C* Wind speed (and associated QC values). CALL UT_QIBF ( rivals ( irsped ), + civals ( icspedqd ), + rivals ( irspedqa ), + rivals ( irspedqr ), + r8ary ( 1, 1 ), r8ary ( 2, 1 ), + r8ary ( 3, 1 ), r8ary ( 4, 1 ), ierqbf ) IF ( ierqbf .eq. 0 ) THEN CALL DRFINI ( iunbfo, 1, 1, '') CALL UFBSEQ ( iunbfo, r8ary, 4, 1, ierusq, 'MNWSPDSQ' ) END IF C* Horizontal visibility (and associated QC values). CALL UT_QIBF ( rivals ( irhovi ), + civals ( ichoviqd ), + rivals ( irhoviqa ), + rivals ( irhoviqr ), + r8ary ( 1, 1 ), r8ary ( 2, 1 ), + r8ary ( 3, 1 ), r8ary ( 4, 1 ), ierqbf ) IF ( ierqbf .eq. 0 ) THEN CALL DRFINI ( iunbfo, 1, 1, '') CALL UFBSEQ ( iunbfo, r8ary, 4, 1, ierusq, 'MNHOVISQ' ) END IF C* Precipitation rate (and associated QC values). CALL UT_QIBF ( rivals ( irrpcp ), + civals ( icrpcpqd ), + rivals ( irrpcpqa ), + rivals ( irrpcpqr ), + r8ary ( 1, 1 ), r8ary ( 2, 1 ), + r8ary ( 3, 1 ), r8ary ( 4, 1 ), ierqbf ) IF ( ierqbf .eq. 0 ) THEN CALL DRFINI ( iunbfo, 1, 1, '') CALL UFBSEQ ( iunbfo, r8ary, 4, 1, ierusq, 'MNREQVSQ' ) END IF C* Total precipitation amounts (and associated QC values). C* Note that, since the density of water is 1 g/cm**3, then C* 1 m of precipitation = 1000 kg/m**2. npcp = INT ( rivals ( irnpcp ) ) IF ( npcp .gt. 0 ) THEN DO ii = 1, npcp r8ary ( 1, ii ) = UT_RIBM ( rivals ( irtphr (ii) ) ) CALL UT_QIBF ( PR_HGKM ( rivals ( irtpcp (ii) ) ), + civals ( ictpcpqd (ii) ), + rivals ( irtpcpqa (ii) ), + rivals ( irtpcpqr (ii) ), + r8ary ( 2, ii ), r8ary ( 3, ii ), + r8ary ( 4, ii ), r8ary ( 5, ii ), ierqbf ) END DO CALL DRFINI ( iunbfo, npcp, 1, '{MNTOPCSQ}') CALL UFBSEQ ( iunbfo, r8ary, 5, npcp, ierusq, 'MNTOPCSQ' ) END IF C* Solar radiation. C* Note that the interface values are in units of watt/m**2 and C* that 1 watt = 1 joule/s. nsrd = INT ( rivals ( irnsrd ) ) IF ( nsrd .gt. 0 ) THEN DO ii = 1, nsrd r8ary ( 1, ii ) = UT_RIBM ( rivals ( irtpmi (ii) ) ) IF ( ERMISS ( rivals ( irdfsord ( ii ) ) ) ) THEN r8ary ( 2, ii ) = r8bfms ELSE r8ary ( 2, ii ) = ( rivals ( irdfsord ( ii ) ) * + rivals ( irtpmi ( ii ) ) * 60. ) END IF IF ( ERMISS ( rivals ( irdrsord ( ii ) ) ) ) THEN r8ary ( 3, ii ) = r8bfms ELSE r8ary ( 3, ii ) = ( rivals ( irdrsord ( ii ) ) * + rivals ( irtpmi ( ii ) ) * 60. ) END IF END DO CALL DRFINI ( iunbfo, nsrd, 1, '{MNSORDSQ}') CALL UFBSEQ ( iunbfo, r8ary, 3, nsrd, ierusq, 'MNSORDSQ' ) END IF C* Roadway data (up to 4 sensors). nrdw = rivals ( irnrdw ) IF ( nrdw .gt. 0 ) THEN DO ii = 1, nrdw C* Road temperature. r8ary1 ( 1, ii ) = UT_RIBM ( rivals ( irrdtm (ii) ) ) C* Road liquid freeze temperature. r8ary1 ( 2, ii ) = UT_RIBM ( rivals ( irrlft (ii) ) ) C* Road liquid ice percent. r8ary1 ( 3, ii ) = UT_RIBM ( rivals ( irrlip (ii) ) ) C* Road liquid depth. r8ary1 ( 4, ii ) = UT_RIBM ( rivals ( irrdld (ii) ) ) C* Road state. r8ary1 ( 5, ii ) = UT_RIBM ( rivals ( irrdst (ii) ) ) END DO CALL UFBINT ( iunbfo, r8ary1, 5, nrdw, ierufb, + 'RDTM RLFT RLIP RDLD RDST' ) END IF C* Restrictions on redistribution. CALL UT_RIBF ( iunbfo, 'RSRD', rsrd, ierrbf ) C* Store the BUFR report. CALL UT_WBFR ( iunbfo, 'mesonet', 0, ierwbf ) C* RETURN END