SUBROUTINE EL_DCOD ( cldt, bufrte, bufrtj, bufrte2, bufrtn, + nhours, iret ) C************************************************************************ C* EL_DCOD * C* * C* This routine decodes bulletins containing EUMETSAT or Japan satellite* C* wind reports into NCEP BUFR format. * C* * C* EL_DCOD ( CLDT, BUFRTE, BUFRTJ, BUFRTN, NHOURS, IRET ) * C* * C* Input parameters: * C* CLDT CHAR* Date-time from command line * C* BUFRTE CHAR* EUMETSAT satellite wind BUFR * C* tables file * C* BUFRTJ CHAR* Japan satellite wind BUFR * C* tables file * C* BUFRTE2 CHAR* EUMETSAT2 satellite wind BUFR * C* tables file with 3-10-077 seq. * 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************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'BUFR.CMN' INCLUDE 'elcmn.cmn' C* C* Number of non-NCEP BUFR tables files. C* PARAMETER ( NBUFRT = 3 ) C* CHARACTER*(*) cldt, bufrte, bufrtj, bufrte2, bufrtn C* CHARACTER bull*(DCMXBF), cbull*(DCMXBF), bfstyp*8, + seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8, + rundt*12, sysdt*12, + rimnem(NRIMN)*8, r8mnem(NR8IMN)*8, + bufrtf(NBUFRT)*(DCMXLN) C* INTEGER irundt (5), irptdt (5), + iubfmf ( NBUFRT ), iubftf ( NBUFRT ), + nxdsc ( NBUFRT ), + ibull ( DCMXBF / 4 ), + nive ( MXBFLV ), nivs ( MXBFLV ) C* LOGICAL bullok, msgok, corrupt C* PARAMETER ( MXVAL = 5000 ) C* REAL*8 GETBMISS, r8arr ( MXVAL ), r8wk ( 4, MXBFLV ) C* EQUIVALENCE ( cbull (1:4), ibull (1) ) C* C* Number of expected descriptors within Section 3 of each C* type of non-NCEP BUFR message. C* PARAMETER ( NXDSCE = 39 ) PARAMETER ( NXDSCJ = 57 ) PARAMETER ( NXDSCE2 = 1 ) C* C* The following array will hold the list of expected descriptors C* within Section 3 of each type of non-NCEP BUFR message. C* The first dimension of this array must be at least as large C* as the largest of the above NXDSC values. C* CHARACTER cxdsc( NXDSCJ, NBUFRT )*6 C* C* Expected descriptors within Section 3 of a EUMETSAT C* satellite wind BUFR message. C* DATA ( cxdsc ( ii, 1 ), ii = 1, NXDSCE ) + / '310014', + '222000', '236000', '101103', '031031', + '001031', '001032', '101004', '033007', + '222000', '237000', + '001031', '001032', '101004', '033035', + '222000', '237000', + '001031', '001032', '101004', '033036', + '222000', '237000', + '001031', '001032', '101004', '033007', + '222000', '237000', + '001031', '001032', '101004', '033035', + '222000', '237000', + '001031', '001032', '101004', '033036' / C* C* Expected descriptors within Section 3 of a Japan C* satellite wind BUFR message. C* DATA ( cxdsc ( ii, 2 ), ii = 1, NXDSCJ ) + / '310014', + '222000', '236000', '101103', '031031', + '001031', '001032', '101004', '033007', + '222000', '237000', + '001031', '001032', '101004', '033035', + '222000', '237000', + '001031', '001032', '101004', '033036', + '222000', '237000', + '001031', '001032', '101004', '033007', + '222000', '237000', + '001031', '001032', '101004', '033035', + '222000', '237000', + '001031', '001032', '101004', '033036', + '222000', '237000', + '001031', '001032', '101004', '033007', + '222000', '237000', + '001031', '001032', '101004', '033035', + '222000', '237000', + '001031', '001032', '101004', '033036' / C* C* Expected descriptors within Section 3 of a EUMETSAT2 C* 3-10-077 satellite wind BUFR message. C* DATA ( cxdsc ( ii, 3 ), ii = 1, NXDSCE2 ) + / '310077' / C* INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 C bufrtf(1) = bufrte nxdsc(1) = NXDSCE C bufrtf(2) = bufrtj nxdsc(2) = NXDSCJ C bufrtf(3) = bufrte2 nxdsc(3) = NXDSCE2 C C* Set the pointers for the interface arrays. C CALL EL_IFSP ( rimnem, r8mnem, ierfsp ) IF ( ierfsp .ne. 0 ) THEN RETURN END IF C C* Loop on each type of non-NCEP BUFR tables file. C DO ii = 1, NBUFRT C C* Open the tables file. C CALL FL_SOPN ( bufrtf (ii), iubftf (ii), ierspn ) IF ( ierspn .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ierspn, bufrtf (ii), ierwlg ) RETURN END IF C C* Open the messages file. C CALL FL_GLUN ( iubfmf (ii), iergln ) IF ( iergln .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg ) RETURN END IF C C* Connect the tables and messages files. C CALL OPENBF ( iubfmf (ii), 'INUL', iubftf (ii) ) C C* Close the tables file. C CALL FL_CLOS ( iubftf (ii), iercls ) IF ( iercls .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg ) END IF C END DO C C* Open the tables file for the NCEP BUFR (i.e. output) stream. C CALL FL_SOPN ( bufrtn, iubftn, ierspn ) IF ( ierspn .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ierspn, bufrtn, ierwlg ) RETURN END IF C C* Open the messages file for the NCEP BUFR (i.e. output) stream. C CALL FL_GLUN ( iubfmn, iergln ) IF ( iergln .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg ) RETURN END IF C C* Connect the tables and messages files for the C* NCEP BUFR (i.e. output) stream. C CALL OPENBF ( iubfmn, 'NUL', iubftn ) r8bfms = GETBMISS() C C* Close the tables file for the NCEP BUFR (i.e. output) stream. C CALL FL_CLOS ( iubftn, iercls ) IF ( iercls .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg ) END IF C DO WHILE ( .true. ) C C* Get a new bulletin from the input pipe. C CALL DC_GBUL ( bull, lenb, ifdtyp, iergbl ) IF ( iergbl .ne. 0 ) THEN C C* A time-out occurred while waiting for a new bulletin C* on the input pipe. Shut down the decoder and exit. C CALL DC_WLOG ( 0, 'DC', iergbl, ' ', ierwlg ) DO ii = 1, NBUFRT CALL CLOSBF ( iubfmf (ii) ) END DO CALL CLOSBF ( iubfmn ) CALL FL_CLAL ( iercal ) RETURN END IF C bullok = .true. C C* Decode the header information from this bulletin. C IF ( ifdtyp .eq. 0 ) THEN C C* Decode WMO products. C CALL DC_GHDR ( bull, lenb, seqnum, buhd, cborg, + bulldt, bbb, ibptr, ierghd ) IF ( ierghd .ne. 0 ) THEN CALL DC_WLOG ( 2, 'DC', ierghd, ' ', ierwlg ) bullok = .false. ELSE C C* Start an entry for this bulletin in the decoder log. C logmsg = '####################' // + '####################' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) logmsg = seqnum // buhd // cborg // bulldt // bbb CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) END IF ELSE C C* Do not decode AFOS products. C bullok = .false. END IF IF ( bullok ) THEN 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 ) bullok = .false. END IF END IF IF ( bullok ) THEN C C* If a date-time was entered on the command line, then C* use it as the run date-time. Otherwise, use the C* system time as the run 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 ) bullok = .false. END IF END IF END IF IF ( bullok ) THEN 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 ) bullok = .false. END IF END IF DO WHILE ( bullok ) C C* Locate the next BUFR message within the bulletin C* and store it within an equivalenced integer array. C ipt1 = INDEX ( bull ( ibptr : lenb ), 'BUFR' ) IF ( ipt1 .eq. 0 ) THEN C C* There are no more BUFR messages within the bulletin. C bullok = .false. C C* Make sure that all BUFR output for this bulletin C* has been written to the BUFR output stream before C* going back to DC_GBUL and waiting for a new bulletin C* on the input pipe. C CALL UT_WBFR ( iubfmn, 'elrw', 1, ierwbf ) C ELSE istart = ibptr + ipt1 - 1 ibptr = istart + 4 cbull = bull ( istart : lenb ) C nrept = 0 msgok = .false. C C* Check for a corrupt message. C corrupt = .false. msglen = IUPBS01 ( ibull, 'LENM' ) IF ( ( msglen .gt. lenb ) .or. + ( cbull ( msglen-3 : msglen ) .ne. '7777' ) ) + THEN corrupt = .true. logmsg = 'ERROR: corrupt BUFR message' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) ELSE C C* Determine which BUFR tables file this message C* corresponds to. C ii = 1 DO WHILE ( ( .not. msgok ) .and. + ( ii .le. NBUFRT ) ) CALL UT_CBS3 ( 4, ibull, cxdsc ( 1, ii ), + nxdsc ( ii ), iercs3 ) IF ( iercs3 .eq. 0 ) THEN msgok = .true. ELSE ii = ii + 1 END IF END DO END IF C IF ( msgok ) THEN logmsg = 'message read using ' // bufrtf (ii) CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) C C* Open this BUFR message. C CALL READERME ( ibull, iubfmf (ii), + bfstyp, ibfdt, ierrme ) IF ( ierrme .ne. 0 ) THEN msgok = .false. END IF ELSE IF ( .not. corrupt ) THEN logmsg = 'message has unknown format' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) END IF C DO WHILE ( msgok ) C C* Get the next report from this BUFR message. C IF ( IREADSB ( iubfmf (ii) ) .ne. 0 ) THEN C C* There are no more reports in this message. C msgok = .false. C C* Print a count of the number of reports C* processed. C WRITE ( UNIT = logmsg, FMT = '( A, I4, A )' ) + 'contained ', nrept, ' reports' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) C ELSE nrept = nrept + 1 C C* Initialize the interface arrays. C CALL EL_IFIV ( ierifi ) C IF ( ii .eq. 3 ) THEN C C* Decode the 3-10-077 report. C CALL UFBSEQ ( iubfmf (ii), r8arr, MXVAL, 1, + ierusq, 'SATDRWN2' ) rivals ( irgctr ) = UT_BMRI ( r8arr (1) ) rivals ( irswcm ) = UT_BMRI ( r8arr (14) ) rivals ( iryear ) = UT_BMRI ( r8arr (20) ) rivals ( irmnth ) = UT_BMRI ( r8arr (21) ) rivals ( irdays ) = UT_BMRI ( r8arr (22) ) rivals ( irhour ) = UT_BMRI ( r8arr (23) ) rivals ( irminu ) = UT_BMRI ( r8arr (24) ) C C* If this is the first report in the message, C* get the delayed replication counts. These C* are guaranteed to be identical for every C* subset in the message, since the message is C* compressed. C IF ( nrept .eq. 1 ) THEN CALL UFBINT ( iubfmf (ii), r8wk, 4, + MXBFLV, ierufb, + '{AMVIVR} {AMVAHA} {AMVIII} {AMVCLD}' ) nivr = IDINT ( r8wk (1,1) ) naha = IDINT ( r8wk (2,1) ) niii = IDINT ( r8wk (3,1) ) ncld = IDINT ( r8wk (4,1) ) nr8ot = ( naha * 4 ) + ( niii * 13 ) + + ( ncld * 17 ) + 69 CALL UFBINT ( iubfmf (ii), r8wk, 4, + MXBFLV, ierufb, + '{AMVIVE} {AMVIVS}' ) DO jj = 1, nivr nive (jj) = IDINT ( r8wk (1, jj) ) nivs (jj) = IDINT ( r8wk (2, jj) ) nr8ot = nr8ot + ( nive (jj) * 3 ) + + ( nivs (jj) * 3 ) + 9 END DO END IF ELSE C C* Decode the report into the interface arrays. C CALL EL_BFIF ( iubfmf (ii), cborg, ierbif ) C C* Write the report data to the decoder log. C CALL EL_IFPT ( 3, rimnem, r8mnem, ierifp ) END IF 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 irptdt (1) = INT ( rivals ( iryear ) ) irptdt (2) = INT ( rivals ( irmnth ) ) irptdt (3) = INT ( rivals ( irdays ) ) irptdt (4) = INT ( rivals ( irhour ) ) irptdt (5) = INT ( rivals ( irminu ) ) CALL DC_TMCK ( 2, irundt, irptdt, nhours, + 180, iertmk ) END IF IF ( iertmk .eq. 0 ) THEN C C* Convert interface-format data for this C* report into BUFR output and then write the C* BUFR output to the BUFR output stream. C CALL EL_BUFR ( iubfmn, ii, irundt, seqnum, + buhd, cborg, bulldt, bbb, + ierbfr ) IF ( ii .eq. 3 ) THEN 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' ) END IF C C* Write the report to the BUFR output stream. C CALL UT_WBFR ( iubfmn, 'elrw', 0, ierwbf ) END IF C logmsg = '-----------------------------------' CALL DC_WLOG ( 3, 'DC', 2, logmsg, ierwlg ) END IF END DO END IF END DO END DO C* RETURN END