SUBROUTINE EL_DCOD ( cldt, bufrtn, nhours, iret )
C************************************************************************
C* EL_DCOD *
C* *
C* This routine decodes bulletins containing EUMETSAT, Japan, or India *
C* satellite wind reports into NCEP BUFR format. *
C* *
C* EL_DCOD ( CLDT, BUFRTN, NHOURS, IRET ) *
C* *
C* Input parameters: *
C* CLDT CHAR* Date-time from command line *
C* BUFRTN CHAR* NCEP 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* J. Ator/NCEP 11/00 *
C* J. Ator/NCEP 05/01 Added capability to decode bulletins *
C* using either BFRTF1 or BFRTF2 *
C* J. Ator/NCEP 06/01 Use 'NUL' in call to OPENBF *
C* J. Ator/NCEP 10/01 Print DC_WLOG message if unknown format *
C* J. Ator/NCEP 01/02 Fix false positive unknown format msgs *
C* J. Ator/NCEP 08/02 Create .dummy subdirectory for OPENBF *
C* C. Caruso Magee/NCEP 01/04 Replace old s/r READERS with READSB *
C* J. Ator/NCEP 08/04 SS_GTIM -> CSS_GTIM *
C* J. Ator/NCEP 10/04 Add capability for Japan & EUMS HRV/HWW *
C* J. Ator/NCEP 05/16 Add check for corrupt message *
C* J. Ator/NCEP 01/18 Add capability for India *
C* M.Weiss+J.Ator/NCEP 09/20 Add capability for EUMETSAT2 *
C* J. Ator/NCEP 09/23 Use new decod_ut library routines, *
C* clean up and simplify logic, use 'SEC3' *
C* for decoding, remove interface format *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BRIDGE.PRM'
INCLUDE 'elcmn.cmn'
CHARACTER*(*) cldt, bufrtn
C* Maximum number of descriptors within Section 3 of a satellite
C* wind BUFR message.
PARAMETER ( MXDSC = 150 )
CHARACTER bull*(DCMXBF), cbull*(DCMXBF), bfstyp*8,
+ bufrdn*(DCMXLN), bufrbn*(DCMXLN),
+ seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8,
+ cdesc(MXDSC)*6
INTEGER irundt (5), irptdt (5),
+ ibull ( DCMXBF / 4 ),
+ nive ( MXL ), nivs ( MXL )
LOGICAL bullok, msgok, got1014, got1077
PARAMETER ( MXVAL = 5000 )
REAL*8 GETBMISS, r8arr ( MXVAL ),
+ r8yr, r8mo, r8dy, r8hr, r8mi
EQUIVALENCE ( cbull (1:4), ibull (1) )
C*-----------------------------------------------------------------------
iret = 0
C* Get the BUFR tables directory from the tables file. This
C* directory will be passed to subroutine MTINFO as the location
C* in which to search for any needed master table files.
CALL FL_PATH ( bufrtn, bufrdn, bufrbn, ierpth )
C* Open the BUFR messages file.
CALL FL_GLUN ( iubfma, iergln )
IF ( iergln .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg )
RETURN
END IF
OPEN ( UNIT = iubfma, FILE = '.dummy/dcelrw',
+ FORM = 'UNFORMATTED' )
CALL OPENBF ( iubfma, 'SEC3', iubftn )
CALL MTINFO ( bufrdn, 98, 99 )
C* Open the BUFR tables file.
CALL FL_SOPN ( bufrtn, iubftn, ierspn )
IF ( ierspn .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', ierspn, bufrtn, ierwlg )
RETURN
END IF
C* Open the BUFR output file.
CALL FL_GLUN ( iubfmn, iergln )
IF ( iergln .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg )
RETURN
END IF
C* Connect the BUFR tables file to the BUFR output file.
CALL OPENBF ( iubfmn, 'NUL', iubftn )
r8bfms = GETBMISS()
C* Specify that output messages are to be compressed, edition 4,
C* and up to 100K bytes in size.
CALL CMPMSG ( 'Y' )
CALL PKVS01 ( 'BEN', 4 )
CALL MAXOUT ( 100000 )
C* Close the BUFR tables file.
CALL FL_CLOS ( iubftn, iercls )
IF ( iercls .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg )
END IF
DO WHILE ( .true. )
C* Get a new bulletin from the input pipe.
CALL DC_GBUL ( bull, lenb, ifdtyp, iergbl )
IF ( iergbl .ne. 0 ) THEN
C* A time-out occurred while waiting for a new bulletin
C* on the input pipe. Shut down the decoder and exit.
CALL DC_WLOG ( 0, 'DC', iergbl, ' ', ierwlg )
CALL CLOSBF ( iubfma )
CALL CLOSBF ( iubfmn )
CALL FL_CLAL ( iercal )
RETURN
END IF
C* Do not decode AFOS products.
IF ( ifdtyp .ne. 0 ) CYCLE
C* Decode the header information from this bulletin.
CALL DC_GHDR ( bull, lenb, seqnum, buhd, cborg,
+ bulldt, bbb, ibptr, ierghd )
IF ( ierghd .ne. 0 ) THEN
CALL DC_WLOG ( 2, 'DC', ierghd, ' ', ierwlg )
CYCLE
END IF
C* Start an entry for this bulletin in the decoder log.
logmsg = '########################################'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
logmsg = seqnum // buhd // cborg // bulldt // bbb
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
C* Get the run date-time.
CALL UT_GET_RUNDT ( cldt, irundt, iergrd )
IF ( iergrd .ne. 0 ) CYCLE
bullok = .true.
C* Decode the header information from this bulletin.
DO WHILE ( bullok )
C* Locate the next BUFR message within the bulletin, and
C* store it within an equivalenced integer array.
CALL UT_GET_BUFRMG ( bull, lenb, ibptr, istart, msglen,
+ mtyp, msbti, MXDSC, cdesc, ndesc, ierbmg )
IF ( ierbmg .ne. 0 ) THEN
C* Make sure that all BUFR output for this bulletin has
C* been written to the BUFR output stream before going back
C* to DC_GBUL and waiting for a new bulletin on the pipe.
CALL UT_WBFR ( iubfmn, 'elrw', 1, ierwbf )
bullok = .false.
CYCLE
END IF
cbull = bull ( istart : ibptr )
nrept = 0
msgok = .false.
got1014 = .false.
got1077 = .false.
C* Review the Section 3 descriptors from the message to ensure
C* it contains satellite wind BUFR data.
ii = 1
DO WHILE ( ( ii .le. ndesc ) .and. ( .not. msgok ) )
IF ( cdesc(ii) .eq. '310014' ) THEN
got1014 = .true.
IF ( ( ndesc .eq. 39 ) .or. ( ndesc .eq. 57 ) )
+ msgok = .true.
ELSE IF ( cdesc(ii) .eq. '310077' ) THEN
got1077 = .true.
msgok = .true.
ELSE
ii = ii + 1
END IF
END DO
IF ( .not. msgok ) THEN
logmsg = 'message does not follow WMO template:'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
DO ii = 1, ndesc
WRITE ( logmsg, FMT = '(I6, A, A)' ) ii, ': ', cdesc(ii)
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
END DO
CYCLE
END IF
C* Open the BUFR message for reading.
CALL READERME ( ibull, iubfma, bfstyp, ibfdt, ierrme )
IF ( ierrme .ne. 0 ) CYCLE
DO WHILE ( msgok )
C* Get the next report from this BUFR message.
IF ( IREADSB ( iubfma ) .ne. 0 ) THEN
C* There are no more reports in this message.
msgok = .false.
C* Print a count of the number of reports processed.
WRITE ( UNIT = logmsg, FMT = '( A, I4, A )' )
+ 'contained ', nrept, ' reports'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
CYCLE
END IF
nrept = nrept + 1
C* Get the main report data.
IF ( got1077 ) THEN
CALL UFBSEQ ( iubfma, r8arr, MXVAL, 1, ierusq,
+ 'SATDRWN2' )
igctr = IDNINT ( r8arr (1) )
iswcm = IDNINT ( r8arr (14) )
r8yr = r8arr (20)
r8mo = r8arr (21)
r8dy = r8arr (22)
r8hr = r8arr (23)
r8mi = r8arr (24)
ELSE IF ( got1014 ) THEN
CALL UFBSEQ ( iubfma, r8arr, MXVAL, 1, ierusq,
+ 'GEOSTWND' )
igctr = IDNINT ( r8arr (2) )
iswcm = IDNINT ( r8arr (15) )
r8yr = r8arr (6)
r8mo = r8arr (7)
r8dy = r8arr (8)
r8hr = r8arr (9)
r8mi = r8arr (10)
END IF
C* Don't create BUFR output for reports that are more than
C* NHOURS before or more than 3 hours after the run time.
CALL UT_CHECK_BUFRRPTDT ( 2, irundt, r8yr, r8mo, r8dy,
+ r8hr, r8mi, nhours, 180, irptdt, iercrt )
IF ( iercrt .ne. 0 ) CYCLE
C* Open a BUFR message for output.
bfstyp = 'NC0050??'
SELECT CASE ( igctr )
CASE ( 28 )
IF ( got1014 ) bfstyp(7:7) = '2'
CASE ( 34 )
bfstyp(7:7) = '4'
CASE ( 254 )
bfstyp(7:7) = '6'
END SELECT
SELECT CASE ( iswcm )
CASE ( 1 )
IF ( got1077 ) THEN
bfstyp(8:8) = '7'
ELSE
bfstyp(8:8) = '4'
END IF
CASE ( 2 )
IF ( got1077 ) THEN
bfstyp(8:8) = '8'
ELSE
bfstyp(8:8) = '5'
END IF
CASE ( 3, 5 )
IF ( got1077 ) THEN
bfstyp(8:8) = '9'
ELSE
bfstyp(8:8) = '6'
END IF
END SELECT
IF ( ( bfstyp(7:7) .eq. '?' ) .or.
+ ( bfstyp(8:8) .eq. '?' ) ) THEN
WRITE ( UNIT = logmsg, FMT = '(A, I5, A, I3, A)' )
+ 'unexpected igctr, iswcm values of', igctr, ',',
+ iswcm, ' in report'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
CYCLE
END IF
ibfdt = ( irptdt (1) * 1000000 ) + ( irptdt (2) * 10000 )
+ + ( irptdt (3) * 100 ) + irptdt (4)
CALL OPENMB ( iubfmn, bfstyp, ibfdt )
IF ( got1077 ) THEN
C* If this is the first report in the message, get the
C* delayed replication counts. These are guaranteed to
C* be identical for every subset in the message, since
C* the message is compressed.
IF ( nrept .eq. 1 )
+ CALL EL_GDRC ( iubfma, nivr, naha, niii, ncld,
+ nive, nivs, nr8ot, ierdrc )
C* Store the main report data.
CALL DRFINI ( iubfmn, nivr, 1, '{AMVIVR}')
CALL DRFINI ( iubfmn, naha, 1, '{AMVAHA}')
CALL DRFINI ( iubfmn, niii, 1, '{AMVIII}')
CALL DRFINI ( iubfmn, ncld, 1, '{AMVCLD}')
CALL DRFINI ( iubfmn, nive, nivr, '{AMVIVE}')
CALL DRFINI ( iubfmn, nivs, nivr, '{AMVIVS}')
CALL UFBSEQ ( iubfmn, r8arr, nr8ot, 1,
+ ierusq, 'SATDRWN2' )
ELSE IF ( got1014 ) THEN
C* Store the main report data.
r8wk (1,1) = r8arr (1)
r8wk (2,1) = r8arr (3)
r8wk (3,1) = r8arr (4)
r8wk (4,1) = r8arr (5)
r8wk (5,1) = r8arr (25)
r8wk (6,1) = r8arr (14)
r8wk (7,1) = r8arr (15)
r8wk (8,1) = r8arr (19)
r8wk (9,1) = r8arr (20)
CALL UFBINT ( iubfmn, r8wk, MXP, 1, nlv,
+ 'SAID SCLF SSNX SSNY SAZA ' //
+ 'SIDP SWCM SCCF SCBW' )
r8wk (1,1) = r8arr (6)
r8wk (2,1) = r8arr (7)
r8wk (3,1) = r8arr (8)
r8wk (4,1) = r8arr (12)
r8wk (5,1) = r8arr (13)
r8wk (6,1) = r8arr (21)
CALL UFBINT ( iubfmn, r8wk, MXP, 1, nlv,
+ 'YEAR MNTH DAYS CLAT CLON CCST' )
C* Get and store the supplementary data.
CALL EL_SUPP ( iubfma, iubfmn, iersup )
END IF
C* Bulletin ID information.
CALL UT_CIBF ( iubfmn, 'SEQNUM', seqnum, 8, iercbf )
CALL UT_CIBF ( iubfmn, 'BUHD', buhd, 8, iercbf )
CALL UT_CIBF ( iubfmn, 'BORG', cborg, 8, iercbf )
CALL UT_CIBF ( iubfmn, 'BULTIM', bulldt, 8, iercbf )
CALL UT_CIBF ( iubfmn, 'BBB', bbb, 8, iercbf )
C* Corrected report indicator.
corn = 0.0
IF ( bbb (1:1) .eq. 'C' ) corn = 1.0
CALL UT_RIBF ( iubfmn, 'CORN', corn, ierrbf )
C* Receipt date-time.
CALL UT_RIBF ( iubfmn, 'RCYR', FLOAT( irundt(1) ), ierrbf)
CALL UT_RIBF ( iubfmn, 'RCMO', FLOAT( irundt(2) ), ierrbf)
CALL UT_RIBF ( iubfmn, 'RCDY', FLOAT( irundt(3) ), ierrbf)
CALL UT_RIBF ( iubfmn, 'RCHR', FLOAT( irundt(4) ), ierrbf)
CALL UT_RIBF ( iubfmn, 'RCMI', FLOAT( irundt(5) ), ierrbf)
CALL UT_RIBF ( iubfmn, 'RCTS', FLOAT( 0 ), ierrbf )
C* Write the report to the BUFR output stream.
CALL UT_WBFR ( iubfmn, 'elrw', 0, ierwbf )
END DO
END DO
END DO
RETURN
END