SUBROUTINE MT_BUFR( bufrtb, saoflg, last, mtrpt, lenr, iret ) C************************************************************************ C* MT_BUFR * C* * C* This routine creates a BUFR message containing subsets of all the * C* same message type. The data from the current report will be * C* converted to a BUFR subset and added to the BUFR message which * C* contains subsets of the same message type as the report. If none * C* exists, one will be started. * C* On the first entry into the routine, unit numbers are assigned to * C* the BUFR output files and these files are then opened for use. On * C* the last entry into the routine, the BUFR output files are closed. * C* * C* MT_BUFR ( BUFRTB, SAOFLG, LAST, MTRPT, LENR, IRET ) * C* * C* Input variables: * C* * C* BUFRTB CHAR* BUFR table file * C* SAOFLG LOGICAL If true, sao report. * C* LAST LOGICAL Flag to close BUFR files * C* LENR INTEGER Length of report * C* MTRPT CHAR* Report array * C* RIVALS(IRYEAR) REAL Report observation year * C* RIVALS(IRMNTH) REAL Report observation month * C* RIVALS(IRDAYS) REAL Report observation day * C* RIVALS(IRHOUR) REAL Report observation hour * C* RIVALS(IRMINU) REAL Report observation minute * C* * C* Output variables: * C* * C* IRET INTEGER Return code * C* 0 = normal return * C* 1 = problems * C* * C** * C* Log: * C* R. Hollern/NCEP 6/98 Adapted from LS_BUFR * C* R. Hollern/NCEP 8/98 Added hviskm to MT_BUFC and MT_BUFI * C* argument list * C* R. Hollern/NCEP 5/99 Added saoflg to argument list * C* C. Caruso Magee/NCEP 06/00 Modify to use rivals instead of irptdt * C* array for date/time handling * C* C. Caruso Magee/NCEP 06/2001 Replace calls to WRITSA and * C* DBN_BUFR with new s/r UT_WBFR. * C* J. Ator/NCEP 06/01 Use 'NUL' in call to OPENBF * C* C. Caruso Magee/NCEP 08/01 Add s/r to encode sst and sea state into* C* BUFR * C* C. Caruso Magee/NCEP 02/2002 Change name to mtbufr.f. Change to use* C* UT_RIBF, UT_CIBF, and UT_RIBM for BUFR * C* output instead of lots of separate * C* calls to UFBINT or UFBREP. * C* This s/r replaces mtbufa.f plus all of * C* the subroutines it previously called. * C* C. Caruso Magee/NCEP 03/2002 Correct typo in writing irgust to BUFR.* C* Correct typo in writing irp03i to BUFR.* C* Correct precip output to check * C* irtarr(4) for hour instead of * C* rivals(irhour) (see comments in code * C* for explanation). * C* R. Hollern/NCEP 09/2003 Corrected problems that caused BUFRLIB * C* warning error messages to be generated * C* C. Caruso Magee/NCEP 01/2004 Commenting out encode of .DTHDOFS * C* (duration of period of newly fallen * C* snow), since this is not yet in * C* bufrtab.000. Will uncomment when we * C* next change bufrtab.000, and will have * C* to reingest metar data. * C* R. Hollern/NCEP 03/04 Removed the logic to print the beginning* C* and ending interface BUFR log messages * C* if level 4 interface printout requested.* C* C. Caruso Magee/NCEP 05/2004 Adding code to store present weather * C* values of 128 and 129 (blowing or * C* drifting snow, sand, or dust, with hovi* C* greater than or equal to 1 km (for 128)* C* or less than 1 km (for 129). Also * C* fixed error in hviskm check for HZ. * C* J. Ator/NCEP 11/06 Don't set missing precip values to 0.0 * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BUFR.CMN' INCLUDE 'mtcmn.cmn' INCLUDE 'mtcmn_bufr.cmn' C* CHARACTER*(*) bufrtb, mtrpt LOGICAL saoflg, last, first, vflag C* REAL*8 r8mmt ( NCMMT, 2 ), r8pwx ( 1, 12 ), + r8cld ( NCCLD, 9 ), r8rwy ( NCRWY, MXRWVR ) , + r8pkw ( NCPKW, 2 ), r8val, + UT_RIBM, GETBMISS REAL skyvals ( 6 ), valcld ( NCCLD, 9 ), xvis INTEGER idt(5), iarr ( 12 ), inumd ( 3 ), jrptdt ( 5 ) CHARACTER subset*8, wx ( 3 )*9 C* DATA first / .true. / C* SAVE C INCLUDE 'ERMISS.FNC' C------------------------------------------------------------------------ C iret = 0 vflag = .false. hviskm = -1.0 C C* Do not create BUFR if the latitude or longitude is missing. C IF ( ( ERMISS ( rivals ( irslat ) ) ) .or. + ( ERMISS ( rivals ( irslon ) ) ) ) THEN iret = 1 RETURN END IF C IF ( first ) THEN first = .false. C C* Allocate unit numbers to the BUFR table and to the BUFR C* output files C CALL FL_GLUN ( lunbtb, kret ) CALL FL_GLUN ( iunbfo, kret ) C C* Open the BUFR table file C OPEN ( UNIT = lunbtb, FILE = bufrtb ) C C* Connect the BUFR output files to the BUFR table C CALL OPENBF ( iunbfo, 'NUL', lunbtb ) r8bfms = GETBMISS() C END IF C IF ( last ) then C C* Close BUFR output files C CALL CLOSBF ( lunbtb ) CALL CLOSBF ( iunbfo ) RETURN END IF C idt(1) = NINT ( rivals (iryear) ) idt(2) = NINT ( rivals (irmnth) ) idt(3) = NINT ( rivals (irdays) ) idt(4) = NINT ( rivals (irhour) ) idt(5) = NINT ( rivals (irminu) ) ibfdt = ( idt (1) * 1000000 ) + + ( idt (2) * 10000 ) + ( idt (3) * 100 ) + + idt (4) C C* Metar report. C subset = 'NC000007' istyp = 3 C C* Open BUFR file for output C CALL OPENMB ( iunbfo, subset, ibfdt ) C C* Initialize BUFR output arrays. C DO jj = 1, 2 DO ii = 1, NCMMT r8mmt ( ii, jj ) = r8bfms END DO END DO DO jj = 1, 12 r8pwx ( 1, jj ) = r8bfms END DO DO jj = 1, 3 wx ( jj ) = ' ' END DO DO j = 1,9 DO i = 1, NCCLD valcld(i,j) = RMISSD r8cld(i,j) = r8bfms END DO END DO DO jj = 1, MXRWVR DO ii = 1, NCRWY r8rwy ( ii, jj ) = r8bfms END DO END DO DO jj = 1, 2 DO ii = 1, NCPKW r8pkw ( ii, jj ) = r8bfms END DO END DO C C* Add bulletin header info to BUFR output. C CALL UT_CIBF ( iunbfo, 'SEQNUM', seqnum, 8, iercbf ) CALL UT_CIBF ( iunbfo, 'BUHD', buhd, 8, iercbf ) CALL UT_CIBF ( iunbfo, 'BORG', cborg, 8, iercbf ) CALL UT_CIBF ( iunbfo, 'BULTIM', btime, 8, iercbf ) CALL UT_CIBF ( iunbfo, 'BBB', bbb, 8, iercbf ) C C* Add character ID ( 0 01 198 ). C CALL UT_CIBF ( iunbfo, 'RPID', civals ( icstid ), 8, iercbf ) C C* Short ICAO location identifier ( 0 01 062 ) . C CALL UT_CIBF ( iunbfo, 'ICLX', civals ( icstid ), 8, iercbf ) C C* Longitude ( 0 06 002 ). C CALL UT_RIBF ( iunbfo, 'CLON', rivals ( irslon ), ierrbf ) C C* Latitude ( 0 05 002 ). C CALL UT_RIBF ( iunbfo, 'CLAT', rivals ( irslat ), ierrbf ) C C* Station elevation in meters ( 0 07 001 ). C CALL UT_RIBF ( iunbfo, 'SELV', rivals ( irselv ), ierrbf ) C C* Get corrected report indicator ( 0 33 215 ). C CALL UT_RIBF ( iunbfo, 'CORN', rivals ( ircorn ), ierrbf ) C C* Type of hourly report ( 0 01 199 ). C CALL UT_RIBF ( iunbfo, 'THRPT', rivals ( irthrp ), ierrbf ) C C* Automatic station flag ( 0 02 194 ). C CALL UT_RIBF ( iunbfo, 'AUTO', rivals ( irauto ), ierrbf ) 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', rctim (2), ierrbf ) CALL UT_RIBF ( iunbfo, 'RCMO', rctim (3), ierrbf ) CALL UT_RIBF ( iunbfo, 'RCDY', rctim (4), ierrbf ) CALL UT_RIBF ( iunbfo, 'RCHR', rctim (5), ierrbf ) CALL UT_RIBF ( iunbfo, 'RCMI', rctim (6), ierrbf ) CALL UT_RIBF ( iunbfo, 'RCTS', rctim (1), ierrbf ) C C* Store wind direction ( 0 11 001 ) in BUFR if it is not variable. C IF ( NINT ( rivals ( irdrct ) ) .ne. -99 ) THEN CALL UT_RIBF ( iunbfo, 'WDIR', rivals ( irdrct ), ierrbf ) END IF C C* Store wind speed. Either irsped or irsknt will be set (not C* both). C* C* Wind speed in m/sec ( 0 11 002 ). C CALL UT_RIBF ( iunbfo, 'WSPD', rivals ( irsped ), ierrbf ) C C* Wind speed in knots. Convert to m/s. C CALL UT_RIBF ( iunbfo, 'WSPD', + PR_KNMS ( rivals ( irsknt ) ), ierrbf ) C C* Wind gust in m/sec ( 0 11 041 ). C IF ( .not. ERMISS ( rivals ( irgums ) ) ) THEN C C* Duration in minutes of wind gust period C CALL UT_RIBF ( iunbfo, '.DTMMXGS', 10.0, ierrbf ) CALL UT_RIBF ( iunbfo, 'MXGS', rivals ( irgums ), ierrbf ) END IF C C* Wind gust in knots. Convert to m/s. C IF ( .not. ERMISS ( rivals ( irgust ) ) ) THEN C C* Duration in minutes of wind gust period C CALL UT_RIBF ( iunbfo, '.DTMMXGS', 10.0, ierrbf ) CALL UT_RIBF ( iunbfo, 'MXGS', + PR_KNMS ( rivals ( irgust ) ), ierrbf ) END IF C C* First variable wind direction ( 0 11 016 ). C CALL UT_RIBF ( iunbfo, 'DRC1', rivals ( irdrc1 ), ierrbf ) C C* Second variable wind direction ( 0 11 017 ). C CALL UT_RIBF ( iunbfo, 'DRC2', rivals ( irdrc2 ), ierrbf ) C C* Hour of wind shift ( 0 04 212 ). C CALL UT_RIBF ( iunbfo, 'WSHFTH', rivals ( irwshh ), ierrbf ) C C* Minute of hour of wind shift ( 0 04 213 ). C CALL UT_RIBF ( iunbfo, 'WSHFTM', rivals ( irwshm ), ierrbf ) C C* Dry bulb temperature in Kelvin ( 0 12 001 ) C CALL UT_RIBF ( iunbfo, 'TMDB', + PR_TMCK ( rivals ( irtmpc ) ), ierrbf ) C C* Dew point temperature in Kelvin ( 0 12 003 ) C CALL UT_RIBF ( iunbfo, 'TMDP', + PR_TMCK ( rivals ( irdwpc ) ), ierrbf ) C C* The 6 hour maximum and minimum temperatures in Kelvin. C* BUFR descriptors ( 0 12 111 ) and ( 0 12 112 ). C mrep = 0 IF ( .not. ERMISS ( rivals ( irt6xc ) ) ) THEN mrep = 1 r8mmt ( LTDTHX, mrep ) = UT_RIBM ( 6.0 ) r8mmt ( LTMXTM, mrep ) = + UT_RIBM ( PR_TMCK ( rivals ( irt6xc ) ) ) END IF IF ( .not. ERMISS ( rivals ( irt6nc ) ) ) THEN mrep = 1 r8mmt ( LTDTHI, mrep ) = UT_RIBM ( 6.0 ) r8mmt ( LTMITM, mrep ) = + UT_RIBM ( PR_TMCK ( rivals ( irt6nc ) ) ) END IF C C* The 24 hour maximum and minimum temperatures in Kelvin. C* BUFR descriptors ( 0 12 111 ) and ( 0 12 112 ). C IF ( .not. ERMISS ( rivals ( irtdxc ) ) .or. + .not. ERMISS ( rivals ( irtdnc ) ) ) THEN mrep = mrep + 1 END IF C IF ( .not. ERMISS ( rivals ( irtdxc ) ) ) THEN r8mmt ( LTDTHX, mrep ) = UT_RIBM ( 24.0 ) r8mmt ( LTMXTM, mrep ) = + UT_RIBM ( PR_TMCK ( rivals ( irtdxc ) ) ) END IF IF ( .not. ERMISS ( rivals ( irtdnc ) ) ) THEN r8mmt ( LTDTHI, mrep ) = UT_RIBM ( 24.0 ) r8mmt ( LTMITM, mrep ) = + UT_RIBM ( PR_TMCK ( rivals ( irtdnc ) ) ) END IF IF ( mrep .gt. 0 ) THEN CALL UFBINT ( iunbfo, r8mmt, NCMMT, mrep, ierufb, + CMMTST ) END IF C C* City hourly temperature in Kelvin ( 0 12 193 ) C CALL UT_RIBF ( iunbfo, 'CTTP', + PR_TMFK ( rivals ( ircttp ) ), ierrbf ) C C* City max temperature in Kelvin ( 0 12 194 ) C CALL UT_RIBF ( iunbfo, 'CTMX', + PR_TMFK ( rivals ( irctmx ) ), ierrbf ) C C* City min temperature in Kelvin ( 0 12 195 ) C CALL UT_RIBF ( iunbfo, 'CTMN', + PR_TMFK ( rivals ( irctmn ) ), ierrbf ) C C* Altimeter setting ( 0 10 052 ). Either alti or altm will C* be set (not both). C* Convert from inches to pascals. C CALL UT_RIBF ( iunbfo, 'ALSE', + PR_M100 ( PR_ALTM ( rivals ( iralti ) ) ), ierrbf ) C C* Convert from millibars to pascals. C CALL UT_RIBF ( iunbfo, 'ALSE', + PR_M100 ( rivals ( iraltm ) ), ierrbf ) C C* Mean sea level pressure in pascals ( 0 10 051 ) C CALL UT_RIBF ( iunbfo, 'PMSL', + PR_M100 ( rivals ( irpmsl ) ), ierrbf ) C C* Characteristic of pressure change ( 0 10 063 ) C* irp03d contains both pressure tendency and change, so first C* get tendency out of the variable. E.g. if p03d = 5125, then C* first divide by 1000 (gives you 5.125), then truncate to get C* just the 5. C IF ( .not. ERMISS ( rivals ( irp03d ) ) ) THEn ip03d = INT ( PR_HGMK ( rivals ( irp03d ) ) ) CALL UT_RIBF ( iunbfo, 'CHPT', FLOAT ( ip03d ), ierrbf ) C C* 3-hour pressure change ( 0 10 061 ). C C* Note: Maximum positve pressure change value allowed in C* BUFR is 52.3mb (1023-500) (10-bit BUFR width) C* Minimum negative pressure change value allowed C* in BUFR is -49.9mb (-499+500) C CALL UT_RIBF ( iunbfo, '3HPC', + PR_P03C ( rivals ( irp03d ) ), ierrbf ) END IF C C* Add precipitation data to BUFR subset. C C* Get the observation hour of report. Use irtarr(4) for obs hour C* rather than actual obs hour (rivals(irhour)) since reports are C* sent early for each hour. I.e. a "0000Z" report is actually sent C* with report hour/minute of, say, 2354Z from the previous day. The C* subroutine rartim.f (called by mtdcod.f) takes the "early" report C* hour/min into account when setting the irtarr array elements (it C* rounds up to the next hour), so that a 2354Z report could be C* recognized as being the "0000Z" report, or a 0254Z report would be C* recognized as being the "0300Z" report. By using irtarr(4) (the C* 'hour' array element), the precip reported within the 2354Z report C* would be recognized as being the 0000Z precip, which is what we want C* stored into (e.g.) TP03 and TP06. If we used the actual report hour C* (rivals(irhour)), then the jobshr seen below would be 23, which isn't C* evenly divisible by 6, so the 2354Z report's precip wouldn't be saved C* into TP06 (e.g.). Instead, the 0054Z report, if it included precip, C* would be stored into TP06 (since irhour would be 00), but this would C* actually be the '0100Z' report! C jobshr = irtarr ( 4 ) irm3 = MOD ( jobshr, 3 ) irm6 = MOD ( jobshr, 6 ) IF ( irm6. eq. 0 ) irm3 = -1 C C* Total precip past 6 hours ( 0 13 021 ) C C* If precipitation group set to slashes in raw C* report, then precip is missing (indeterminable) C* and rivals(irp06i) will already be set to -99. Same C* is true for 3 hr precip. C IF ( NINT ( rivals ( irp06i ) ) .ne. -99 .and. + ( .not. ERMISS ( rivals ( irp06i ) ) ) .and. + irm6 .eq. 0 ) THEN IF ( rivals ( irp06i ) .eq. -0.1 ) THEN C C* Trace of precipitation C CALL UT_RIBF ( iunbfo, 'TP06', -0.1, ierrbf ) ELSE C C* Convert from inches to millimeters C CALL UT_RIBF ( iunbfo, 'TP06', + PR_INMM ( rivals ( irp06i ) ), ierrbf ) END IF END IF C C* Total precip past 24 hours ( 0 13 023 ) C IF ( NINT ( rivals ( irp24i ) ) .ne. -99 .and. + ( .not. ERMISS ( rivals ( irp24i ) ) ) .and. + jobshr .eq. 12 ) THEN IF ( rivals ( irp24i ) .eq. -0.1 ) THEN C C* Trace of precipitation C CALL UT_RIBF ( iunbfo, 'TP24', -0.1, ierrbf ) ELSE C C* Convert from inches to millimeters C CALL UT_RIBF ( iunbfo, 'TP24', + PR_INMM ( rivals ( irp24i ) ), ierrbf ) END IF END IF C C* Total precip past 1 hour ( 0 13 019 ) C IF ( ( NINT ( rivals ( irp01i ) ) .ne. -99 ) .and. + ( .not. ERMISS ( rivals ( irp01i ) ) ) ) THEN IF ( rivals ( irp01i ) .eq. -0.1 ) THEN C C* Trace of precipitation C CALL UT_RIBF ( iunbfo, 'TP01', -0.1, ierrbf ) ELSE C C* Convert from inches to millimeters C CALL UT_RIBF ( iunbfo, 'TP01', + PR_INMM ( rivals ( irp01i ) ), ierrbf ) END IF END IF C C* Total precip past 3 hours ( 0 13 020 ) C IF ( NINT ( rivals ( irp03i ) ) .ne. -99 .and. + ( .not. ERMISS ( rivals ( irp03i ) ) ) .and. + irm3 .eq. 0 ) THEN IF ( rivals ( irp03i ) .eq. -0.1 ) THEN C C* Trace of precipitation C CALL UT_RIBF ( iunbfo, 'TP03', -0.1, ierrbf ) ELSE C C* Convert from inches to millimeters C CALL UT_RIBF ( iunbfo, 'TP03', + PR_INMM ( rivals ( irp03i ) ), ierrbf ) END IF END IF C C* Number of sky conditon groups (max = 6) C nrep = NINT ( rivals ( irnsky ) ) C IF ( nrep .gt. 0 .and. nrep .le. 6 ) THEN C C* Get GEMPAK sky cover code C DO i = 1, nrep skyvals(i) = rivals ( ircmtn ( i ) ) END DO C C* Convert GEMPAK sky cover numbers to BUFR values C ndesc = 4 C CALL MT_BFCL ( skyvals, nrep, ndesc, valcld, iret ) C END IF C C* Get the low, middle, and high level cloud types C C IF ( .not. ( ERMISS ( rivals ( irctyl ) ) ) ) THEN nrep = nrep + 1 valcld(1,nrep) = 7. valcld(3,nrep) = rivals ( irctyl ) + 30. END IF IF ( .not. ( ERMISS ( rivals ( irctym ) ) ) ) THEN nrep = nrep + 1 valcld(1,nrep) = 8. valcld(3,nrep) = rivals ( irctym ) + 20. END IF IF ( .not. ( ERMISS ( rivals ( irctyh ) ) ) ) THEN nrep = nrep + 1 valcld(1,nrep) = 9. valcld(3,nrep) = rivals ( irctyh ) + 10. END IF C IF ( nrep .gt. 0 ) THEN DO j = 1, nrep DO i = 1, NCCLD r8cld ( i, j ) = UT_RIBM ( valcld ( i, j ) ) END DO END DO C C* The obscuration (X) data of an SAO report is not C* decoded correctly. The following logic corrects C* the problem by setting the vertical visibility to C* the cloud height and then setting the cloud height C* to missing. This is a temporary fix, until the C* problem can be corrected in the SAO decoding section. C IF ( saoflg ) THEN IF ( r8cld ( 2, 1 ) .eq. 9.0 .or. + r8cld ( 2, 1 ) .eq. 10.0 ) THEN IF ( r8cld ( 4, 1 ) .gt. 0.0 .and. + civals ( icstid )( 1:1 ) .eq. 'C' ) THEN rivals ( irvrtv ) = PR_HGMF ( r8cld ( 4, 1 ) ) r8cld ( 4, 1 ) = r8bfms END IF END IF END IF CALL UFBINT ( iunbfo, r8cld, NCCLD, nrep, ierufb, + CCLDST ) END IF C C* Vertical visibility in feet ( 0 20 002 ). Convert to meters. C CALL UT_RIBF ( iunbfo, 'VTVI', + PR_HGFM ( rivals ( irvrtv ) ), ierrbf ) C C* Horizontal visibility in kilometers ( 0 20 001 ). C* Either vsbk or vsby will be reported (not both). Convert to meters. C IF ( .not. ERMISS ( rivals ( irvsbk ( 1 ) ) ) ) THEN vflag = .true. xvis = PR_HGKM ( rivals ( irvsbk ( 1 ) ) ) END IF C C* Horizontal visibility in statute miles. Convert to meters. C IF ( .not. ERMISS ( rivals ( irvsby ( 1 ) ) ) ) THEN vflag = .true. xvis = PR_HGFM ( PR_HGSF ( rivals ( irvsby ( 1 ) ) ) ) END IF C C* BUFR data width limit of 13 for horiz. visiblity means max C* allowed is approx 50 SM (80467.5m). C IF ( xvis .gt. 81900. ) THEN xvis = 81900. rivals ( irvsfl(1) ) = 4.0 END IF C C* Relationship to the following code table value C xrelfl = rivals ( irvsfl(1) ) C IF ( vflag ) THEN C IF ( ERMISS ( xrelfl ) ) THEN xrelfl = 2.0 END IF C IF ( xrelfl .lt. 8.0 ) THEN CALL UT_RIBF ( iunbfo, '.REHOVI', + xrelfl, ierrbf ) END IF C C* Horizontal visibility in meters (0 20 001) C* Convert hovi back to kilometers for use when encoding C* weather (see below). C CALL UT_RIBF ( iunbfo, 'HOVI', xvis, ierrbf ) hviskm = PR_HGMK ( xvis ) END IF C C* Number of runway groups (max = 4) C nrep = NINT ( rivals ( irnrwy ) ) C IF ( nrep .gt. 0 .and. nrep .le. 4 ) THEN DO i = 1, nrep C C* Runway ID ( 0 01 064 ) C IF ( civals ( icrwid ( i ) )( 1:1 ) .ne. ' ' ) THEN CALL UT_C2R8 ( civals ( icrwid ( i ) ), 8, + r8val, nr8val, ier2r8 ) IF ( ier2r8 .eq. 0 ) THEN r8rwy ( LRRWID, i ) = r8val END IF END IF C C* Relationship to following value ( 0 08 201 ) C r8rwy ( LRREV1, i ) = + UT_RIBM ( rivals ( irv1rf ( i ) ) ) C C* First runway visual range ( 0 20 061 ) C r8rwy ( LRV1RI, i ) = + UT_RIBM ( rivals ( irv1ri ( i ) ) ) C C* Relationship to following value ( 0 08 201 ) C r8rwy ( LRREV2, i ) = + UT_RIBM ( rivals ( irv2rf ( i ) ) ) C C* Second runway visual range ( 0 20 193 ) C r8rwy ( LRV2RI, i ) = + UT_RIBM ( rivals ( irv2ri ( i ) ) ) r8rwy ( LRRWYT, i ) = + UT_RIBM ( rivals ( irrwyt ( i ) ) ) END DO CALL UFBINT ( iunbfo, r8rwy, NCRWY, nrep, ierufb, + CRWYST ) END IF C C* Number of present weather groups (max = 3) C nrep = NINT ( rivals ( irnpwx ) ) IF ( nrep .gt. 0 .and. nrep .le. 3 ) THEN C C* Determine if manned or automatic station C IF ( rivals ( irauto ) .gt. -1.0 .and. + rivals ( irauto ) .le. 4.0 ) THEN iauto = 2 ELSE C C* Observer coded all or part of the report. C iauto = 1 END IF C C* Convert METAR present wx groups into BUFR descriptors. C DO i = 1, nrep wx ( i ) = civals ( icwcod ( i ) ) END DO C CALL UT_BFPW ( wx, iauto, iarr, inumd, iret ) IF ( iret .eq. 0 ) THEN C C* Get the number of present weather code table values C inum = MAX ( inumd (1), inumd (2), inumd (3) ) IF ( inum .gt. 0 .and. inum .le. 12 ) THEN DO j = 1, inum rwx = FLOAT ( iarr ( j ) ) C C* Check if HZ and visibility less than 1km C IF ( iarr ( j ) .eq. 104 .and. + ( hviskm .ge. 0.0 .and. hviskm .lt. 1.0 ) ) THEN rwx = 105. END IF C C* Check vis if blowing or drifting dust, snow, or sand. C* BLDU, BLSA, BLSN, or DRSN are stored as code 127 from C* UT_BFPA. Drifting dust or sand (DRDU and DRSA) are C* stored as code 208 by UT_BFPA. C IF ( iarr ( j ) .eq. 127 .or. iarr ( j ) .eq. 208 ) THEN IF( hviskm .ge. 0.0 ) THEN IF ( hviskm .lt. 1.0 ) THEN rwx = 129. ELSE rwx = 128. END IF END IF END IF r8pwx ( 1, j ) = UT_RIBM ( rwx ) END DO CALL UFBINT ( iunbfo, r8pwx, 1, inum, ierufb, + 'PRWE' ) END IF END IF END IF C C* Depth of fresh snow in inches C IF ( .not. ERMISS ( rivals ( irsnew ) ) ) THEN C C* Duration of period of newly fallen snow is 1 hour C* (according to NWS Observing Handbook #7, Part I - Manual C* Observations; p. 10-14, under rules for Snow Increasing C* Rapidly (SNINCR). C C* Commenting out for now until next update of bufrtab.000 (upon C* which time this shall be added to metar format). C c CALL UT_RIBF ( iunbfo, '.DTHDOFS', 1.0, ierrbf ) C C* Depth of newly fallen snow ( 0 13 012 ) C* Convert from inches to mm, then from mm to m. C IF ( rivals ( irsnew ) .ge. 0.0 ) THEN CALL UT_RIBF ( iunbfo, 'DOFS', + PR_HGMK ( PR_INMM ( rivals ( irsnew ) ) ), ierrbf ) END IF END IF C C* Total depth of snow on the ground ( 0 13 013 ) C IF ( rivals ( irsnow ) .ge. 0.0 ) THEN CALL UT_RIBF ( iunbfo, 'TOSD', + PR_HGMK ( PR_INMM ( rivals ( irsnow ) ) ), ierrbf ) END IF C C* Total precipitation/total water equivalent ( 0 13 011 ) C CALL UT_RIBF ( iunbfo, 'TOPC', + PR_INMM ( rivals ( irweqs ) ), ierrbf ) C C* Total sunshine ( 0 14 031 ) C CALL UT_RIBF ( iunbfo, 'TOSS', rivals ( irmsun ), ierrbf ) C* Check direction of peak wind ( 0 11 202 ). If not missing, then C* save obs date/time (for these data types, will overwrite previous C* storage of obs date/time), peak wind date/time, peak wind direction, C* and peak wind speed. C IF ( .not. ERMISS ( rivals ( irpwdr ) ) ) THEN r8pkw ( LPYEAR, 1 ) = + UT_RIBM ( rivals ( iryear ) ) r8pkw ( LPMNTH, 1 ) = + UT_RIBM ( rivals ( irmnth ) ) r8pkw ( LPDAYS, 1 ) = + UT_RIBM ( rivals ( irdays ) ) r8pkw ( LPHOUR, 1 ) = + UT_RIBM ( rivals ( irhour ) ) r8pkw ( LPMINU, 1 ) = + UT_RIBM ( rivals ( irminu ) ) C C* Save obs time of peak wind direction and speed so we can check to C* see if obs time was in the previous day. C jrptdt(1) = rivals ( iryear ) jrptdt(2) = rivals ( irmnth ) jrptdt(3) = rivals ( irdays ) jrptdt(4) = INT ( rivals ( irpwhr ) ) jrptdt(5) = INT ( rivals ( irpwmn ) ) C IF ( jrptdt(4) .gt. rivals ( irhour ) ) THEN C C* Backdate to previous day. C CALL TI_SUBD ( jrptdt, jrptdt, ier ) END IF r8pkw ( LPYEAR, 2 ) = + UT_RIBM ( FLOAT ( jrptdt ( 1 ) ) ) r8pkw ( LPMNTH, 2 ) = + UT_RIBM ( FLOAT ( jrptdt ( 2 ) ) ) r8pkw ( LPDAYS, 2 ) = + UT_RIBM ( FLOAT ( jrptdt ( 3 ) ) ) r8pkw ( LPHOUR, 2 ) = + UT_RIBM ( FLOAT ( jrptdt ( 4 ) ) ) r8pkw ( LPMINU, 2 ) = + UT_RIBM ( FLOAT ( jrptdt ( 5 ) ) ) C C* peak wind direction ( 0 11 202 ) C r8pkw ( LPPKWD, 2 ) = + UT_RIBM ( rivals ( irpwdr ) ) C C* peak wind speed ( 0 11 203 ) C r8pkw ( LPPKWS, 2 ) = + UT_RIBM ( PR_KNMS ( rivals ( irpwsp ) ) ) CALL UFBREP ( iunbfo, r8pkw, NCPKW, 2, ierufb, + CPKWST ) END IF C C* Sea surface temperature in Kelvin ( 0 22 043 ) C CALL UT_RIBF ( iunbfo, 'SST1', + PR_TMCK ( rivals ( irsst1 ) ), ierrbf ) C C* State of the sea ( 0 22 061 ) (Code table 3700) C CALL UT_RIBF ( iunbfo, 'SEST', + rivals ( irsest ) , ierrbf ) C C* Retrieve raw report and add it to BUFR subset. C IF ( lenr .gt. MXBFRR ) THEN WRITE ( UNIT = logmsg, FMT = '( A, I4, A )' ) + 'Only stored first ', MXBFRR, ' bytes of raw report' CALL DC_WLOG ( 4, 'MT', 1, logmsg, ierwlg ) END IF CALL UT_CIBF ( iunbfo, 'RRSTG', mtrpt, lenr, iercbf ) C C* Write BUFR message to BUFR output file C CALL UT_WBFR ( iunbfo, 'metar', 0, ierwbf ) C* RETURN END