SUBROUTINE DB_BUFR( bufrtb, last, dburpt, mszrpt, iret ) C*********************************************************************** C* DB_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* DB_BUFR ( BUFRTB, LAST, DBURPT, 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* MSZRPT INTEGER Byte size of report * C* DBURPT CHAR* Report array * 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 12/99 * 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 02/2002 Change name to dbbufr.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 dbbufa.f plus all of * C* the subroutines it previously called. * C* C. Caruso Magee/NCEP 03/2002 Modify part of code that checks anemo * C* hgt and decides which mnemonic it will * C* be stored under. Remove WLOG prints of* C* "begin BUFR output" and "end BUFR out- * C* put" since no mnemonics/values can be * C* printed here w/out extensive WLOG calls* C* C. Caruso Magee/NCEP 12/2002 Add code to save to BUFR the subsfc * C* depth, direction, and current speed, * C* along with method of removing velocity * C* & motion of platform from current mea- * C* surement (MRMV) and duration and time * C* of current measurement (DTCC). * C* C. Caruso Magee/NCEP 12/2002 Add code to save QCLS to BUFR. * C* C. Caruso Magee/NCEP 09/2003 Correct typo - AHAC was incorrectly * C* entered as ANAC. * C* C. Caruso Magee/NCEP 06/2004 Add code to save LDDS, LDRS, and BVOL * C* to BUFR. Removed incorrect comments * C* re: BUFR descriptors of quality parms * C* not currently saved to BUFR output. * C* C. Caruso Magee/NCEP 01/2006 Add code to save CORN. CORN is part of* C* output bufr format but wasn't being * C* saved anywhere by this decoder. Also, * C* modified how year is stored into bufr. * C* Now uses irptdt(1) instead of old * C* rivals(iryear). * C*********************************************************************** INCLUDE 'GEMPRM.PRM' INCLUDE 'BUFR.CMN' INCLUDE 'dbcmn_bufr.cmn' INCLUDE 'dbcmn.cmn' C* CHARACTER*(*) bufrtb, dburpt LOGICAL first, last, keep C* REAL*8 r8dts ( NCDTS, MXDLYR*2 ), UT_RIBM, UT_IWBF, GETBMISS REAL htan, risw, qcts, qccu, bvolt, xx CHARACTER subset*8, buoyid*5 C* DATA first / .true. / C SAVE C* INCLUDE 'ERMISS.FNC' 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 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 ( iunbtb, kret ) CALL FL_GLUN ( iunbfo, kret ) C C* Open the BUFR table file C OPEN ( UNIT = iunbtb, FILE = bufrtb ) C C* Connect the BUFR output files to the BUFR table C CALL OPENBF ( iunbfo, 'NUL', iunbtb ) r8bfms = GETBMISS() C END IF C IF ( LAST ) then C C* Close BUFR output files C CALL CLOSBF ( iunbtb ) CALL CLOSBF ( iunbfo ) RETURN END IF C ibfdt = ( irptdt (1) * 1000000 ) + + ( irptdt (2) * 10000 ) + ( irptdt (3) * 100 ) + + irptdt (4) C C* Drifting buoy report. C subset = 'NC001002' istyp = 2 C C* Open BUFR file for output C CALL OPENMB ( iunbfo, subset, ibfdt ) C C* Initialize BUFR output arrays. C DO jj = 1, MXDLYR DO ii = 1, NCDTS r8dts ( 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* Buoy platform ID (numeric). 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 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 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* Type of station C CALL UT_RIBF ( iunbfo, 'TOST', rivals ( irtost ), ierrbf ) C C* Wind direction in degrees C CALL UT_RIBF ( iunbfo, 'WDIR', rivals ( irdrct ), ierrbf ) C C* Wind speed in m/sec C CALL UT_RIBF ( iunbfo, 'WSPD', rivals ( irsped ), 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* 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* Sea surface temperature in Kelvin ( 0 22 042 ) C CALL UT_RIBF ( iunbfo, 'SST1', + PR_TMCK ( rivals ( irsstc ) ), ierrbf ) C C* Relative humidity in per cent ( 0 13 003 ) C CALL UT_RIBF ( iunbfo, 'REHU', rivals ( irrelh ), ierrbf ) C C* PRES, PMSL, and 3HPC are in units of millibars within C* 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* Period of waves (instruments) (0 22 011) C CALL UT_RIBF ( iunbfo, 'POWV', rivals ( irwper ), ierrbf ) C C* Height of waves (instruments) (0 22 021) C CALL UT_RIBF ( iunbfo, 'HOWV', rivals ( irwhgt ), ierrbf ) C C* Quality control indicator for temp/salinity profile. Convert C* from WMO Code Table 3334 to local BUFR Code Table 0 33 239 values. C* C* NOTE: local BUFR Code Tables 0 33 239 and 0 33 240 both have the C* same values as WMO BUFR Code Table 0 33 020. We're using local C* tables because we couldn't figure out how to get 0 33 020 to work C* for entire profiles (as opposed to a single value) in our version C* of BUFR. C IF ( .not. ERMISS ( rivals ( irq3d1 ) ) ) THEN IF ( rivals ( irq3d1 ) .eq. 0. ) qcts = 4.0 IF ( rivals ( irq3d1 ) .eq. 5. ) qcts = 5.0 IF ( ( rivals ( irq3d1 ) .ge. 1. ) .and. + ( rivals ( irq3d1 ) .le. 4. ) ) THEN qcts = rivals ( irq3d1 ) - 1.0 END IF CALL UT_RIBF ( iunbfo, 'QCTSP', qcts, ierrbf ) END IF C C* Quality control indicator for current profile. Convert from C* WMO Code Table 3334 to local BUFR Code Table 0 33 240 values. C IF ( .not. ERMISS ( rivals ( irq3d1 ) ) ) THEN IF ( rivals ( irq3d2 ) .eq. 0. ) qccu = 4.0 IF ( rivals ( irq3d2 ) .eq. 5. ) qccu = 5.0 IF ( ( rivals ( irq3d2 ) .ge. 1. ) .and. + ( rivals ( irq3d2 ) .le. 4. ) ) THEN qccu = rivals ( irq3d2 ) - 1.0 END IF CALL UT_RIBF ( iunbfo, 'QCCUR', qccu, ierrbf ) END IF 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) ( 0 02 031 ). C CALL UT_RIBF ( iunbfo, 'DTCC', rivals ( irdtcc ), ierrbf ) C C* Method of salinity/depth measurement (0 02 033) C CALL UT_RIBF ( iunbfo, 'MSDM', rivals ( irmsdm ), ierrbf ) C C* Depth/temperature/salinity data. C* Add number of depth/temp/salinity to number of depth/dir/spd of C* current. C ndts = NINT ( rivals ( irndts ) ) nddc = NINT ( rivals ( irnddc ) ) ndep = ndts + nddc IF ( ndts .gt. 0 .and. ndts .le. 200 ) 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 IF ( nddc .gt. 0 .and. nddc .le. 200 ) 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 IF ( ndep .gt. 0 ) THEN CALL UFBINT ( iunbfo, r8dts, NCDTS, ndep, ierufb, + CDTSST ) END IF C C* Add the section 4 quality control data and engineering C* and technical parameters to the BUFR subset. C C* Quality of the buoy satellite transmission (0 33 022) C CALL UT_RIBF ( iunbfo, 'QBST', rivals ( irqbst ), ierrbf ) C C* Quality of buoy location (0 33 023) C CALL UT_RIBF ( iunbfo, 'QCIL', rivals ( irqcil ), ierrbf ) C C* Location quality class (0 33 027) C CALL UT_RIBF ( iunbfo, 'QCLS', rivals ( irqcls ), ierrbf ) C C* Indicator for whether depths are corrected using hydrostatic C* pressure (0 25 086). C CALL UT_RIBF ( iunbfo, 'QDEP', rivals ( irqdep ), ierrbf ) C keep = .false. C C* QOPM, QCBH, QWTM and QATM quality control data values are C* skipped, since they are not useful data (at this time). C* Entries for these values are not currently in the BUFR table. C IF ( keep ) THEN C C* Quality of the pressure measurement. C CALL UT_RIBF ( iunbfo, 'QOPM', rivals ( irqopm ), ierrbf ) C C* Quality of the ARGOS housekeeping parameter. C CALL UT_RIBF ( iunbfo, 'QCBH', rivals ( irqcbh ), ierrbf ) C C* Quality of the measurement of the water-surface C* temperature. C CALL UT_RIBF ( iunbfo, 'QWTM', rivals ( irqwtm ), ierrbf ) C C* Quality of the measurement of the air temp. C CALL UT_RIBF ( iunbfo, 'QATM', rivals ( irqatm ), ierrbf ) END IF C C* Add remaining section 4 data to BUFR output. C C* Exact time of last known position of buoy (0 04 196 - 0 04 199). C CALL UT_RIBF ( iunbfo, 'PSYR', rivals ( irpsyr ), ierrbf ) CALL UT_RIBF ( iunbfo, 'PSMN', rivals ( irpsmn ), ierrbf ) CALL UT_RIBF ( iunbfo, 'PSDY', rivals ( irpsdy ), ierrbf ) CALL UT_RIBF ( iunbfo, 'PSHR', rivals ( irpshr ), ierrbf ) CALL UT_RIBF ( iunbfo, 'PSMI', rivals ( irpsmi ), ierrbf ) C C* Drift speed of buoy in meters/sec (0 01 014). C CALL UT_RIBF ( iunbfo, 'PLDS', + PR_D100 ( rivals ( irdbvv ) ), ierrbf ) C C* Drift direction of buoy (0 01 012). C CALL UT_RIBF ( iunbfo, 'DOMO', rivals ( irdbdd ), ierrbf ) C C* Latitude/longitude of second possible solution C* (symmetrical to the satellite subtrack) (0 27 001, C* 0 28 001). C CALL UT_RIBF ( iunbfo, 'DLATH', rivals ( irdlat ), ierrbf ) CALL UT_RIBF ( iunbfo, 'DLONH', rivals ( irdlon ), ierrbf ) C C* Drogue type (0 02 034). C CALL UT_RIBF ( iunbfo, 'DROT', rivals ( irdrot ), ierrbf ) C C* Depth at which the drogue is C* attached, in meters (0 07 070). C CALL UT_RIBF ( iunbfo, 'DROD', rivals ( irdrod ), ierrbf ) C C* Hydrostatic pressure of lower end of cable C* in centibars (0 02 168). Convert to Pascals (1 centibar = C* 1000 Pa). C CALL UT_RIBF ( iunbfo, 'HPLE', + PR_HGKM ( rivals ( irhple ) ), ierrbf ) C C* Length of cable (thermistor strings), in meters C* (0 02 035). C CALL UT_RIBF ( iunbfo, 'CALT', rivals ( ircalt ), ierrbf ) C C* Type of data buoy (0 02 149). C CALL UT_RIBF ( iunbfo, 'BUYT', rivals ( irbuyt ), ierrbf ) C C* Anemometer height in meters (either 0 07 032 or 0 07 064, depending C* on whether height was artificially corrected to 10 meters or not). C* If iranht .ne. 999, then convert from decimeters to meters and save C* (this is height of anemometer above local ground)(10 decimeters = 1 m). C* If iranht .eq. 999, then height was artificially corrected to 10 C* meters, so just save as 10 meters. C IF ( .not. ERMISS ( rivals ( iranht ) ) ) THEN IF ( NINT ( rivals ( iranht ) ) .eq. 999 ) THEN CALL UT_RIBF ( iunbfo, 'AHAC', 10., ierrbf ) ELSE htan = rivals ( iranht ) / 10. CALL UT_RIBF ( iunbfo, 'ANHT', htan, ierrbf ) END IF END IF C C* Anemometer type (0 02 169). C CALL UT_RIBF ( iunbfo, 'ANTP', rivals ( irantp ), ierrbf ) C C* Lagrangian drifter drogue status (0 22 060) C CALL UT_RIBF ( iunbfo, 'LDDS', rivals ( irldds ), ierrbf ) C C* Lagrangian drifter submergence (0 02 190). C CALL UT_RIBF ( iunbfo, 'LDRS', rivals ( irldrs ), ierrbf ) C C* Battery voltage (0 25 025). Convert from tenths of volts to volts. C bvolt = rivals ( irbvol ) / 10. CALL UT_RIBF ( iunbfo, 'BVOL', bvolt, ierrbf ) 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, 'DB', 1, logmsg, ierwlg ) END IF CALL UT_CIBF ( iunbfo, 'RRSTG', dburpt, mszrpt, iercbf ) C C* Write BUFR message to BUFR output file C CALL UT_WBFR ( iunbfo, 'drbu', 0, ierwbf ) C* RETURN END