SUBROUTINE EL_BFIF ( iubfmf, cborg, iret ) C************************************************************************ C* EL_BFIF * C* * C* This subroutine decodes a report from a EUMETSAT or Japan satellite * C* wind BUFR message, converts it into interface output, and then writes* C* the interface output into the interface arrays. * C* * C* EL_BFIF ( IUBFMF, CBORG, IRET ) * C* * C* Input parameters: * C* IUBFMF INTEGER Logical unit number of * C* BUFR messages file * C* CBORG CHARACTER*(*) Bulletin originator * C* * C* Output parameters: * C* RIVALS (IRSAID) REAL Satellite identifier * C* (WMO BUFR Table 0 01 007) * C* RIVALS (IRGCTR) REAL Generating center identifier * C* (WMO BUFR Table 0 01 031) * C* RIVALS (IRSCLF) REAL Satellite classification * C* (WMO BUFR Table 0 02 020) * C* RIVALS (IRSSNX) REAL Segment size at nadir in X dir * C* RIVALS (IRSSNY) REAL Segment size at nadir in Y dir * C* RIVALS (IRSAZA) REAL Satellite zenith angle * C* RIVALS (IRYEAR) REAL Report year * C* RIVALS (IRMNTH) REAL Report month * C* RIVALS (IRDAYS) REAL Report day * C* RIVALS (IRHOUR) REAL Report hour * C* RIVALS (IRMINU) REAL Report minute * C* RIVALS (IRSECO) REAL Report second * C* RIVALS (IRSLAT) REAL Latitude in degrees * C* RIVALS (IRSLON) REAL Longitude in degrees * C* RIVALS (IRSIDP) REAL Satellite instrument used in * C* data processing * C* (WMO BUFR Table 0 02 152) * C* RIVALS (IRSWCM) REAL Satellite derived wind * C* computation method * C* (WMO BUFR Table 0 02 023) * C* RIVALS (IRPRES) REAL Pressure in millibars * C* RIVALS (IRDRCT) REAL Wind direction in degrees * C* RIVALS (IRSPED) REAL Wind speed in m/s * C* RIVALS (IRCCST) REAL Coldest cluster temp. in Kelvin * C* RIVALS(IRPCCFGC)REAL Generating center identifier * C* for PCCF values * C* (WMO BUFR Table 0 01 031) * C* RIVALS(IRPCCFGA)REAL Generating application at GCTR * C* for PCCF values * C* (WMO BUFR Table 0 01 032) * C* RIVALS(IRPCCFPR)REAL Per cent confidence in PRES * C* RIVALS(IRPCCFDR)REAL Per cent confidence in DRCT * C* RIVALS(IRPCCFSP)REAL Per cent confidence in SPED * C* RIVALS(IRPCCFCT)REAL Per cent confidence in CCST * C* RIVALS(IRMAQCGC)REAL Generating center identifier * C* for MAQC values * C* (WMO BUFR Table 0 01 031) * C* RIVALS(IRMAQCGA)REAL Generating application at GCTR * C* for MAQC values * C* (WMO BUFR Table 0 01 032) * C* RIVALS(IRMAQCPR)REAL Manual/automatic QC for PRES * C* (WMO BUFR Table 0 33 035) * C* RIVALS(IRMAQCDR)REAL Manual/automatic QC for DRCT * C* (WMO BUFR Table 0 33 035) * C* RIVALS(IRMAQCSP)REAL Manual/automatic QC for SPED * C* (WMO BUFR Table 0 33 035) * C* RIVALS(IRMAQCCT)REAL Manual/automatic QC for CCST * C* (WMO BUFR Table 0 33 035) * C* RIVALS(IRNCTHGC)REAL Generating center identifier * C* for NCTH values * C* (WMO BUFR Table 0 01 031) * C* RIVALS(IRNCTHGA)REAL Generating application at GCTR * C* for NCTH values * C* (WMO BUFR Table 0 01 032) * C* RIVALS(IRNCTHPR)REAL Nominal conf threshhold for PRES* C* RIVALS(IRNCTHDR)REAL Nominal conf threshhold for DRCT* C* RIVALS(IRNCTHSP)REAL Nominal conf threshhold for SPED* C* RIVALS(IRNCTHCT)REAL Nominal conf threshhold for CCST* C* R8VALS (IRSCCF) REAL Satellite channel frequency * C* (WMO BUFR Table 0 02 153) * C* R8VALS (IRSCBW) REAL Satellite channel band width * C* (WMO BUFR Table 0 02 154) * C* IRET INTEGER Return code: * C* 0 = normal return * C** * C* Log: * C* J. Ator/NCEP 11/00 * C* J. Ator/NCEP 05/01 Changed in response to EUMETSAT changes * C* J. Ator/NCEP 06/01 Use 'BUFR.CMN', clean up * C* J. Ator/NCEP 10/01 Simplify references to r8vals ( ) * C* J. Ator/NCEP 10/03 Stop logmsgs for non-"missing" TSIG vals* C* J. Ator/NCEP 10/04 Add capability for Japan & EUMS HRV/HWW * C* S. Guan/NCEP 06/14 Add RPSEQ1 and MDPT2 to output * C* J. Ator/NCEP 01/18 Add capability for India * C* J. Ator/NCEP 01/18 (Re)set ixbm(21) during each call. * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'elcmn.cmn' C* CHARACTER*(*) cborg C* C* Total number of bitmap values within a EUMETSAT or Japan C* satellite wind BUFR message. C* PARAMETER ( NBMVAL = 103 ) C* C* Array of expected bitmap values. C* INTEGER ixbm ( NBMVAL ) C* REAL*8 r8wkd1 ( NBMVAL ) C* C* Indicator for whether this is the first call to this subroutine. C* INTEGER ifirst C* DATA ifirst / 0 / C* SAVE ixbm, ifirst C* INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 C IF ( ifirst .eq. 0 ) THEN ifirst = 1 C C* Initialize the expected bitmap values. These are constant C* for all originators so only need to be set once during C* program startup. C DO ii = 1, NBMVAL ixbm (ii) = IMISSD END DO ixbm ( 16 ) = 0 ixbm ( 17 ) = 0 ixbm ( 18 ) = 0 END IF C C* The following bitmap value needs to be set for each new report, C* since it can vary by originator. C IF ( cborg(1:4) .ne. 'DEMS' ) THEN ixbm ( 21 ) = 0 ELSE ixbm ( 21 ) = IMISSD END IF C C* Decode the data into the interface arrays. C CALL UT_BFRI ( iubfmf, 'SAID', rivals ( irsaid ), ierbri ) CALL UT_BFRI ( iubfmf, 'SCLF', rivals ( irsclf ), ierbri ) CALL UT_BFRI ( iubfmf, 'SSNX', rivals ( irssnx ), ierbri ) CALL UT_BFRI ( iubfmf, 'SSNY', rivals ( irssny ), ierbri ) CALL UT_BFRI ( iubfmf, 'SAZA', rivals ( irsaza ), ierbri ) CALL UT_BFRI ( iubfmf, 'YEAR', rivals ( iryear ), ierbri ) CALL UT_BFRI ( iubfmf, 'MNTH', rivals ( irmnth ), ierbri ) CALL UT_BFRI ( iubfmf, 'DAYS', rivals ( irdays ), ierbri ) CALL UT_BFRI ( iubfmf, 'CLATH', rivals ( irslat ), ierbri ) CALL UT_BFRI ( iubfmf, 'CLONH', rivals ( irslon ), ierbri ) CALL UT_BFRI ( iubfmf, 'SIDP', rivals ( irsidp ), ierbri ) CALL UT_BFRI ( iubfmf, 'SWCM', rivals ( irswcm ), ierbri ) C CALL UFBINT ( iubfmf, r8vals ( irsccf ), 1, 1, ierufb, 'SCCF' ) CALL UFBINT ( iubfmf, r8vals ( irscbw ), 1, 1, ierufb, 'SCBW' ) C CALL UT_BFRI ( iubfmf, 'CCST', rivals ( irccst ), ierbri ) C C* Unpack and check the time significance values, and write a log C* message for any that are not "missing". C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'TSIG' ) DO ii = 1, 4 rivals ( irfttsig (ii) ) = UT_BMRI ( r8wkd1 (2*ii+1) ) rivals ( irsdtsig (ii) ) = UT_BMRI ( r8wkd1 (2*ii+2) ) END DO DO ii = 1, ierufb tsig = UT_BMRI ( r8wkd1 (ii) ) IF ( .not. ERMISS ( tsig ) ) THEN WRITE ( UNIT = logmsg, FMT = '(I3, A, F4.0)' ) + ii, 'th TSIG value was ', tsig CALL DC_WLOG ( 4, 'DC', 2, logmsg, ierwlg ) END IF END DO C C* Unpack and check the height assignment values, and write a log C* message for any that are not "missing". C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'HAMD' ) DO ii = 1, ierufb rivals (irshamd(ii) ) = UT_BMRI ( r8wkd1 (ii+1) ) hamd = UT_BMRI ( r8wkd1 (ii) ) IF ( .not. ERMISS ( hamd ) ) THEN WRITE ( UNIT = logmsg, FMT = '(I3, A, F4.0)' ) + ii, 'th HAMD value was ', hamd CALL DC_WLOG ( 4, 'DC', 2, logmsg, ierwlg ) END IF END DO C C* Unpack and check the bitmap values and, if one is found that C* does not match the corresponding value in the expected bitmap, C* then write a log message and RETURN. C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'DPRI' ) DO ii = 1, NBMVAL IF ( INT ( UT_BMRI ( r8wkd1 (ii) ) ) .ne. ixbm (ii) ) THEN WRITE ( UNIT = logmsg, FMT = '(A, I3)' ) + 'Unexpected bitmap value at position ', ii CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) RETURN END IF END DO C C* Decode and store the quality control indicators. C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'GCLONG' ) rivals ( irgctr ) = UT_BMRI ( r8wkd1 (1) ) rivals ( irpccfgc (1) ) = UT_BMRI ( r8wkd1 (2) ) rivals ( irmaqcgc (1) ) = UT_BMRI ( r8wkd1 (3) ) rivals ( irncthgc (1) ) = UT_BMRI ( r8wkd1 (4) ) rivals ( irpccfgc (2) ) = UT_BMRI ( r8wkd1 (5) ) rivals ( irmaqcgc (2) ) = UT_BMRI ( r8wkd1 (6) ) rivals ( irncthgc (2) ) = UT_BMRI ( r8wkd1 (7) ) IF ( ierufb .gt. 7 ) THEN rivals ( irpccfgc (3) ) = UT_BMRI ( r8wkd1 (8) ) rivals ( irmaqcgc (3) ) = UT_BMRI ( r8wkd1 (9) ) rivals ( irncthgc (3) ) = UT_BMRI ( r8wkd1 (10) ) END IF C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'GNAP' ) rivals ( irpccfga (1) ) = UT_BMRI ( r8wkd1 (1) ) rivals ( irmaqcga (1) ) = UT_BMRI ( r8wkd1 (2) ) rivals ( irncthga (1) ) = UT_BMRI ( r8wkd1 (3) ) rivals ( irpccfga (2) ) = UT_BMRI ( r8wkd1 (4) ) rivals ( irmaqcga (2) ) = UT_BMRI ( r8wkd1 (5) ) rivals ( irncthga (2) ) = UT_BMRI ( r8wkd1 (6) ) IF ( ierufb .gt. 6 ) THEN rivals ( irpccfga (3) ) = UT_BMRI ( r8wkd1 (7) ) rivals ( irmaqcga (3) ) = UT_BMRI ( r8wkd1 (8) ) rivals ( irncthga (3) ) = UT_BMRI ( r8wkd1 (9) ) END IF C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'PCCF' ) rivals ( irpccfpr (1) ) = UT_BMRI ( r8wkd1 (1) ) rivals ( irpccfdr (1) ) = UT_BMRI ( r8wkd1 (2) ) rivals ( irpccfsp (1) ) = UT_BMRI ( r8wkd1 (3) ) rivals ( irpccfct (1) ) = UT_BMRI ( r8wkd1 (4) ) rivals ( irpccfpr (2) ) = UT_BMRI ( r8wkd1 (5) ) rivals ( irpccfdr (2) ) = UT_BMRI ( r8wkd1 (6) ) rivals ( irpccfsp (2) ) = UT_BMRI ( r8wkd1 (7) ) rivals ( irpccfct (2) ) = UT_BMRI ( r8wkd1 (8) ) IF ( ierufb .gt. 8 ) THEN rivals ( irpccfpr (3) ) = UT_BMRI ( r8wkd1 (9) ) rivals ( irpccfdr (3) ) = UT_BMRI ( r8wkd1 (10) ) rivals ( irpccfsp (3) ) = UT_BMRI ( r8wkd1 (11) ) rivals ( irpccfct (3) ) = UT_BMRI ( r8wkd1 (12) ) END IF C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'MAQC' ) rivals ( irmaqcpr (1) ) = UT_BMRI ( r8wkd1 (1) ) rivals ( irmaqcdr (1) ) = UT_BMRI ( r8wkd1 (2) ) rivals ( irmaqcsp (1) ) = UT_BMRI ( r8wkd1 (3) ) rivals ( irmaqcct (1) ) = UT_BMRI ( r8wkd1 (4) ) rivals ( irmaqcpr (2) ) = UT_BMRI ( r8wkd1 (5) ) rivals ( irmaqcdr (2) ) = UT_BMRI ( r8wkd1 (6) ) rivals ( irmaqcsp (2) ) = UT_BMRI ( r8wkd1 (7) ) rivals ( irmaqcct (2) ) = UT_BMRI ( r8wkd1 (8) ) IF ( ierufb .gt. 8 ) THEN rivals ( irmaqcpr (3) ) = UT_BMRI ( r8wkd1 (9) ) rivals ( irmaqcdr (3) ) = UT_BMRI ( r8wkd1 (10) ) rivals ( irmaqcsp (3) ) = UT_BMRI ( r8wkd1 (11) ) rivals ( irmaqcct (3) ) = UT_BMRI ( r8wkd1 (12) ) END IF C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'NCTH' ) rivals ( irncthpr (1) ) = UT_BMRI ( r8wkd1 (1) ) rivals ( irncthdr (1) ) = UT_BMRI ( r8wkd1 (2) ) rivals ( irncthsp (1) ) = UT_BMRI ( r8wkd1 (3) ) rivals ( irncthct (1) ) = UT_BMRI ( r8wkd1 (4) ) rivals ( irncthpr (2) ) = UT_BMRI ( r8wkd1 (5) ) rivals ( irncthdr (2) ) = UT_BMRI ( r8wkd1 (6) ) rivals ( irncthsp (2) ) = UT_BMRI ( r8wkd1 (7) ) rivals ( irncthct (2) ) = UT_BMRI ( r8wkd1 (8) ) IF ( ierufb .gt. 8 ) THEN rivals ( irncthpr (3) ) = UT_BMRI ( r8wkd1 (9) ) rivals ( irncthdr (3) ) = UT_BMRI ( r8wkd1 (10) ) rivals ( irncthsp (3) ) = UT_BMRI ( r8wkd1 (11) ) rivals ( irncthct (3) ) = UT_BMRI ( r8wkd1 (12) ) END IF C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'HOUR' ) rivals ( irhour ) = UT_BMRI ( r8wkd1 (1) ) DO ii = 1, 4 rivals ( irfthour (ii) ) = UT_BMRI ( r8wkd1 (2*ii +1) ) rivals ( irsdhour (ii) ) = UT_BMRI ( r8wkd1 (2*ii+2) ) END DO C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'MINU' ) rivals ( irminu ) = UT_BMRI ( r8wkd1 (1) ) DO ii = 1, 4 rivals ( irftminu (ii) ) = UT_BMRI ( r8wkd1 (2*ii ) ) rivals ( irsdminu (ii) ) = UT_BMRI ( r8wkd1 (2*ii+1) ) END DO C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'SECO' ) rivals ( irseco ) = UT_BMRI ( r8wkd1 (1) ) DO ii = 1, 4 rivals ( irftseco (ii) ) = UT_BMRI ( r8wkd1 (2*ii) ) rivals ( irsdseco (ii) ) = UT_BMRI ( r8wkd1 (2*ii+1) ) END DO C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'WDIR' ) rivals ( irdrct ) = UT_BMRI ( r8wkd1 (1) ) DO ii = 1,4 rivals ( irsdwdir (ii) ) = UT_BMRI ( r8wkd1 (ii +1) ) END DO DO ii = 1, ierufb wdir = UT_BMRI ( r8wkd1 (ii) ) IF ( .not. ERMISS ( wdir ) ) THEN WRITE ( UNIT = logmsg, FMT = '(I3, A, F4.0)' ) + ii, 'th WDIR value was ', wdir CALL DC_WLOG ( 4, 'DC', 2, logmsg, ierwlg ) END IF END DO C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'WSPD' ) rivals ( irsped ) = UT_BMRI ( r8wkd1 (1) ) DO ii = 1,4 rivals ( irsdwspd (ii) ) = UT_BMRI ( r8wkd1 (ii +1) ) END DO C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'PRLC' ) rivals ( irpres ) = PR_D100 ( UT_BMRI ( r8wkd1 (1) ) ) DO ii = 1, 10 rivals ( irsprlc (ii) ) = + PR_D100 ( UT_BMRI ( r8wkd1 (ii +1) ) ) END DO C CALL UFBREP ( iubfmf, r8wkd1, 1, NBMVAL, ierufb, 'TMDBST' ) DO ii = 1, 10 rivals ( irstmdbst (ii) ) = UT_BMRI ( r8wkd1 (ii ) ) END DO C* RETURN END