SUBROUTINE CG_BUFR( bufrtb, last, cgrpt, mszrpt, iret ) C************************************************************************ C* CG_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* CG_BUFR ( BUFRTB, LAST, CGRPT, 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* CGRPT CHAR* Report array * C* MSZRPT INTEGER Byte size of report * C* * C* Output variables: * C* * C* IRET INTEGER Return code * C* 0 = normal return * C* 1 = problems * C* * C** * C* Log: * C* C. Caruso Magee/NCEP 05/00 New for coast guard data. * C* C. Caruso Magee/NCEP 01/01 Corrected logmsg at end of s/r. * 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 cgbufr.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 cgbufa.f plus all of * C* the subroutines it previously called. * C************************************************************************ INCLUDE 'BRIDGE.PRM' INCLUDE 'cgcmn.cmn' INCLUDE 'cgcmn_bufr.cmn' C* CHARACTER*(*) bufrtb, cgrpt CHARACTER*(DCMXBF) cgrptout REAL*8 UT_IWBF LOGICAL last, first C* CHARACTER subset*8 C* DATA first / .true. / SAVE 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 ) 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, 'CG', 1, logmsg, ierwsg ) C ibfdt = ( irptdt (1) * 1000000 ) + + ( irptdt (2) * 10000 ) + ( irptdt (3) * 100 ) + + irptdt (4) C C* Coast Guard report C subset = 'NC001007' C C* Open BUFR file for output C CALL OPENMB ( iunbfo, subset, ibfdt ) 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* 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* Type of station C CALL UT_RIBF ( iunbfo, 'TOST', rivals ( irtost ), ierrbf ) C C* Horizontal visibility in meters (0 20 001) C* Am assuming statute miles for now (based on CG/MARS documentation). C* Convert visibility in statute miles to meters. C* Do PRHGSF (statute miles to feet), then PRHGFM (feet to meters) C CALL UT_RIBF ( iunbfo, 'HOVI', + PR_HGFM ( PR_HGSF ( rivals ( irvsby ) ) ), ierrbf ) C C* % of total cloud cover ( 0 20 010 ) C* Convert to % (100. * (cfrt/8.)) C IF ( .not. ERMISS ( rivals ( ircfrt ) ) ) THEN CALL UT_RIBF ( iunbfo, 'TOCC', + ( rivals ( ircfrt ) * 12.5 ), ierrbf ) END IF C C* cloud amount in oktas C CALL UT_RIBF ( iunbfo, 'CLAM', rivals ( irclam ), ierrbf ) C C* height of cloud base in meters C CALL UT_RIBF ( iunbfo, 'HOCB', rivals ( irhocb ), 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* (rivals ( irdrct ) was set to -99.0) then set direction to C* 0. C IF ( rivals ( irdrct ) .eq. -99.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 kts. Convert to m/s. C CALL UT_RIBF ( iunbfo, 'WSPD', + PR_KNMS ( rivals ( irsknt ) ) , ierrbf ) C C* Wind gust in kts. Convert to m/s. C CALL UT_RIBF ( iunbfo, 'MXGS', + PR_KNMS ( rivals ( irgust ) ) , ierrbf ) C C* Dry bulb temperature in deg F. Convert to Kelvin ( 0 12 001 ) C CALL UT_RIBF ( iunbfo, 'TMDB', + PR_TMFK ( rivals ( irtmpf ) ) , ierrbf ) C C* Sea surface temperature in deg F. Convert to Kelvin ( 0 12 042 ) C CALL UT_RIBF ( iunbfo, 'SST1', + PR_TMFK ( rivals ( irsstf ) ) , ierrbf ) C C* Maximum and minimum temperature in Kelvin ( 0 12 011, 0 12 012 ) C CALL UT_RIBF ( iunbfo, 'MXTM', + PR_TMFK ( rivals ( irmxtm ) ) , ierrbf ) CALL UT_RIBF ( iunbfo, 'MITM', + PR_TMFK ( rivals ( irmitm ) ) , ierrbf ) C C* Altimeter setting ( 0 10 052 ). First convert to millibars, C* then convert to Pascals. C CALL UT_RIBF ( iunbfo, 'ALSE', + PR_M100 ( PR_ALTM ( rivals ( iralti ) ) ), ierrbf ) C C* If selv is not missing, convert alti to station pressure C* (in Pascals ( 0 10 004 )) using gemlib conversion subroutine. C* If selv is less than 7.5 meters, also copy converted alti into C* sea-level pressure. C IF ( .not. ERMISS ( rivals ( irselv ) ) ) THEN CALL UT_RIBF ( iunbfo, 'PRES', + PR_M100 ( PR_PALT ( PR_ALTM ( rivals ( iralti ) ), + rivals ( irselv ) ) ), ierrbf ) IF ( rivals ( irselv ) .lt. 7.5 ) THEN CALL UT_RIBF ( iunbfo, 'PMSL', + PR_M100 ( PR_PALT ( PR_ALTM ( rivals ( iralti ) ), + rivals ( irselv ) ) ), ierrbf ) END IF END IF C C* Station 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* Check to see if pmsl has already been set. C* If it's missing, check to see if station pressure is present. C* If it's present, and if the station elevation is less C* than 7.5 meters, then copy station pressure into sea-level C* pressure and save it into BUFR. C IF ( .not. ERMISS ( rivals ( irpmsl ) ) ) THEN CALL UT_RIBF ( iunbfo, 'PMSL', + PR_M100 ( rivals ( irpmsl ) ), ierrbf ) ELSE IF ( .not. ERMISS ( rivals ( irpres ) ) ) THEN IF ( rivals ( irselv ) .lt. 7.5 ) THEN CALL UT_RIBF ( iunbfo, 'PMSL', + PR_M100 ( rivals ( irpres ) ), ierrbf ) END IF END IF END IF C C* Manned station. Store present weather ( 0 20 003 ). C CALL UT_RIBF ( iunbfo, 'PRWE', ( rivals ( irwwmo ) ), ierrbf ) C C* Period and height of waves (0 22 011, 0 22 021) C CALL UT_RIBF ( iunbfo, 'POWV', rivals ( irwper ), ierrbf ) CALL UT_RIBF ( iunbfo, 'HOWV', + PR_HGFM ( rivals ( irwhgt ) ), ierrbf ) C C* Maximum wave height (0 22 073). Convert from feet to meters. C CALL UT_RIBF ( iunbfo, 'MXWH', + PR_HGFM ( rivals ( irmxwh ) ), ierrbf ) C C* Tidal elevation wrt local chart (0 22 038). Convert from C* inches to meters. C CALL UT_RIBF ( iunbfo, 'TERC', + PR_HGMK ( PR_INMM ( rivals ( irterc ) ) ), ierrbf ) C C* Direction of swell waves from true. (0 22 003) C CALL UT_RIBF ( iunbfo, 'DOSW', rivals ( irdosw ), ierrbf ) C C* Retrieve raw report C* Remove unprintable characters from cgrpt before saving to BUFR. C IF ( mszrpt .gt. 400 ) THEN len = 400 WRITE ( UNIT = logmsg, FMT = '( A )' ) + 'Only stored first 400 bytes of raw report' CALL DC_WLOG ( 4, 'CG', 1, logmsg, ierwlg ) ELSE len = mszrpt END IF CALL ST_UNPR ( cgrpt, len, cgrptout, lenout, iret) CALL UT_CIBF ( iunbfo, 'RRSTG', cgrptout, lenout, iercbf ) C C* Write BUFR message to BUFR output file C CALL UT_WBFR ( iunbfo, 'cgrd', 0, ierwbf ) C loglvl = 4 logmsg = '<--------------END BUFR OUTPUT-------------->' CALL DC_WLOG ( loglvl, 'CG', 1, logmsg, ierwsg ) C* RETURN END