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, '<MNPRESSQ>')
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, '<MNALSESQ>')
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, '<MNTMDBSQ>')
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, '<MNTMDPSQ>')
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, '<MNWDIRSQ>')
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, '<MNWSPDSQ>')
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, '<MNHOVISQ>')
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, '<MNREQVSQ>')
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