SUBROUTINE CN_BUFR ( iunbfo, irundt, cmsobn, iret )
C************************************************************************
C* CN_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* CN_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* S. Guan/NCEP 12/11 *
C* J. Ator/NCEP 12/11 Change "mesonet" identifiers to "crn" *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BUFR.CMN'
INCLUDE 'cncmn.cmn'
C*
INTEGER irundt (5)
C*
CHARACTER bfstyp*8, cmsobn*18
C*
REAL*8 r8ary ( 9, MAX0 ( MXPCP, MXSOL ) ),
+ r8ary1 ( 5, 4 ),
+ r8ary2 ( 6, MXPCP ),
+ UT_RIBM, PKFTBV
C*
INCLUDE 'ERMISS.FNC'
C*-----------------------------------------------------------------------
iret = 0
C
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.
C
IF ( civals ( icprvid )(1:3) .eq. 'CRN' ) THEN
bfstyp = 'NC255111'
ELSE
RETURN
END IF
rsrd = PKFTBV (9,1)
C
C* Set the BUFR message date-time.
C
year = rivals ( iryear )
rmth = rivals ( irmnth )
days = rivals ( irdays )
hour = rivals ( irhour )
IF ( ( ERMISS ( year ) ) .or. ( ERMISS ( rmth ) ) .or.
+ ( ERMISS ( days ) ) .or. ( ERMISS ( hour ) ) ) THEN
RETURN
END IF
ibfdt = ( INT ( year ) * 1000000 ) + ( INT ( rmth ) * 10000 ) +
+ ( INT ( days ) * 100 ) + INT ( hour )
C
C* Open a BUFR message for output.
C
CALL OPENMB ( iunbfo, bfstyp, ibfdt )
C
C* Report date-time.
C
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
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', 0., ierrbf )
C
C* Station ID.
C
CALL UT_CIBF ( iunbfo, 'RPID', civals ( icstid ), 8, iercbf )
C
C* Provider ID.
C
CALL ST_LSTR ( civals ( icprvid ), lenp, ierltr )
CALL UT_CIBF ( iunbfo, 'PRVSTG',
+ civals ( icprvid ), lenp, iercbf )
C
C* File basename.
C
CALL UT_CIBF ( iunbfo, 'FNSTG', cmsobn, 18, iercbf )
C
C* Latitude.
C
CALL UT_RIBF ( iunbfo, 'CLATH', rivals ( irslat ), ierrbf )
C
C* Longitude.
C
CALL UT_RIBF ( iunbfo, 'CLONH', rivals ( irslon ), ierrbf )
C
C* Elevation.
C
CALL UT_RIBF ( iunbfo, 'SELV', rivals ( irselv ), ierrbf )
C
C* Wind gust direction.
C
CALL UT_RIBF ( iunbfo, 'MXGD', rivals ( irgudr ), ierrbf )
C
C* Wind gust speed.
C
CALL UT_RIBF ( iunbfo, 'MXGS', rivals ( irgums ), ierrbf )
C
C* Platform type.
C
CALL UT_RIBF ( iunbfo, 'PLTTYP',
+ PR_D100 ( rivals ( irpltp ) ) , ierrbf )
C
C* Temperature (and associated QC values).
C
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
C* Relative humidity (and associated QC values).
C
CALL UT_QIBF ( rivals ( irrelh ),
+ civals ( icrelhqd ),
+ rivals ( irrelhqa ),
+ rivals ( irrelhqr ),
+ r8ary ( 1, 1 ), r8ary ( 2, 1 ),
+ r8ary ( 3, 1 ), r8ary ( 4, 1 ), ierqbf )
IF ( ierqbf .eq. 0 ) THEN
CALL DRFINI ( iunbfo, 1, 1, '<MNREHUSQ>')
CALL UFBSEQ ( iunbfo, r8ary, 4, 1, ierusq, 'MNREHUSQ' )
END IF
C
C* Wind direction (and associated QC values).
C
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
C* Wind speed (and associated QC values).
C
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
C* Global solar radiation (and associated QC values).
C
CALL UT_QIBF ( rivals ( irsrdf ),
+ civals ( icsrdfqd ),
+ rivals ( irsrdfqa ),
+ rivals ( irsrdfqr ),
+ r8ary ( 1, 1 ), r8ary ( 2, 1 ),
+ r8ary ( 3, 1 ), r8ary ( 4, 1 ), ierqbf )
IF ( ierqbf .eq. 0 ) THEN
CALL DRFINI ( iunbfo, 1, 1, '<MNSORFSQ>')
CALL UFBSEQ ( iunbfo, r8ary, 4, 1, ierusq, 'MNSORFSQ' )
END IF
C
C* Precipitation rate (and associated QC values).
C
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
C* Total precipitation amounts (and associated QC values).
C
C* Note that, since the density of water is 1 g/cm**3, then
C* 1 m of precipitation = 1000 kg/m**2.
C
npcp = INT ( rivals ( irnpcp ) )
IF ( npcp .gt. 0 ) THEN
DO ii = 1, npcp
r8ary2 ( 1, ii ) = rivals ( irtphr (ii) )
r8ary2 ( 2, ii ) = rivals ( irtpmi (ii) )
CALL UT_QIBF ( PR_HGKM ( rivals ( irtpcp (ii) ) ),
+ civals ( ictpcpqd (ii) ),
+ rivals ( irtpcpqa (ii) ),
+ rivals ( irtpcpqr (ii) ),
+ r8ary2 ( 3, ii ), r8ary2 ( 4, ii ),
+ r8ary2 ( 5, ii ), r8ary2 ( 6, ii ),
+ ierqbf )
END DO
CALL DRFINI ( iunbfo, npcp, 1, '{CNTOPCSQ}')
CALL UFBSEQ ( iunbfo, r8ary2, 6, npcp, ierusq, 'CNTOPCSQ' )
END IF
C
C* Soil moistures/temperatures (and associated QC values, set 1).
C
nsol = INT ( rivals ( irnsol1 ) )
IF ( nsol .gt. 0 ) THEN
DO ii = 1, nsol
r8ary ( 1, ii ) = rivals ( irslin1(ii) )/100.0
CALL UT_QIBF ( rivals ( irsolm1 (ii) ),
+ civals ( icsolmqd1 (ii) ),
+ rivals ( irsolmqa1 (ii) ),
+ rivals ( irsolmqr1 (ii) ),
+ r8ary ( 2, ii ), r8ary ( 3, ii ),
+ r8ary ( 4, ii ), r8ary ( 5, ii ),
+ ierqbf )
CALL UT_QIBF ( rivals ( irsolt1 (ii) ),
+ civals ( icsoltqd1 (ii) ),
+ rivals ( irsoltqa1 (ii) ),
+ rivals ( irsoltqr1 (ii) ),
+ r8ary ( 6, ii ), r8ary ( 7, ii ),
+ r8ary ( 8, ii ), r8ary ( 9, ii ),
+ ierqbf )
END DO
CALL DRFINI ( iunbfo, nsol, 1, '{MNSOMTSQ}')
CALL UFBSEQ ( iunbfo, r8ary, 9, nsol, ierusq, 'MNSOMTSQ' )
END IF
C
C* Soil moistures/temperatures (and associated QC values, set 2).
C
nsol = INT ( rivals ( irnsol2 ) )
IF ( nsol .gt. 0 ) THEN
DO ii = 1, nsol
r8ary ( 1, ii ) = rivals ( irslin1(ii) )/100.0
CALL UT_QIBF ( rivals ( irsolm2 (ii) ),
+ civals ( icsolmqd2 (ii) ),
+ rivals ( irsolmqa2 (ii) ),
+ rivals ( irsolmqr2 (ii) ),
+ r8ary ( 2, ii ), r8ary ( 3, ii ),
+ r8ary ( 4, ii ), r8ary ( 5, ii ),
+ ierqbf )
CALL UT_QIBF ( rivals ( irsolt2 (ii) ),
+ civals ( icsoltqd2 (ii) ),
+ rivals ( irsoltqa2 (ii) ),
+ rivals ( irsoltqr2 (ii) ),
+ r8ary ( 6, ii ), r8ary ( 7, ii ),
+ r8ary ( 8, ii ), r8ary ( 9, ii ),
+ ierqbf )
END DO
CALL DRFINI ( iunbfo, nsol, 1, '{MNSOMTSQ}')
CALL UFBSEQ ( iunbfo, r8ary, 9, nsol, ierusq, 'MNSOMTSQ' )
END IF
C
C* Soil moistures/temperatures (and associated QC values, set 3).
C
nsol = INT ( rivals ( irnsol3 ) )
IF ( nsol .gt. 0 ) THEN
DO ii = 1, nsol
r8ary ( 1, ii ) = rivals ( irslin1(ii) )/100.0
CALL UT_QIBF ( rivals ( irsolm3 (ii) ),
+ civals ( icsolmqd3 (ii) ),
+ rivals ( irsolmqa3 (ii) ),
+ rivals ( irsolmqr3 (ii) ),
+ r8ary ( 2, ii ), r8ary ( 3, ii ),
+ r8ary ( 4, ii ), r8ary ( 5, ii ),
+ ierqbf )
CALL UT_QIBF ( rivals ( irsolt3 (ii) ),
+ civals ( icsoltqd3 (ii) ),
+ rivals ( irsoltqa3 (ii) ),
+ rivals ( irsoltqr3 (ii) ),
+ r8ary ( 6, ii ), r8ary ( 7, ii ),
+ r8ary ( 8, ii ), r8ary ( 9, ii ),
+ ierqbf )
END DO
CALL DRFINI ( iunbfo, nsol, 1, '{MNSOMTSQ}')
CALL UFBSEQ ( iunbfo, r8ary, 9, nsol, ierusq, 'MNSOMTSQ' )
END IF
C
C* Restrictions on redistribution.
C
CALL UT_RIBF ( iunbfo, 'RSRD', rsrd, ierrbf )
C
C* Store the BUFR report.
C
CALL UT_WBFR ( iunbfo, 'crn', 0, ierwbf )
C*
RETURN
END