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