SUBROUTINE MA_BUFR( bufrtb, last, marrpt, mszrpt, iret )
C************************************************************************
C* MA_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* MA_BUFR ( BUFRTB, LAST, MARRPT, MSZRPT, 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* IBRTYP INTEGER Bulletin report type *
C* 1 = BBXX reports *
C* 2 = CMAN reports *
C* MSZRPT INTEGER Byte size of report *
C* MARRPT CHAR* Report array *
C* IFBUOY INTEGER Fixed buoy report flag *
C* 0 = fixed buoy report *
C* 1 = not fixed buoy 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 6/96 *
C* R. Hollern/NCEP 8/96 Added the CALL to MA_BUFW *
C* R. Hollern/NCEP 12/97 New interface format, style changes *
C* J. Ator/NCEP 3/98 Use 4-digit year in call to OPENMB *
C* R. Hollern/NCEP 1/99 Renamed INCLUDE block ma.bufr.prm to *
C* mabufr.cmn *
C* R. Hollern/NCEP 7/99 Added the CALL to MA_BUFJ in the *
C* drifting buoy section *
C* R. Hollern/NCEP 9/99 Added the CALL to MA_BUFX *
C* R. Hollern/NCEP 12/99 Removed the drifting buoy logic *
C* R. Hollern/NCEP 9/00 Modified log message *
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/2002 Change name to mabufr.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/2002 Fix bug in determining number of cont. *
C* wind values (had nclo instead of ncwd). *
C* R. Hollern/NCEP 7/02 Added the NCEP BUFR Code Table 002038 *
C* and 002039 definitions for MSST and *
C* MWBT, respectivley. *
C* C. Caruso Magee/NCEP 03/2005 Add code to route tide gauge CMAN format*
C* reports to b001/xx008. *
C* J. Ator/NCEP 07/09 Use NC001013 for unrestricted ship data *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BUFR.CMN'
INCLUDE 'macmn.cmn'
INCLUDE 'macmn_bufr.cmn'
C*
CHARACTER*(*) bufrtb, marrpt
LOGICAL first, last, icont
C*
REAL*8 r8swv ( NCSWV, MXSLYR ),
+ r8cld ( NCCLD, MXCLYR ),
+ r8pkw ( NCPKW, 2 ),
+ r8cwd ( NCCWD, MXWLYR ),
+ UT_RIBM, UT_IWBF, PKFTBV, GETBMISS
REAL xx, bufrice(5), rice, risw
CHARACTER subset*8, cval*8, buoyid*5, lcase*26, ucase*26,
+ cbb*11
C*
DATA first / .true. /
C
DATA lcase / 'abcdefghijklmnopqrstuvwxyz' /
DATA ucase / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' /
C
DATA bufrice / 8., 4., 12., 2., 10. /
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
END IF
C
IF ( LAST ) then
C
C* Close BUFR output files
C
CALL CLOSBF ( lunbtb )
CALL CLOSBF ( iunbfo )
RETURN
END IF
C
loglvl = 4
logmsg = '<------------- BEGIN BUFR OUTPUT -------------->'
CALL DC_WLOG( loglvl, 'MA', 1, logmsg, ierwsg )
C
ibfdt = ( irptdt (1) * 1000000 ) +
+ ( irptdt (2) * 10000 ) + ( irptdt (3) * 100 ) +
+ irptdt (4)
C
C* ibrtyp = 0 indicates neither BBXX nor CMAN report
C* ibrtyp = 1 indicates BBXX report
C* ibrtyp = 2 indicates CMAN report
C* ifbuoy = 0 indicates buoy report
C* ifbuoy = 1 indicates ship report
C* smcman = T indicates sfc marine CMAN
C* tgcman = T indicates tide gauge CMAN
C
IF ( ibrtyp .eq. 1 .and. ifbuoy .eq. 0 ) THEN
C
C* Fixed buoy report
C
subset = 'NC001003'
ELSE IF ( ibrtyp .eq. 1 .and. ifbuoy .eq. 1 ) THEN
C
C* Ship report
C
C* Check if it's a restricted report.
C
cbb = buhd (1:6) // ' ' // cborg (1:4)
CALL DC_BSRC ( cbb, crshpb, nrshpb, ipos, ierbrc )
IF ( ipos .ne. 0 ) THEN
subset = 'NC001001'
ELSE
subset = 'NC001013'
END IF
ELSE IF ( ibrtyp .eq. 2 ) THEN
IF ( smcman ) THEN
C
C* sfc marine CMAN station report
C
subset = 'NC001004'
ELSE IF ( tgcman ) THEN
C
C* tide gauge CMAN station report
C
subset = 'NC001008'
END IF
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 jj = 1, MXSLYR
DO ii = 1, NCSWV
r8swv ( ii, jj ) = r8bfms
END DO
END DO
DO jj = 1, MXCLYR
DO ii = 1, NCCLD
r8cld ( ii, jj ) = r8bfms
END DO
END DO
DO jj = 1, 2
DO ii = 1, NCPKW
r8pkw ( ii, jj ) = r8bfms
END DO
END DO
DO jj = 1, MXWLYR
DO ii = 1, NCCWD
r8cwd ( ii, jj ) = r8bfms
END DO
END DO
IF ( ibrtyp .eq. 1 .or. ibrtyp .eq. 2 ) THEN
C
C* Ship, fixed buoy, or CMAN report.
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.
C
CALL UT_CIBF ( iunbfo, 'RPID', civals(icstid), 8, iercbf )
C
IF ( ibrtyp .eq. 1 .and. ifbuoy .eq. 1 ) THEN
C
C* Ship report.
C
IF ( subset .eq. 'NC001001' ) THEN
C
C* Store the restriction indicator.
C
rsrd = PKFTBV(9,1)
CALL UT_RIBF ( iunbfo, 'RSRD', rsrd, ierrbf )
END IF
C
C* Save the ship report ID (RPID) in upper case.
C
cval = civals ( icstid )
DO i = 1,8
lc = INDEX( lcase, cval(i:i) )
IF ( lc .gt. 0 ) THEN
cval(i:i) = ucase(lc:lc)
END IF
END DO
CALL UT_CIBF ( iunbfo, 'SHPC8', cval, 8, iercbf )
END IF
C
IF ( ibrtyp .eq. 2 ) THEN
C
C* CMAN report. Save station ID ( 0 01 010 )
C
CALL UT_CIBF ( iunbfo, 'SBPI',
+ civals(icstid), 8, iercbf )
END IF
C
C* Buoy platform ID (numeric)
C
IF ( ibrtyp .eq. 1 .and. ifbuoy .eq. 0 ) THEN
C
C* Fixed buoy report. Save ID.
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', 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* Precipitation indicator ( 0 13 194 )
C
CALL UT_RIBF ( iunbfo, 'INPC', rivals ( irinpc ), ierrbf )
C
C* Station indicator ( 0 02 193 )
C
IF ( .not. ERMISS ( rivals ( iritso ) ) ) THEN
CALL UT_RIBF ( iunbfo, 'ITSO',
+ ( rivals ( iritso ) - 1.0 ), ierrbf )
END IF
C
C* Type of station ( 0 02 001 )
C
CALL UT_RIBF ( iunbfo, 'TOST', rivals ( irtost ), ierrbf )
C
C* Horizontal visibility in meters
C
CALL UT_RIBF ( iunbfo, 'HOVI',
+ PR_HGKM ( rivals ( irvsbk ) ), ierrbf )
C
C* Vertical visibility in meters (0 20 002)
C
CALL UT_RIBF ( iunbfo, 'VTVI', rivals ( irvrtm ), ierrbf )
C
C* Indicator for source and units of wind speed
C
risw = UT_IWBF ( rivals ( irisws ) )
CALL UT_RIBF ( iunbfo, 'TIWM', risw, ierrbf )
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* Number of supplementary wind types
C
nwty = NINT ( rivals ( irnspw ) )
IF ( nwty .gt. 0 .and. nwty .le. 3 ) THEN
C
C* The outer loop corresponds to the NCEP Supplementary Wind
C* Type Code Table SPWT values. The 911ff group is given the
C* highest priority for determining the wind gust (0 11 041).
C
icont = .true.
C
DO k = 0,2
C
DO j = 1,nwty
C
mty = NINT ( rivals ( irspwt ( j ) ) )
C
IF ( mty .eq. k .and. icont ) THEN
C
C* Duration in minutes of wind gust period
C
C
C* Duration in minutes of wind gust period
C
IF ( rivals ( irspwp ( j ) ) .ge. 0.0 .and.
+ rivals ( irspwp ( j ) ) .le. 60.0 ) THEN
CALL UT_RIBF ( iunbfo, '.DTMMXGS',
+ rivals ( irspwp ( j ) ), ierrbf )
icont = .false.
END IF
C
C* Wind gust
C
CALL UT_RIBF ( iunbfo, 'MXGS',
+ rivals ( irspws ( j ) ), ierrbf )
icont = .false.
END IF
END DO
END DO
END IF
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* Method of sea surface temperature ( 0 02 038 )
C
C* The NCEP BUFR Code Table 0 02 038 definitions for MSST.
C
ix = NINT ( rivals ( irmsst ) )
C
IF ( ix .eq. 0 .or. ix .eq. 1 ) THEN
xx = 0.
ELSE IF ( ix .eq. 2 .or. ix .eq. 3 ) THEN
xx = 1.
ELSE IF ( ix .eq. 4 .or. ix .eq. 5 ) THEN
xx = 2.
ELSE
xx = RMISSD
END IF
C
CALL UT_RIBF ( iunbfo, 'MSST', xx, ierrbf )
C
C* Sea surface temperature in Kelvin ( 0 22 042 )
C
CALL UT_RIBF ( iunbfo, 'SST1',
+ PR_TMCK ( rivals ( irsstc ) ), ierrbf )
C
C* Method of wet bulb temperature ( 0 02 039 )
C
C* The NCEP BUFR Code Table 0 02 039 definitions for MWBT.
C
ix = NINT ( rivals ( irstwc ) )
C
IF ( ix .eq. 0 .or. ix .eq. 1 ) THEN
xx = 0.
ELSE IF ( ix .eq. 2 ) THEN
xx = 1.
ELSE IF ( ix .eq. 5 .or. ix .eq. 6 ) THEN
xx = 2.
ELSE IF ( ix .eq. 7 ) THEN
xx = 3.
ELSE
xx = RMISSD
END IF
C
CALL UT_RIBF ( iunbfo, 'MWBT', xx, ierrbf )
C
C* Wet bulb temperature in Kelvin ( 0 12 002 )
C
CALL UT_RIBF ( iunbfo, 'TMWB',
+ PR_TMCK ( rivals ( irtmwc ) ), ierrbf )
C
C* Relative humidity in per cent ( 0 13 003 )
C
CALL UT_RIBF ( iunbfo, 'REHU', rivals ( irrelh ), ierrbf )
C
C* Maximum and minimum temperature in Kelvin. The time period
c* will be set to missing, although most likely these are 24 hour
C* max/min temperatures. ( 0 12 011, 0 12 012 )
C
CALL UT_RIBF ( iunbfo, '.DTHMXTM',
+ rivals ( irdtv1 ), ierrbf )
CALL UT_RIBF ( iunbfo, 'MXTM',
+ PR_TMCK ( rivals ( irmxtm ) ), ierrbf )
CALL UT_RIBF ( iunbfo, '.DTHMITM',
+ rivals ( irdtv2 ), ierrbf )
CALL UT_RIBF ( iunbfo, 'MITM',
+ PR_TMCK ( rivals ( irmitm ) ), ierrbf )
C
C* PRES, PMSL, 3HPC, and 24PC are in units of millibars
C* within the interface format, but they need to be in units of
C* Pascals within the BUFR format.
C
C* Pressure in Pascals ( 0 10 004)
C
CALL UT_RIBF ( iunbfo, 'PRES',
+ PR_M100 ( rivals ( irpres ) ), 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
CALL UT_RIBF ( iunbfo, 'CHPT', rivals ( irchpt ), ierrbf )
C
C* 3-hour pressure change ( 0 10 061 )
C
CALL UT_RIBF ( iunbfo, '3HPC',
+ PR_M100 ( rivals ( ir3hpc ) ), ierrbf )
C
C* 24-hour pressure change ( 0 10 062 )
C
CALL UT_RIBF ( iunbfo, '24PC',
+ PR_M100 ( rivals ( ir24pc ) ), ierrbf )
C
C* Number of precipitation values.
C
nvals = NINT ( rivals ( irnpcv ) )
IF ( nvals .gt. 0 ) THEN
DO i = 1, nvals
C
C* Determine period of precip
C
IF ( ERMISS ( rivals ( irpprd ( i ) ) ) ) THEN
ipd = 0
ELSE
ipd = NINT ( rivals ( irpprd ( i ) ) )
END IF
C
IF ( .not. ERMISS ( rivals ( irpamt ( i ) ) ) ) THEN
C
C* Total precip past 6 hours ( 0 13 021 ).
C
IF ( ipd .eq. 6 ) THEN
CALL UT_RIBF ( iunbfo, 'TP06',
+ rivals ( irpamt ( i ) ), ierrbf )
ELSE IF ( ipd .eq. 24 ) THEN
C
C* Total precip past 24 hours ( 0 13 023 ).
C
CALL UT_RIBF ( iunbfo, 'TP24',
+ rivals ( irpamt ( i ) ), ierrbf )
ELSE IF ( ipd .eq. 1 ) THEN
C
C* Total precip past 1 hour ( 0 13 019 ).
C
CALL UT_RIBF ( iunbfo, 'TP01',
+ rivals ( irpamt ( i ) ), ierrbf )
ELSE IF ( ipd .eq. 3 ) THEN
C
C* Total precip past 3 hours ( 0 13 020 ).
C
CALL UT_RIBF ( iunbfo, 'TP03',
+ rivals ( irpamt ( i ) ), ierrbf )
ELSE IF ( ipd .eq. 12 ) THEN
C
C* Total precip past 12 hours ( 0 13 022 ).
C
CALL UT_RIBF ( iunbfo, 'TP12',
+ rivals ( irpamt ( i ) ), ierrbf )
ELSE IF ( ipd .eq. 2 .or. ipd .eq. 9 .or.
+ ipd .eq. 15 .or. ipd .eq. 18. or.
+ ipd .eq. 0 ) THEN
C
C* Total precip past 2, 9, 15, 18, or 0 hours ( 0 13 011 ).
C* Don't store period if ipd = 0. BUFR will default to
C* r8bfms in this case, which is what we want.
C
CALL UT_RIBF ( iunbfo, 'TOPC',
+ rivals ( irpamt ( i ) ), ierrbf )
IF ( ipd .ne. 0 ) THEN
CALL UT_RIBF ( iunbfo, '.DTHTOPC',
+ rivals ( irpprd ( i ) ), ierrbf )
END IF
END IF
END IF
END DO
END IF
C
C* Present and past weather. Determine if station is manned (iritso
C* = 1), automated (iritso = 7), or automated using Code tables 4677
C* and 4561 ( iritso = 4 ) (which are the same tables used by manned
C* stations), so we know which interface mnemonics to use.
C
IF ( rivals ( iritso ) .eq. 1 .or.
+ rivals ( iritso ) .eq. 4 ) THEN
c
C* Present weather ( 0 20 003 )
C
CALL UT_RIBF ( iunbfo, 'PRWE', rivals ( irwwmo ), ierrbf )
C
C* Past weather 1 ( 0 20 004 )
C
CALL UT_RIBF ( iunbfo, 'PSW1', rivals ( irpwwm ), ierrbf )
C
C* Past weather 2 ( 0 20 005 )
C
CALL UT_RIBF ( iunbfo, 'PSW2', rivals ( irpsw2 ), ierrbf )
C
ELSE IF ( rivals ( iritso ) .eq. 7 ) THEN
C
C* Present weather ( 0 20 003 )
C
IF ( .not. ERMISS ( rivals ( irwwma ) ) ) THEN
CALL UT_RIBF ( iunbfo, 'PRWE',
+ ( rivals ( irwwma ) + 100. ), ierrbf )
END IF
C
C* Past weather 1 ( 0 20 004 )
C
IF ( .not. ERMISS ( rivals ( irpwwa ) ) ) THEN
CALL UT_RIBF ( iunbfo, 'PSW1',
+ ( rivals ( irpwwa ) + 10. ), ierrbf )
END IF
C
C* Past weather 2 ( 0 20 005 )
C
IF ( .not. ERMISS ( rivals ( irpwa2 ) ) ) THEN
CALL UT_RIBF ( iunbfo, 'PSW2',
+ ( rivals ( irpwa2 ) + 10. ), ierrbf )
END IF
END IF
C
C* Period and height of waves (instruments) (0 22 011, 0 22 021)
C
CALL UT_RIBF ( iunbfo, 'POWV', rivals ( irwper ), ierrbf )
CALL UT_RIBF ( iunbfo, 'HOWV', rivals ( irwhgt ), ierrbf )
C
C* Period and height of wind waves (0 22 012, 0 22 022)
C
CALL UT_RIBF ( iunbfo, 'POWW', rivals ( irpoww ), ierrbf )
CALL UT_RIBF ( iunbfo, 'HOWW', rivals ( irhoww ), ierrbf )
C
C* Swell data ( 0 22 003, 0 22 013, 0 22 23 )
C
C* Number of systems of swell observed
C
nrep = NINT ( rivals ( irnswv ) )
IF ( nrep .gt. 0 .and. nrep .le. 2 ) THEN
DO j = 1, nrep
r8swv ( LSDOSW, j ) =
+ UT_RIBM ( rivals ( irdosw ( j ) ) )
r8swv ( LSPOSW, j ) =
+ UT_RIBM ( rivals ( irposw ( j ) ) )
r8swv ( LSHOSW, j ) =
+ UT_RIBM ( rivals ( irhosw ( j ) ) )
END DO
CALL UFBINT ( iunbfo, r8swv, NCSWV, nrep, ierufb,
+ CSWVST )
END IF
END IF
C
IF ( ibrtyp .eq. 1 .and. ifbuoy .eq. 1 ) THEN
C
C* Ship report.
C* General cloud information (BBXX section 1 data)
C
C* % of total cloud cover ( 0 20 010 )
C* Convert to % (100. * (cfrt/8.))
C
C* Note that a cfrt value of 9 will generate a corresponding
C* TOCC value of 113%, but this is the correct practice
C* according to Note (5) of BUFR Table B, Class 20.
C
IF ( .not. ERMISS ( rivals ( ircfrt ) ) ) THEN
CALL UT_RIBF ( iunbfo, 'TOCC',
+ ( rivals ( ircfrt ) * 12.5 ), ierrbf )
END IF
C
C* Height of lowest cloud seen (0 20 201)
C
CALL UT_RIBF ( iunbfo, 'HBLCS', rivals ( irhblc ), ierrbf )
C
C* Multi-layer cloud data
C
C* Sections 1 and 3 cloud layer data
C
nrep = NINT ( rivals ( irnclo ) )
C
IF ( nrep .gt. 0 .and. nrep .le. 7 ) THEN
DO i = 1, nrep
r8cld ( LCVSSO, i ) =
+ UT_RIBM ( rivals ( irvsso ( i ) ) )
r8cld ( LCCLAM, i ) =
+ UT_RIBM ( rivals ( irclam ( i ) ) )
r8cld ( LCCLTP, i ) =
+ UT_RIBM ( rivals ( ircltp ( i ) ) )
r8cld ( LCHOCB, i ) =
+ UT_RIBM ( rivals ( irhocb ( i ) ) )
END DO
CALL UFBINT ( iunbfo, r8cld, NCCLD, nrep, ierufb,
+ CCLDST )
END IF
C
C* Direction of ship's movement ( 0 01 015)
C
CALL UT_RIBF ( iunbfo, 'TDMP', rivals ( irtdmp ), ierrbf )
C
C* Ship's average speed during the 3 hours preceding time of obs
C* (0 01 016)
C
CALL UT_RIBF ( iunbfo, 'ASMP', rivals ( irasmp ), ierrbf )
C
C* Cause of ice accretion on ships ( 0 20 033 )
C
IF ( .not. ERMISS ( rivals( ircoia ) ) ) THEN
C
C* Convert Code table 1751 value to BUFR table 0 02 033 value
C
ice = NINT ( rivals ( ircoia ) )
rice = bufrice ( ice )
CALL UT_RIBF ( iunbfo, 'COIA', rice, ierrbf )
END IF
C
C* Thickness of ice accretion on ships ( 0 20 031 )
C
CALL UT_RIBF ( iunbfo, 'IDTH', rivals ( iridth ), ierrbf )
C
C* Rate of ice accretion on ships ( 0 20 032 )
C
CALL UT_RIBF ( iunbfo, 'ROIA', rivals ( irroia ), ierrbf )
END IF
C
IF ( ibrtyp .eq. 2 ) THEN
C
C* CMAN - save tide elevation with respect to mean lower low water.
C* Convert from feet to meters for BUFR.
C
CALL UT_RIBF ( iunbfo, 'TLLW', PR_HGFM ( rivals ( irtllw ) ),
+ ierrbf )
END IF
IF ( (ibrtyp .eq. 1 .and. ifbuoy .eq. 0) .or.
+ ibrtyp .eq. 2 ) THEN
C
C* Fixed buoy or CMAN report.
C* 10 meter extrapolated wind speed ( 0 11 223 )
C
CALL UT_RIBF ( iunbfo, 'XS10', rivals ( irxs10 ), ierrbf )
C
C* 20 meter extrapolated wind speed ( 0 11 224 )
C
CALL UT_RIBF ( iunbfo, 'XS20', rivals ( irxs20 ), ierrbf )
C
C* Check direction of peak wind ( 0 11 043 ). 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 ) )
r8pkw ( LPYEAR, 2 ) =
+ UT_RIBM ( rivals ( irpwyr ) )
r8pkw ( LPMNTH, 2 ) =
+ UT_RIBM ( rivals ( irpwmo ) )
r8pkw ( LPDAYS, 2 ) =
+ UT_RIBM ( rivals ( irpwdy ) )
r8pkw ( LPHOUR, 2 ) =
+ UT_RIBM ( rivals ( irpwhr ) )
r8pkw ( LPMINU, 2 ) =
+ UT_RIBM ( rivals ( irpwmn ) )
r8pkw ( LPPKWD, 2 ) =
+ UT_RIBM ( rivals ( irpwdr ) )
r8pkw ( LPPKWS, 2 ) =
+ UT_RIBM ( rivals ( irpwsp ) )
CALL UFBREP ( iunbfo, r8pkw, NCPKW, 2, ierufb,
+ CPKWST )
END IF
C
C* Number of continuous wind time periods
C* Add time displacement in minutes, continuous wind direction,
C* and continuous wind speed (in m/s) to BUFR output.
C
nrep = NINT ( rivals ( irncwd ) )
C
IF ( nrep .gt. 0 .and. nrep .le. 6 ) THEN
DO i = 1, nrep
r8cwd ( LWTPMI, i ) =
+ UT_RIBM ( rivals ( irtpmi ( i ) ) )
r8cwd ( LWWDRC, i ) =
+ UT_RIBM ( rivals ( irwdrc ( i ) ) )
r8cwd ( LWWDSC, i ) =
+ UT_RIBM ( rivals ( irwdsc ( i ) ) )
END DO
CALL UFBINT ( iunbfo, r8cwd, NCCWD, nrep, ierufb,
+ CCWDST )
END IF
END IF
C
C* Retrieve raw report
C
IF ( mszrpt .gt. MXBFRR ) THEN
WRITE ( UNIT = logmsg, FMT = '( A, I4, A )' )
+ 'Only stored first ', MXBFRR, ' bytes of raw report'
CALL DC_WLOG ( 4, 'MA', 1, logmsg, ierwlg )
END IF
CALL UT_CIBF ( iunbfo, 'RRSTG', marrpt, mszrpt, iercbf )
C
C* Write BUFR message to BUFR output file
C
CALL UT_WBFR ( iunbfo, 'msfc', 0, ierwbf )
C
loglvl = 4
logmsg = '<--------------END BUFR OUTPUT-------------->'
CALL DC_WLOG ( loglvl, 'MA', 1, logmsg, ierwsg )
C*
RETURN
END