SUBROUTINE SN_BUFR ( iunbfo, irundt, cmsobn, iret ) C************************************************************************ C* SN_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* SN_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 SNOW data file basename * C* * C* Output parameters: * C* IRET INTEGER Return code: * C* 0 = normal return * C** * C* Log: * C* C. Caruso Magee/NCEP 07/06 New * C* C* J. Ator/NCEP 02/11 Change to {MNDOFSSQ} * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'sncmn.cmn' C* INTEGER irundt (5) C* CHARACTER bfstyp*8, cmsobn*18 C* REAL*8 r8ary ( 4, 1 ), r8aryfs ( 5, 2 ), + r8aryeq ( 5, 3 ), + UT_RIBM, + bfdint, bflint, bftint, bfrolf C* INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 C C* Set the BUFR message subtype and redistribution restriction. C bfstyp = 'NC255161' 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 ( icsnid ), 8, iercbf ) C C* Subprovider ID. C IF ( civals ( icsprvid ) (1:1) .ne. ' ' ) THEN CALL ST_LSTR ( civals ( icsprvid ), lensp, ierltr ) CALL UT_CIBF ( iunbfo, 'SPRVSTG', + civals ( icsprvid ), lensp, iercbf ) END IF 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* Snow remarks. C CALL UT_RIBF ( iunbfo, 'SRMK', rivals ( irsrmk ), ierrbf ) C C* Snow data (and associated QC values). Total snow depth and depth of C* fresh snow are reported in millimeters, and bufr storage is in meters, C* so convert to meters before storage. Snow water equiv. data are C* reported in millimeters, and bufr storage is in kg/m**2, so no C* conversion is necessary for this parameter (1 millimeter = 1 kg/m**2 C* (BUFR storage units)). C* First do total snow depth. C CALL UT_QIBF ( PR_HGMK ( rivals ( irtosd ) ), + civals ( ictosdqd ), + rivals ( irtosdqa ), + rivals ( irtosdqr ), + 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, 'MNTOSDSQ' ) END IF C C* Snow water equivalent - depth. C* First array element is TPHR (set to 0 for depth). C* Write sequences after all r8ary values are set. C C* Initialize number of swem and dofs to 0. C nswem = 0 ndofs = 0 C IF ( .not. ERMISS ( rivals ( irswem ) ) ) THEN nswem = nswem + 1 r8aryeq ( 1, nswem ) = 0.0 CALL UT_QIBF ( rivals ( irswem ), + civals ( icswemqd ), + rivals ( irswemqa ), + rivals ( irswemqr ), + r8aryeq ( 2, nswem ), r8aryeq ( 3, nswem ), + r8aryeq ( 4, nswem ), r8aryeq ( 5, nswem ), + ierqbf ) END IF C C* Change time period to 6 hrs. C* Snowfall - last 6 hrs. C IF ( .not. ERMISS ( rivals ( irdofs6 ) ) ) THEN ndofs = ndofs + 1 r8aryfs ( 1, ndofs ) = 6.0 CALL UT_QIBF ( PR_HGMK ( rivals ( irdofs6 ) ), + civals ( icdofs6qd ), + rivals ( irdofs6qa ), + rivals ( irdofs6qr ), + r8aryfs ( 2, ndofs ), r8aryfs ( 3, ndofs ), + r8aryfs ( 4, ndofs ), r8aryfs ( 5, ndofs ), + ierqbf ) END IF C C* Snow water equivalent - 6 hr. C IF ( .not. ERMISS ( rivals ( irswem6 ) ) ) THEN nswem = nswem + 1 r8aryeq ( 1, nswem ) = 6.0 CALL UT_QIBF ( rivals ( irswem6 ), + civals ( icswem6qd ), + rivals ( irswem6qa ), + rivals ( irswem6qr ), + r8aryeq ( 2, nswem ), r8aryeq ( 3, nswem ), + r8aryeq ( 4, nswem ), r8aryeq ( 5, nswem ), + ierqbf ) END IF C C* Change time period to last 24 hrs C* Snowfall - last 24 hrs. C IF ( .not. ERMISS ( rivals ( irdofs24 ) ) ) THEN ndofs = ndofs + 1 r8aryfs ( 1, ndofs ) = 24.0 CALL UT_QIBF ( PR_HGMK ( rivals ( irdofs24 ) ), + civals ( icdofs24qd ), + rivals ( irdofs24qa ), + rivals ( irdofs24qr ), + r8aryfs ( 2, ndofs ), r8aryfs ( 3, ndofs ), + r8aryfs ( 4, ndofs ), r8aryfs ( 5, ndofs ), + ierqbf ) END IF C C* Snow water equivalent - 24 hr. C IF ( .not. ERMISS ( rivals ( irswem24 ) ) ) THEN nswem = nswem + 1 r8aryeq ( 1, nswem ) = 24.0 CALL UT_QIBF ( rivals ( irswem24 ), + civals ( icswem24qd ), + rivals ( irswem24qa ), + rivals ( irswem24qr ), + r8aryeq ( 2, nswem ), r8aryeq ( 3, nswem ), + r8aryeq ( 4, nswem ), r8aryeq ( 5, nswem ), + ierqbf ) END IF C C* Last values have been stored into r8ary, so write 'em out. C IF ( ndofs .gt. 0 ) THEN CALL DRFINI ( iunbfo, ndofs, 1, '{MNDOFSSQ}' ) CALL UFBSEQ ( iunbfo, r8aryfs, 5, ndofs, ierusq, 'MNDOFSSQ' ) END IF IF ( nswem .gt. 0 ) THEN CALL DRFINI ( iunbfo, nswem, 1, '{SNSWEMSQ}' ) CALL UFBSEQ ( iunbfo, r8aryeq, 5, nswem, ierusq, 'SNSWEMSQ' ) END IF C C* Store the BUFR report. C CALL UT_WBFR ( iunbfo, 'snow', 0, ierwbf ) C* RETURN END