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