SUBROUTINE BT_BUFR( bufrtb, last, report, mszrpt, iret )
C************************************************************************
C* BT_BUFR *
C* *
C* This routine creates BATHY, TESAC, and TRACKOB BUFR messages. A *
C* BUFR message contains subsets of all the same message type. The *
C* current report data will be converted to a BUFR subset and added to *
C* the BUFR message which contains subsets of the same message type as *
C* the report. If none 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* BT_BUFR ( BUFRTB, LAST, REPORT, MSZRPT, IRET ) *
C* *
C* Input parameters: *
C* *
C* BUFRTB CHARACTER BUFR table file *
C* LAST LOGICAL Flag to tell routine no more *
C* reports; close files. *
C* IRPTYP INTEGER Report type identifier *
C* = 1, BATHY (JJYY) report *
C* = 2, TESAC (KKXX) report *
C* = 3, TRACKOB (NNXX) report *
C* = 4, BATHY (JJVV) report with *
C* a high precision lat/long *
C* = 5, TESAC (KKYY) report with *
C* a high precision lat/long *
C* MSZRPT INTEGER Byte size of report *
C* REPORT CHAR* Report array *
C* IRPTDT (*) INTEGER Report date-time *
C* (YYYY, MM, DD, HH, MM) *
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 11/98 *
C* R. Hollern/NCEP 01/99 Added code to create TESAC BUFR *
C* messages *
C* R. Hollern/NCEP 03/99 Added code to convert TRACKOB decoded *
C* data to BUFR *
C* R. Hollern/NCEP 04/00 Added more checks on report type *
C* C. Caruso Magee/NCEP 06/01 Replace WBMISS with R8BFMS and add *
C* new include to BUFR.CMN. *
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 Replace btbufr.cmn w/ btcmn_bufr.cmn; *
C* DBN_BUFR with new s/r UT_WBFR. *
C* C. Caruso Magee/NCEP 02/02 Change name to btbufr.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 btbufa.f plus all of *
C* the subroutines it previously called. *
C* C. Caruso Magee/NCEP 03/02 Add code to save to BUFR the subsfc *
C* depth, direction, and current speed. *
C* C. Caruso Magee/NCEP 01/03 Correct typo where indicator for units *
C* of wind speed and instrumentation *
C* type are converted and saved into BUFR. *
C* This s/r still had rivals(irisws) but *
C* it needs rivals(iriuws). *
C* C. Caruso Magee/NCEP 04/03 Change nlev of subsurface data from *
C* 200 to MXDLYR. *
C* R. Hollern/NCEP 02/03 Added logic to check that number of *
C* depths for temp/salinity and for dir/spd*
C* of current do not exceed MXDLYR. ADDED *
C* call to MAXOUT to be able to create BUFR*
C* messages as large as 20000 bytes. *
C* C. Caruso Magee/NCEP 01/2006 Modified how report year is stored into *
C* bufr, using irptdt(1) instead of old *
C* rivals (iryear). *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BUFR.CMN'
INCLUDE 'btcmn_bufr.cmn'
INCLUDE 'btcmn.cmn'
C*
CHARACTER*(*) bufrtb, report
LOGICAL first, last
C*
REAL*8 r8avp ( 1, TRKAVP ), r8dts ( NCDTS, MXDLYR*2),
+ r8dtc ( 1, 2 ), UT_RIBM, GETBMISS
REAL tiwm, rdigit
INTEGER iuws, idigit
CHARACTER subset*8, cval*8, buoyid*5
C*
DATA first / .true. /
C
SAVE
C*
INCLUDE 'ERMISS.FNC'
C-----------------------------------------------------------------------
C
iret = 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
C* Set the msglen to the maximum bufr message size.
C
msglen = 20000
C
CALL MAXOUT ( msglen )
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
IF ( irptyp .eq. 1 .or. irptyp .eq. 4 ) THEN
C
C* Bathy report.
C
subset = 'NC031001'
ELSE IF ( irptyp .eq. 2 .or. irptyp .eq. 5 ) THEN
C
C* Tesac report.
C
subset = 'NC031002'
ELSE IF ( irptyp .eq. 3 ) THEN
C
C* Trackob report.
C
subset = 'NC031003'
ELSE
RETURN
END IF
C
C* Open BUFR file for output
C
CALL OPENMB ( iunbfo, subset, ibfdt )
C
C* Initialize BUFR output arrays.
C
DO j = 1, TRKAVP
r8avp(1,j) = r8bfms
END DO
DO j = 1, 2
r8dtc(1,j) = r8bfms
END DO
DO jj = 1, MXDLYR*2
DO ii = 1, NCDTS
r8dts ( ii, jj ) = r8bfms
END DO
END DO
C
C* Set irepl = 0 to indicate that the following mnemonics
C* are not replicated.
C
irepl = 0
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* Ship report.
C* Save the ship report ID (RPID) in upper case ( 0 01 011 ).
C
IF ( idtype .eq. 0 .or. idtype .eq. 2 ) THEN
cval = civals ( icstid )
CALL ST_LCUC ( cval ( 1:8 ), cval ( 1:8 ), iret )
CALL UT_CIBF ( iunbfo, 'SHPC8', cval, 8, iercbf )
END IF
C
IF ( idtype .eq. 1 ) THEN
C
C* Character stationary buoy ID ( 0 01 010 ).
C
CALL UT_CIBF ( iunbfo, 'SBPI', civals(icstid), 8, iercbf )
C
C* Numeric buoy ID ( 0 01 005 ).
C
buoyid = civals(icstid)(1:5)
CALL ST_INTG ( buoyid, ival, ier )
IF ( ier .eq. 0 ) THEN
CALL UT_RIBF ( iunbfo, 'BPID', FLOAT(ival), ierrbf )
END IF
END IF
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* Report date-time.
C
CALL UT_RIBF ( iunbfo, 'YEAR', FLOAT ( irptdt (1) ), 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
IF ( irptyp .eq. 1 .or. irptyp .eq. 2 .or.
+ irptyp .eq. 4 .or. irptyp .eq. 5 ) THEN
C
C* Bathy or Tesac report, either regular or high precision
C* lat/long.
C
C* High accuracy longitude ( 0 06 001 ) and latitude (0 05 001)
C
CALL UT_RIBF ( iunbfo, 'CLONH', rivals ( irslon ), ierrbf )
CALL UT_RIBF ( iunbfo, 'CLATH', rivals ( irslat ), ierrbf )
C
C* Indicator for units of wind speed and instrumentation type
C* Convert to BUFR code table
C
IF ( .not. ERMISS ( rivals ( iriuws ) ) ) THEN
iuws = NINT ( rivals ( iriuws ) )
IF ( iuws .eq. 0 ) THEN
tiwm = 8.0
ELSE IF ( iuws .eq. 1 ) THEN
tiwm = 12.0
ELSE IF ( iuws .eq. 2 ) THEN
tiwm = 0.0
ELSE IF ( iuws .eq. 3 ) THEN
tiwm = 4.0
ELSE
tiwm = RMISSD
END IF
CALL UT_RIBF ( iunbfo, 'TIWM', tiwm, ierrbf )
END IF
C
C* Wind direction in degrees. If wind is light and variable
C* (direction was reported as '99'), set wind direction to 0.
C
IF ( INT ( rivals ( irdrct ) ) .eq. 99 .and.
+ rivals ( irsped ) .gt. 0.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/sec
C
CALL UT_RIBF ( iunbfo, 'WSPD', rivals ( irsped ), ierrbf )
C
C* Dry bulb temperature in Kelvin ( 0 12 001 )
C
CALL UT_RIBF ( iunbfo, 'TMDB',
+ PR_TMCK ( rivals ( irtmpc ) ), ierrbf )
C
C* Total water depth in meters ( 0 22 063 )
C
CALL UT_RIBF ( iunbfo, 'TOWD', rivals ( irtowd ), ierrbf )
C
C* Indicator for digitization ( 0 02 032 )
C
IF ( .not. ERMISS ( rivals ( iridgt ) ) ) THEN
idigit = NINT ( rivals ( iridgt ) )
IF ( idigit .eq. 7 ) THEN
rdigit = 0.0
ELSE IF ( idigit .eq. 8 ) THEN
rdigit = 1.0
ELSE
rdigit = RMISSD
END IF
CALL UT_RIBF ( iunbfo, 'IDGT', rdigit, ierrbf )
END IF
C
C* Instrument type for XBT ( 0 22 067 )
C
CALL UT_RIBF ( iunbfo, 'IWTEMP',
+ rivals ( iriwtm ), ierrbf )
C
C* Water temperature profile recorder types ( 0 22 068 )
C
CALL UT_RIBF ( iunbfo, 'WTEMPR',
+ rivals ( irwtmr ), ierrbf )
C
C* Indicator for the method of current measurement ( 0 02 030 )
C
CALL UT_RIBF ( iunbfo, 'MCMS', rivals ( irmcms ), ierrbf )
C
C* Method of salinity/depth measurement ( 0 02 033 )
C
CALL UT_RIBF ( iunbfo, 'MSDM', rivals ( irmsdm ), ierrbf )
C
C* Save parameters only found in TESAC reports.
C
IF ( irptyp .eq. 2 .or. irptyp .eq. 5 ) THEN
C
C* Method of removing velocity and motion of platform from
C* current measurement. ( 0 02 040 )
C
CALL UT_RIBF ( iunbfo, 'MRMV',
+ rivals ( irmrmv ), ierrbf )
C
C* Duration and time of current measurement (vector or Doppler
C* current profiling method) and Period of current measurement
C* ( 0 02 031 ).
C
r8dtc ( 1, 1 ) = UT_RIBM ( rivals ( irdtcc ) )
IF ( .not. ERMISS ( rivals ( irpocm ) ) ) THEN
r8dtc ( 1, 2 ) = UT_RIBM ( rivals ( irpocm ) + 10. )
END IF
CALL UFBINT ( iunbfo, r8dtc, 1, 2, ierufb, 'DTCC' )
END IF
END IF
C
IF ( irptyp .eq. 3 ) THEN
C
C* Averaging periods for trackob parameters. ( 0 22 194 )
C* iravgp = 9 means data aren't available.
C
yavp = 0.0
DO j = 1, TRKAVP
IF ( .not. ERMISS ( rivals ( iravgp ( j ) ) ) ) THEN
IF ( NINT ( rivals ( iravgp ( j ) ) ) .ne. 9 ) THEN
ravp = rivals ( iravgp ( j ) ) + yavp
ELSE
ravp = yavp + 4.0
END IF
r8avp ( 1, j ) = UT_RIBM ( ravp )
END IF
yavp = yavp + 5.0
END DO
CALL UFBINT ( iunbfo, r8avp, 1, TRKAVP, ierufb,
+ 'AVGPER' )
C
C* Indicator for units of sea-surface current speed. ( 0 22 196 )
C* Only store into BUFR if it equals 0 (m/s) or 1 (kts).
C* 9 means no sea current data were available.
C
IF ( NINT ( rivals ( irucsp ) ) .ne. 9 ) THEN
CALL UT_RIBF ( iunbfo, 'IUCSPD',
+ rivals ( irucsp ), ierrbf )
END IF
END IF
C
C* Add depth, temperature at depth, salinity, direction
C* of current, and speed of current to BUFR subset.
C
ndts = NINT ( rivals ( irndts ) )
nddc = NINT ( rivals ( irnddc ) )
C
IF ( ndts .gt. 0 ) THEN
DO j = 1, ndts
C
C* Depth in meters ( 0 07 062 )
C
r8dts ( LDDBSS, j ) =
+ UT_RIBM ( rivals ( irdbss ( j ) ) )
C
C* Sea temperature ( 0 22 043 )
C
r8dts ( LDSTMP, j ) =
+ UT_RIBM ( PR_TMCK ( rivals ( irstmp ( j ) ) ) )
C
C* Salinity ( 0 22 062 )
C
r8dts ( LDSALN, j ) =
+ UT_RIBM ( rivals ( irsaln ( j ) ) )
END DO
END IF
C
IF ( nddc .gt. 0 ) THEN
DO k = 1, nddc
C
C* Depth in meters ( 0 07 062 )
C
r8dts ( LDDBSS, ndts + k ) =
+ UT_RIBM ( rivals ( irdbsc ( k ) ) )
C
C* Direction of the current ( 0 22 004 )
C
r8dts ( LDDROC, ndts + k ) =
+ UT_RIBM ( rivals ( irdroc ( k ) ) )
C
C* Speed of the current ( 0 22 031 )
C
r8dts ( LDSPOC, ndts + k ) =
+ UT_RIBM ( rivals ( irspoc ( k ) ) )
END DO
END IF
C
C* Add number of depth/temp/salinity to number of depth/dir/spd
C* of current.
C
ndep = ndts + nddc
C
IF ( ndep .gt. 0 ) THEN
CALL UFBINT ( iunbfo, r8dts, NCDTS, ndep, ierufb, CDTSST )
END IF
C
C* Retrieve raw report
C
IF ( mszrpt .gt. MXBFRR16 ) THEN
WRITE ( UNIT = logmsg, FMT = '( A, I4, A )' )
+ 'Only stored first ',MXBFRR16, ' bytes of raw report'
CALL DC_WLOG ( 4, 'BT', 1, logmsg, ierwlg )
END IF
C
CALL UT_CIBF ( iunbfo, 'RRSTG', report, mszrpt, iercbf )
C
C* Write BUFR message to BUFR output file
C
CALL UT_WBFR ( iunbfo, 'bathy', 0, ierwbf )
C*
RETURN
END