SUBROUTINE UG_DCOD ( cldt, usgsfl, usgtbl,
+ bufrtb, nhours, iret )
C************************************************************************
C* UG_DCOD *
C* *
C* This routine decodes the USGS river and stream runoff data into *
C* BUFR format. *
C* *
C* UG_DCOD ( CLDT, USGSFL, USGTBL, BUFRTB, NHOURS, IRET ) *
C* *
C* Input parameters: *
C* CLDT CHAR* Date-time from command line *
C* USGSFL CHAR* USGS data file *
C* USGTBL CHAR* Station table *
C* BUFRTB CHAR* BUFR tables file *
C* NHOURS INTEGER Max # of hours before run time *
C* for creating BUFR output *
C* *
C* Output parameters: *
C* IRET INTEGER Return code: *
C* 0 = normal return *
C* *
C** *
C* Log: *
C* C. Caruso Magee/NCEP5 Based on dcalps *
C* J. Ator/NCEP 07/08 Increased capacity to handle additional *
C* data fields (up to 28) *
C* J. Ator/NCEP 03/09 Use DC_BSRC for station lookup, and *
C convert report time from local to UTC *
C* J. Ator/NCEP 05/09 Use MXFLDS and MXRECL parameters, use *
C* new UK_BKST subroutine, and add decode *
C* of specific conductance (00095) *
C* J. Ator/NCEP 06/11 Allow station IDs up to 16 characters *
C* J. Ator/NCEP 08/13 Use ST_INTG to decode date field *
C* J. Ator/NCEP 08/13 Use timezone from report *
C* J. Ator/NCEP 10/16 Look for underscore in each field of *
C* header record, rather than assuming it's*
C* always in the 3rd character *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'ugcmn.cmn'
C*
CHARACTER*(*) cldt, usgsfl, usgtbl, bufrtb
C*
CHARACTER rundt*12, sysdt*12,
+ report*(MXRECL), rptcpy*(MXRECL),
+ rimnem(NRIMN)*8, cimnem(NCIMN)*8,
+ flds(MXFLDSP3)*16,
+ parmlist(MXFLDS)*5, ddlist(MXFLDS)*7,
+ siteno*16, param(NDPRM)*5, tmpparm*16,
+ dummyparm*5, dummydd*2
C*
INTEGER irundt (5), irptdt (5)
C*
LOGICAL match, havdata, rptok
C*
DATA param / '00010','00020','00021','00035','00036',
+ '00045','00055','00060','00065','00480',
+ '61728','72020','00095' /
DATA dummyparm / 'XXXXX' /
DATA dummydd / 'DD' /
C*
INCLUDE 'ERMISS.FNC'
C*-----------------------------------------------------------------------
iret = 0
ieread = -9
loglev = 3
C
C* Open and read the USGS station table file.
C
CALL UG_STOR ( usgtbl, ierugt )
C
C* Set the pointers for the interface arrays.
C
CALL UG_IFSP ( rimnem, cimnem, ierfsp )
IF ( ierfsp .ne. 0 ) THEN
RETURN
END IF
C
C* Open the USGS data file.
C
CALL FL_SOPN ( usgsfl, iunndf, ierspn )
IF ( ierspn .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', ierspn, usgsfl, ierwlg )
RETURN
END IF
C
C* Open the BUFR tables file.
C
CALL FL_SOPN ( bufrtb, iunbft, ierspn )
IF ( ierspn .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', ierspn, bufrtb, ierwlg )
RETURN
END IF
C
C* Open the BUFR output file.
C
CALL FL_GLUN ( iunbfo, iergln )
IF ( iergln .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg )
RETURN
END IF
C
C* Connect the BUFR tables and output files to the BUFR interface.
C
CALL OPENBF ( iunbfo, 'NUL', iunbft )
C
C* Specify the use of BUFR edition 4, since Table C operator 2-07
C* is being utilized within the BUFR tables file.
C
CALL PKVS01 ( 'BEN', 4 )
C
C* Close the BUFR tables file.
C
CALL FL_CLOS ( iunbft, iercls )
IF ( iercls .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg )
END IF
C
C* Get the system time.
C
itype = 1
CALL CSS_GTIM ( itype, sysdt, iergtm )
IF ( iergtm .ne. 0 ) THEN
CALL DC_WLOG ( 2, 'SS', iergtm, ' ', ierwlg )
RETURN
END IF
C
C* If a date-time was entered on the command line, then use it as
C* the run date-time. Otherwise, use the system time as the run
C* date-time.
C
IF ( cldt .eq. 'SYSTEM' ) THEN
rundt = sysdt
ELSE
CALL TI_STAN ( cldt, sysdt, rundt, ierstn )
IF ( ierstn .ne. 0 ) THEN
CALL DC_WLOG ( 2, 'TI', ierstn, ' ', ierwlg )
RETURN
END IF
END IF
C
C* Convert the run date-time to integer.
C
CALL TI_CTOI ( rundt, irundt, iercto )
IF ( iercto .ne. 0 ) THEN
CALL DC_WLOG ( 2, 'TI', iercto, ' ', ierwlg )
RETURN
END IF
C
irc = 0
C
DO WHILE ( .true. )
C
irc = irc + 1
havdata = .false.
C
C* Read the next record (i.e. line) from the USGS data file.
C
READ ( UNIT = iunndf, FMT = '(A)', ERR = 900, END = 910 )
+ report
C
IF ( ( report ( 1:4 ) .eq. 'agen' ) .or.
+ ( report ( 1:4 ) .eq. 'USGS' ) ) THEN
C
C* Break the record into an array of substrings (i.e. fields).
C
CALL ST_LSTR ( report, lenr, ilret )
IF ( lenr .gt. MXRECL ) THEN
WRITE ( UNIT = logmsg, FMT='(I4)' ) lenr
CALL DC_WLOG ( 2, 'UG', 10, logmsg(1:4), ierwlg )
lenr = MXRECL
END IF
CALL UG_BKST ( report, lenr, flds, numfld, iret )
IF ( iret .ne. 0 ) THEN
WRITE ( UNIT = logmsg, FMT='(A,I2)' )
+ 'more than ', MXFLDS
CALL DC_WLOG ( 2, 'UG', 2, logmsg(1:12), ierwlg )
END IF
C
C* The first 4 fields are fixed fields containing the "USGS"
C* label, the station number, the datetime and the timezone.
C
nff = 4
C
IF ( numfld .gt. nff ) THEN
C
C* Make a copy of the report with the tabs and any
C* extra spaces removed, then write this copy to the
C* decoder log.
C
rptcpy = ' '
IF ( flds (3)(13:13) .eq. ':' ) THEN
rptcpy = flds(1)(1:4) // ' ' //
+ flds(2)(1:16) // ' ' //
+ flds(3)(1:10) // ' ' //
+ flds(3)(11:15) // ' ' //
+ flds(4)(1:4) // ' '
lrcpy = 47
nspc = 3
ELSE
rptcpy = ' site_no datetime' //
+ ' tmzone '
lrcpy = 46
nspc = 1
END IF
DO ii = nff+1, numfld
IF ( INDEX ( flds (ii), '_cd' ) .eq. 0 ) THEN
CALL ST_LSTR ( flds (ii), lfld, ierstr )
IF ( lfld .ne. 0 ) THEN
DO jj = 1, nspc
rptcpy ( lrcpy+1 : lrcpy+1 ) = ' '
lrcpy = lrcpy + 1
END DO
rptcpy ( lrcpy+1 : lrcpy+lfld ) =
+ flds (ii)(1:lfld)
lrcpy = lrcpy + lfld
END IF
END IF
END DO
IF ( lrcpy .ge. 100 ) THEN
CALL DC_WLOG ( 2, ' ', 1, rptcpy, ierwlg )
ELSE
CALL DC_WLOG ( 2, 'DC', 2, rptcpy, ierwlg )
END IF
C
C* Check to see if this is a header record for a station.
C
IF ( flds ( 1 ) .eq. 'agency_cd') THEN
C
C* Yes, so search for fields which define the data
C* parameters for this station.
C
DO i = nff+1, numfld
match = .false.
iusc = INDEX ( flds ( i ), '_' )
IF ( ( iusc .gt. 1 ) .and. ( iusc+5 .lt. 16 ) ) THEN
DO j = 1, NDPRM
IF ( .not. match ) THEN
IF ( flds ( i )( iusc+1 : iusc+5 ) .eq.
+ param ( j )( 1:5 ) ) THEN
parmlist ( i - nff ) = param ( j )
ddlist ( i - nff ) =
+ flds ( i )( 1 : MIN( iusc-1, 7 ) )
match = .true.
END IF
END IF
END DO
END IF
IF ( .not. match ) THEN
parmlist ( i - nff ) = dummyparm
ddlist ( i - nff ) = dummydd
END IF
END DO
ELSE
C
C* This is a data record, so store it into the interface.
C
rptok = .true.
C
C* Initialize the interface arrays.
C
CALL UG_IFIV ( ierifi )
C
C* Look for the station in the station table.
C
siteno = flds ( 2 )
CALL DC_BSRC ( siteno, stnid, jstnm, ipos, ierbrc )
IF ( ipos .eq. 0 ) THEN
CALL DC_WLOG ( 0, 'UG', 3, siteno, ierwlg )
rptok = .false.
ELSE
civals ( icstid ) = stnid ( ipos )
rivals ( irselv ) = elev ( ipos )
rivals ( irslat ) = ylat ( ipos )
rivals ( irslon ) = ylong ( ipos )
civals ( icagcy ) = flds ( 1 )
END IF
C
IF ( rptok ) THEN
C
C* Get the report date-time. This time is reported
C* as a local time at the station, so it needs to be
C* converted to UTC.
C
CALL ST_INTG ( flds(3)(1:4), irptdt(1), iersi1)
CALL ST_INTG ( flds(3)(6:7), irptdt(2), iersi2)
CALL ST_INTG ( flds(3)(9:10), irptdt(3), iersi3)
CALL ST_INTG ( flds(3)(11:12), irptdt(4), iersi4)
CALL ST_INTG ( flds(3)(14:15), irptdt(5), iersi5)
IF ( ( iersi1 .ne. 0 ) .or. ( iersi2 .ne. 0 ) .or.
+ ( iersi3 .ne. 0 ) .or. ( iersi4 .ne. 0 ) .or.
+ ( iersi5 .ne. 0 ) ) THEN
rptok = .false.
END IF
END IF
C
IF ( rptok ) THEN
C
C* Using the reported timezone, determine the difference
C* (in hours) between UTC and the local time at that
C* location.
C
SELECT CASE( flds(4)(1:3) )
CASE( "HST" )
idiff = 10
CASE( "AKS" )
idiff = 9
CASE( "AKD", "PST" )
idiff = 8
CASE( "PDT" )
idiff = 7
CASE( "CST" )
idiff = 6
CASE( "CDT", "EST" )
idiff = 5
CASE( "EDT", "AST" )
idiff = 4
CASE( "ADT" )
idiff = 3
CASE DEFAULT
rptok = .false.
END SELECT
END IF
C
IF ( rptok ) THEN
C
C* Convert the local time to UTC.
C
CALL TI_ADDM ( irptdt, idiff*60, irptdt, ieradm )
IF ( ieradm .ne. 0 ) THEN
CALL UT_EMSG ( 2, 'TI_ADDM', ieradm )
rptok = .false.
ELSE
rivals ( iryear ) = FLOAT ( irptdt(1) )
rivals ( irmnth ) = FLOAT ( irptdt(2) )
rivals ( irdays ) = FLOAT ( irptdt(3) )
rivals ( irhour ) = FLOAT ( irptdt(4) )
rivals ( irminu ) = FLOAT ( irptdt(5) )
END IF
END IF
C
IF ( rptok ) THEN
iwnds = 0
iwndr = 0
irsh = 0
idch = 0
ipcp = 0
DO k = 1, numfld - nff
READ ( UNIT = flds( k+nff ), FMT = '(A)',
+ IOSTAT = ier ) tmpparm
C
C* Convert character parm to real number. If return
C* code is non-zero, conversion failed (parm either
C* contained letters or invalid non-numeric character).
C* Output parm for non-zero return code is RMISSD.
C
C* Convert character parameter to either real directly
C* or to integer then real.
C
CALL ST_CRNM ( tmpparm, foutparm, icrret )
IF ( icrret .eq. 0 ) THEN
IF ( parmlist ( k ) .eq. '00010' ) THEN
havdata = .true.
rivals ( irwtmp ) = foutparm
ELSEIF ( parmlist ( k ) .eq. '00020' ) THEN
havdata = .true.
rivals ( irtmpc ) = foutparm
ELSEIF ( parmlist ( k ) .eq. '00021' ) THEN
havdata = .true.
rivals ( irtmpf ) = foutparm
ELSEIF ( parmlist ( k ) .eq. '00095' ) THEN
havdata = .true.
rivals ( irwacn ) = foutparm
ELSEIF ( parmlist ( k ) .eq. '00035' ) THEN
iwnds = iwnds + 1
IF ( iwnds .lt. 3 ) THEN
havdata = .true.
rivals ( irwspd (iwnds) ) = foutparm
CALL ST_CRNM ( ddlist ( k ),
+ rivals ( irddws ( iwnds ) ), icrret2 )
ELSE
WRITE (UNIT=logmsg, FMT='(I2)') iwnds
CALL DC_WLOG ( 0, 'UG', 4,
+ logmsg(1:2), ierwlg )
END IF
ELSEIF ( parmlist ( k ) .eq. '00036' ) THEN
iwndr = iwndr + 1
IF ( iwndr .lt. 3 ) THEN
havdata = .true.
rivals ( irwdir (iwndr) ) = foutparm
CALL ST_CRNM ( ddlist ( k ),
+ rivals ( irddwd ( iwndr ) ), icrret3 )
ELSE
WRITE (UNIT =logmsg, FMT='(I2)') iwndr
CALL DC_WLOG ( 0, 'UG', 4,
+ logmsg(1:2), ierwlg )
END IF
ELSEIF ( parmlist ( k ) .eq. '00045' ) THEN
ipcp = ipcp + 1
IF ( ipcp .lt. 3 ) THEN
havdata = .true.
rivals ( irprec ( ipcp ) ) = foutparm
CALL ST_CRNM ( ddlist ( k ),
+ rivals ( irddpc ( ipcp ) ), icrret4 )
ELSE
WRITE (UNIT=logmsg, FMT='(I2)') ipcp
CALL DC_WLOG ( 0, 'UG', 7,
+ logmsg(1:2), ierwlg )
END IF
ELSEIF ( parmlist ( k ) .eq. '00055' ) THEN
havdata = .true.
rivals ( irstrv ) = foutparm
ELSEIF ( parmlist ( k ) .eq. '00060' ) THEN
idch = idch + 1
IF ( idch .lt. 3 ) THEN
havdata = .true.
rivals ( irdchg ( idch ) ) = foutparm
CALL ST_CRNM ( ddlist ( k ),
+ rivals ( irdddc ( idch ) ), icrret5 )
ELSE
WRITE (UNIT=logmsg, FMT='(I2)') idch
CALL DC_WLOG ( 0, 'UG', 8,
+ logmsg(1:2), ierwlg )
END IF
ELSEIF ( parmlist ( k ) .eq. '00065' ) THEN
irsh = irsh + 1
IF ( irsh .lt. 3 ) THEN
havdata = .true.
rivals ( irrshm (irsh) ) = foutparm
CALL ST_CRNM ( ddlist ( k ),
+ rivals ( irddrs ( irsh ) ), icrret6 )
ELSE
WRITE (UNIT=logmsg, FMT='(I2)') irsh
CALL DC_WLOG ( 0, 'UG', 9,
+ logmsg(1:2), ierwlg )
END IF
ELSEIF ( parmlist ( k ) .eq. '00480' ) THEN
havdata = .true.
rivals ( irsaln ) = foutparm
ELSEIF ( parmlist ( k ) .eq. '61728' ) THEN
havdata = .true.
rivals ( irgust ) = foutparm
ELSEIF ( parmlist ( k ) .eq. '72020' ) THEN
havdata = .true.
rivals ( irrsh9 ) = foutparm
END IF
END IF
END DO
rivals ( irnwnd ) = MAX0 ( iwnds, iwndr )
rivals ( irnrsh ) = irsh
rivals ( irndch ) = idch
rivals ( irnpcp ) = ipcp
END IF
C
IF ( havdata ) THEN
C
C* Write the interface output to the decoder log.
C
CALL UG_IFPT ( loglev, rimnem, cimnem, iret )
C
C* Do not create BUFR output for reports that are
C* more than NHOURS before or more than 3 hours
C* after the run time.
C
IF ( ( ERMISS ( rivals ( iryear ) ) ) .or.
+ ( ERMISS ( rivals ( irmnth ) ) ) .or.
+ ( ERMISS ( rivals ( irdays ) ) ) .or.
+ ( ERMISS ( rivals ( irhour ) ) ) .or.
+ ( ERMISS ( rivals ( irminu ) ) ) ) THEN
iertmk = -1
ELSE
CALL DC_TMCK ( 2, irundt, irptdt, nhours,
+ 180, iertmk )
END IF
C
IF ( iertmk .eq. 0 ) THEN
C
C* Convert interface-format data for this report
C* into BUFR output and then write the BUFR output
C* to the BUFR output stream.
C
CALL UG_BUFR ( iunbfo, irundt, rptcpy, lrcpy,
+ ierbfr )
END IF
C
END IF
END IF
END IF
END IF
C
END DO
C
900 ieread = -5
910 CALL DC_WLOG ( 0, 'DC', ieread, ' ', ierwlg )
C
C* Make sure that all BUFR output has been written before exiting.
C
CALL UT_WBFR ( iunbfo, 'usgs', 1, ierwbf )
C
CALL CLOSBF ( iunbfo )
CALL FL_CLAL ( iercal )
C*
RETURN
END