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, '') 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, '') 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, '') 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, '') 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, '') 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, '') 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