SUBROUTINE TG_BUFR( bufrtb, last, tidrpt, tszrpt, iret ) C************************************************************************ C* TG_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* TG_BUFR ( BUFRTB, LAST, TIDRPT, TSZRPT, IRET ) * C* * C* Input parameters: * C* * C* BUFRTB CHARACTER BUFR table file * C* LAST LOGICAL Flag used to tell routine * C* when to close BUFR files * C* TSZRPT INTEGER Byte size of report * C* TIDRPT CHAR* Current report * 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 08/00 * C* C. Caruso Magee/NCEP 06/01 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 02/02 Change name to tgbufr.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 mabufa.f plus all of * C* the subroutines it previously called. * C* C. Caruso Magee/NCEP 03/05 Correct logic which checked wspd to see * C* if it equaled 0 (was causing wdir to be * C* set to 0 even if wspd was equal to * C* RMISSD). * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BUFR.CMN' INCLUDE 'tgcmn_bufr.cmn' INCLUDE 'tgcmn.cmn' C* CHARACTER*(*) bufrtb, tidrpt INTEGER tszrpt LOGICAL first, last C* REAL*8 r8tel ( NCTEL, MXTIDL ), UT_RIBM, GETBMISS CHARACTER subset*8 C* DATA first / .true. / C SAVE C----------------------------------------------------------------------- iret = 0 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 ibfdt = ( irptdt (1) * 1000000 ) + + ( irptdt (2) * 10000 ) + ( irptdt (3) * 100 ) + + irptdt (4) C C* Tide gauge report C subset = 'NC001005' istyp = 5 C C* Open BUFR file for output C CALL OPENMB ( iunbfo, subset, ibfdt ) C C* Initialize BUFR output arrays. C DO jj = 1, MXTIDL DO ii = 1, NCTEL r8tel ( ii, jj ) = r8bfms END DO END DO C C* Add bulletin header information 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. C CALL UT_CIBF ( iunbfo, 'RPID', civals(icstid), 8, iercbf ) C C* Longitude. C CALL UT_RIBF ( iunbfo, 'CLON', rivals ( irslon ), ierrbf ) C C* Latitude. C CALL UT_RIBF ( iunbfo, 'CLAT', rivals ( irslat ), ierrbf ) C C* Station elevation in meters. C CALL UT_RIBF ( iunbfo, 'SELV', rivals ( irselv ), ierrbf ) C C* Corrected report indicator C IF ( bbb (1:1) .eq. 'C' ) THEN xx = 1.0 ELSE xx = 0.0 END IF CALL UT_RIBF ( iunbfo, 'CORN', xx, ierrbf ) C C* Type of station -- automatic. C CALL UT_RIBF ( iunbfo, 'TOST', rivals ( irtost ), 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* Add the water level data to the BUFR subset. C C* Sea surface temperature in Kelvin ( 0 22 042 ) C CALL UT_RIBF ( iunbfo, 'SST1', rivals ( irsstk ), ierrbf ) C C* Tide station automated water level check (0 22 120). C CALL UT_RIBF ( iunbfo, 'AWCK', rivals ( irawck ), ierrbf ) C C* Tide station manual water level check (0 22 121). C CALL UT_RIBF ( iunbfo, 'MWCK', rivals ( irmwck ), ierrbf ) C C* Time period or displacement (0 04 025) C CALL UT_RIBF ( iunbfo, 'TPMI', rivals ( irtpmi ), ierrbf ) C C* Time Increment (0 04 015) C CALL UT_RIBF ( iunbfo, 'TIMI', rivals ( irstmi ), ierrbf ) C C* Tidal elevation series data. C nval = NINT ( rivals( irntid) ) IF ( nval .gt. 0 .and. nval .le. 6 ) THEN DO j = 1, nval C C* Tidal elevation with respect to chart datum (0 22 038 ). C r8tel ( LTTERC, j ) = + UT_RIBM ( rivals ( irterc ( j ) ) ) C C* Meterological residual tidal elevation (0 22 039 ). C r8tel ( LTMRTE, j ) = + UT_RIBM ( rivals ( irmrte ( j ) ) ) END DO CALL UFBINT ( iunbfo, r8tel, NCTEL, nval, ierufb, + CTELST ) END IF C C* Tide station automated meteorological data check ( 0 22 122 ). C CALL UT_RIBF ( iunbfo, 'AMCK', rivals ( iramck ), ierrbf ) C C* Tide station manual meteorological data check ( 0 22 123 ). C CALL UT_RIBF ( iunbfo, 'MMCK', rivals ( irmmck ), ierrbf ) C C* Dry bulb temperature in Kelvin ( 0 12 101 ) C CALL UT_RIBF ( iunbfo, 'TMDB', + PR_TMCK ( rivals ( irtmpc ) ), ierrbf ) C C* Pressure in Pascals ( 0 10 051 ) C C* The pressure reported from the tide stations is C* really a mean sea level pressure. C CALL UT_RIBF ( iunbfo, 'PMSL', + PR_M100 ( rivals ( irprlc ) ), ierrbf ) C C* Wind direction in degrees ( 0 11 001 ). If wind speed is 0.0 C* m/s, set wind direction to 0 deg to indicate calm conditions. C IF ( NINT ( rivals ( irsped ) ) .eq. 0 ) THEN CALL UT_RIBF ( iunbfo, 'WDIR', 0.0, ierrbf ) ELSE CALL UT_RIBF ( iunbfo, 'WDIR', rivals ( irdrct ), ierrbf ) END IF C C* Wind speed in m/s ( 0 11 002 ). C CALL UT_RIBF ( iunbfo, 'WSPD', rivals ( irsped ), ierrbf ) C C* Retrieve raw report C IF ( tszrpt .gt. MXBFRR ) THEN WRITE ( UNIT = logmsg, FMT = '( A, I4, A )' ) + 'Only stored first ', MXBFRR, ' bytes of raw report' CALL DC_WLOG ( 4, 'DCTIDG', 1, logmsg, ierwlg ) END IF CALL UT_CIBF ( iunbfo, 'RRSTG', tidrpt, tszrpt, iercbf ) C C* Write BUFR message to BUFR output file C CALL UT_WBFR ( iunbfo, 'tidg', 0, ierwbf ) C* RETURN END