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