SUBROUTINE EL_BUFR ( iubfmn, idxbmf, irundt, seqnum, buhd,
+ cborg, bulldt, bbb, iret )
C************************************************************************
C* EL_BUFR *
C* *
C* This subroutine retrieves data from the interface arrays, converts *
C* it into BUFR output, and then writes the BUFR output to the BUFR *
C* output stream. *
C* *
C* EL_BUFR ( IUBFMN, IRUNDT, SEQNUM, BUHD, *
C* CBORG, BULLDT, BBB, IRET ) *
C* *
C* Input parameters: *
C* IUBFMN INTEGER Logical unit number of messages *
C* file for BUFR output stream *
C* IDXBMF INTEGER Index of non-NCEP BUFR tables *
C* file used to read in the data *
C* IRUNDT (5) INTEGER Run date-time *
C* (YYYY, MM, DD, HH, MM) *
C* SEQNUM CHAR* Bulletin sequence number *
C* BUHD CHAR* Bulletin header *
C* CBORG CHAR* Bulletin originator *
C* BULLDT CHAR* Bulletin date-time *
C* BBB CHAR* Bulletin BBB indicator *
C* *
C* Output parameters: *
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 UT_WBFR and BUFR.CMN, clean up *
C* J. Ator/NCEP 10/01 Simplify references to r8vals ( ) *
C* J. Ator/NCEP 01/02 GCLONG -> OGCE *
C* J. Ator/NCEP 10/04 Add capability for Japan & EUMS HRV/HWW *
C* J. Ator/NCEP 02/05 Adjust for new SWCM values in NC005046 *
C* J. Ator/NCEP 07/05 Add capability for EUMS WVW *
C* J. Ator/NCEP 09/06 Adjust for 3rd QC level in EUMG reports *
C* S. Guan/NCEP 06/14 Add RPSEQ1 and MDPT2 to BUFR output *
C* J. Ator/NCEP 01/18 Add capability for India *
C* J. Ator/NCEP 09/20 Add capability to process 3-10-077 data *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'elcmn.cmn'
PARAMETER ( MXMN = 10 )
C*
CHARACTER seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8,
+ bfstyp*8
C*
REAL*8 r8ary ( MXMN, 13 ), UT_RIBM
C*
INTEGER irundt (5)
C*
INCLUDE 'ERMISS.FNC'
C*-----------------------------------------------------------------------
iret = 0
C
C* Set the BUFR message date-time.
C
year = rivals ( iryear )
rmth = rivals ( irmnth )
days = rivals ( irdays )
hour = rivals ( irhour )
IF ( ( ERMISS ( year ) ) .or. ( ERMISS ( rmth ) ) .or.
+ ( ERMISS ( days ) ) .or. ( ERMISS ( hour ) ) ) THEN
RETURN
END IF
ibfdt = ( INT ( year ) * 1000000 ) + ( INT ( rmth ) * 10000 ) +
+ ( INT ( days ) * 100 ) + INT ( hour )
C
C* Open a BUFR message for output.
C
iswcm = INT ( rivals ( irswcm ) )
igctr = INT ( rivals ( irgctr ) )
bfstyp = '????????'
IF ( igctr .eq. 34 ) THEN
IF ( iswcm .eq. 1 ) THEN
bfstyp = 'NC005044'
ELSE IF ( iswcm .eq. 2 ) THEN
bfstyp = 'NC005045'
ELSE IF ( ( iswcm .eq. 3 ) .or. ( iswcm .eq. 5 ) ) THEN
bfstyp = 'NC005046'
END IF
ELSE IF ( igctr .eq. 28 ) THEN
IF ( iswcm .eq. 1 ) THEN
bfstyp = 'NC005024'
ELSE IF ( iswcm .eq. 2 ) THEN
bfstyp = 'NC005025'
ELSE IF ( ( iswcm .eq. 3 ) .or. ( iswcm .eq. 5 ) ) THEN
bfstyp = 'NC005026'
END IF
ELSE
IF ( iswcm .eq. 1 ) THEN
IF ( idxbmf .eq. 3 ) THEN
bfstyp = 'NC005067'
ELSE
bfstyp = 'NC005064'
END IF
ELSE IF ( iswcm .eq. 2 ) THEN
IF ( idxbmf .eq. 3 ) THEN
bfstyp = 'NC005068'
ELSE
bfstyp = 'NC005065'
END IF
ELSE IF ( ( iswcm .eq. 3 ) .or. ( iswcm .eq. 5 ) ) THEN
IF ( idxbmf .eq. 3 ) THEN
bfstyp = 'NC005069'
ELSE
bfstyp = 'NC005066'
END IF
END IF
END IF
IF ( bfstyp .eq. '????????' ) THEN
WRITE ( UNIT = logmsg, FMT = '(A, I2, A)' )
+ 'unexpected SWCM value of ', iswcm, ' in report'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
RETURN
END IF
CALL OPENMB ( iubfmn, bfstyp, ibfdt )
C
C* Bulletin ID information.
C
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
C* Report date-time.
C
CALL UT_RIBF ( iubfmn, 'YEAR', rivals ( iryear ), ierrbf )
CALL UT_RIBF ( iubfmn, 'MNTH', rivals ( irmnth ), ierrbf )
CALL UT_RIBF ( iubfmn, 'DAYS', rivals ( irdays ), ierrbf )
C
C* Corrected report indicator.
C
corn = 0.0
IF ( bbb (1:1) .eq. 'C' ) THEN
corn = 1.0
END IF
CALL UT_RIBF ( iubfmn, 'CORN', corn, ierrbf )
C
C* Receipt date-time.
C
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
C* If this is a 3-10-077 report, then there's nothing further
C* to be done here.
C
IF ( idxbmf .eq. 3 ) RETURN
C
C* Satellite identifier.
C
CALL UT_RIBF ( iubfmn, 'SAID', rivals ( irsaid ), ierrbf )
C
C* Satellite classification.
C
CALL UT_RIBF ( iubfmn, 'SCLF', rivals ( irsclf ), ierrbf )
C
C* Segment size at nadir in X direction.
C
CALL UT_RIBF ( iubfmn, 'SSNX', rivals ( irssnx ), ierrbf )
C
C* Segment size at nadir in Y direction.
C
CALL UT_RIBF ( iubfmn, 'SSNY', rivals ( irssny ), ierrbf )
C
C* Satellite zenith angle.
C
CALL UT_RIBF ( iubfmn, 'SAZA', rivals ( irsaza ), ierrbf )
C
C* Latitude.
C
CALL UT_RIBF ( iubfmn, 'CLAT', rivals ( irslat ), ierrbf )
C
C* Longitude.
C
CALL UT_RIBF ( iubfmn, 'CLON', rivals ( irslon ), ierrbf )
C
C* Satellite instrument used in data processing.
C
CALL UT_RIBF ( iubfmn, 'SIDP', rivals ( irsidp ), ierrbf )
C
C* Satellite derived wind calculation method.
C
CALL UT_RIBF ( iubfmn, 'SWCM', rivals ( irswcm ), ierrbf )
C
C* Satellite channel centre frequency.
C
CALL UFBINT ( iubfmn, r8vals ( irsccf ), 1, 1, ierufb, 'SCCF')
C
C* Satellite channel band width.
C
CALL UFBINT ( iubfmn, r8vals ( irscbw ), 1, 1, ierufb, 'SCBW')
C
C* Coldest cluster temperature.
C
CALL UT_RIBF ( iubfmn, 'CCST', rivals ( irccst ), ierrbf )
C
C* Store the QC parameters.
C
C* Note that this logic and BUFR table design presume that the
C* same generating center (i.e. OGCE) and generating application
C* (i.e. GNAP) were used for all three QC parameters (e.g. PCCF,
C* MAQC and NCTH) at a particular QC level.
C
C* Reports from RJTD and EUMG contain 3 QC levels, whereas reports
C* from EUMS contain 2. For purposes of this routine, just always
C* store 3 QC levels, and the last level for EUMS reports will
C* just contain "missing" values.
C
nqc = 3
C
C* Generating center.
C
r8ary ( 1, 1 ) = UT_RIBM ( rivals ( irgctr ) )
DO ii = 1, nqc
r8ary ( 1, ii + 1 ) =
+ UT_RIBM ( rivals (irpccfgc(ii)) )
r8ary ( 1, nqc + ii + 1 ) =
+ UT_RIBM ( rivals (irpccfgc(ii)) )
r8ary ( 1, (2*nqc)+ ii + 1 ) =
+ UT_RIBM ( rivals (irpccfgc(ii)) )
r8ary ( 1, (3*nqc)+ ii + 1 ) =
+ UT_RIBM ( rivals (irpccfgc(ii)) )
END DO
CALL UFBREP ( iubfmn, r8ary, MXMN, ((4*nqc)+1), ierufb, 'OGCE' )
C
DO ii = 1, nqc
C
C* Generating application.
C
r8ary ( 1, ii ) = UT_RIBM ( rivals (irpccfga(ii)) )
r8ary ( 1, nqc + ii ) = UT_RIBM ( rivals (irpccfga(ii)) )
r8ary ( 1, (2*nqc)+ ii ) = UT_RIBM ( rivals (irpccfga(ii)) )
r8ary ( 1, (3*nqc)+ ii ) = UT_RIBM ( rivals (irpccfga(ii)) )
C
C* Percent confidence.
C
r8ary ( 2, ii ) = UT_RIBM ( rivals (irpccfpr(ii)) )
r8ary ( 2, nqc + ii ) = UT_RIBM ( rivals (irpccfdr(ii)) )
r8ary ( 2, (2*nqc)+ ii ) = UT_RIBM ( rivals (irpccfsp(ii)) )
r8ary ( 2, (3*nqc)+ ii ) = UT_RIBM ( rivals (irpccfct(ii)) )
C
C* Manual/automatic quality control.
C
r8ary ( 3, ii ) = UT_RIBM ( rivals (irmaqcpr(ii)) )
r8ary ( 3, nqc + ii ) = UT_RIBM ( rivals (irmaqcdr(ii)) )
r8ary ( 3, (2*nqc)+ ii ) = UT_RIBM ( rivals (irmaqcsp(ii)) )
r8ary ( 3, (3*nqc)+ ii ) = UT_RIBM ( rivals (irmaqcct(ii)) )
C
C* Nominal confidence threshhold.
C
r8ary ( 4, ii ) = UT_RIBM ( rivals (irncthpr(ii)) )
r8ary ( 4, nqc + ii ) = UT_RIBM ( rivals (irncthdr(ii)) )
r8ary ( 4, (2*nqc)+ ii ) = UT_RIBM ( rivals (irncthsp(ii)) )
r8ary ( 4, (3*nqc)+ ii ) = UT_RIBM ( rivals (irncthct(ii)) )
END DO
CALL UFBREP ( iubfmn, r8ary, MXMN, (4*nqc), ierufb,
+ 'GNAP PCCF MAQC NCTH' )
C
C* HOUR MINU SECO
C
r8ary ( 1, 1 ) = UT_RIBM ( rivals ( irhour ) )
r8ary ( 2, 1 ) = UT_RIBM ( rivals ( irminu ) )
r8ary ( 3, 1 ) = UT_RIBM ( rivals ( irseco ) )
DO ii = 1, 4
r8ary ( 1, 2*ii ) = UT_RIBM ( rivals (irfthour(ii)) )
r8ary ( 2, 2*ii ) = UT_RIBM ( rivals (irftminu(ii)) )
r8ary ( 3, 2*ii ) = UT_RIBM ( rivals (irftseco(ii)) )
r8ary ( 1, 2*ii+1 ) = UT_RIBM ( rivals (irsdhour(ii)) )
r8ary ( 2, 2*ii+1 ) = UT_RIBM ( rivals (irsdminu(ii)) )
r8ary ( 3, 2*ii+1 ) = UT_RIBM ( rivals (irsdseco(ii)) )
END DO
CALL UFBREP ( iubfmn, r8ary, 10, 9, ierufb,
+ 'HOUR MINU SECO' )
C
C* Wind direction and wind speed.
C
r8ary ( 1, 1 ) = UT_RIBM ( rivals ( irdrct ) )
r8ary ( 2, 1 ) = UT_RIBM ( rivals ( irsped ) )
DO ii = 1, 4
r8ary ( 1, ii+1 ) = UT_RIBM ( rivals (irsdwdir(ii)) )
r8ary ( 2, ii+1 ) = UT_RIBM ( rivals (irsdwspd(ii)) )
END DO
CALL UFBREP ( iubfmn, r8ary, 10, 5, ierufb,
+ 'WDIR WSPD' )
C
C* Pressure.
C
r8ary ( 1, 1 ) = PR_M100 ( rivals ( irpres ) )
DO ii = 1, 10
r8ary ( 1, ii+1 ) = PR_M100( rivals (irsprlc(ii)) )
END DO
CALL UFBREP ( iubfmn, r8ary, 10, 11, ierufb, 'PRLC' )
C
C* RPSEQ1
C
DO ii = 1, 4
r8ary ( 1, 2*ii-1 ) = UT_RIBM ( rivals (irfttsig(ii)) )
r8ary ( 1, 2*ii ) = UT_RIBM ( rivals (irsdtsig(ii)) )
END DO
CALL UFBREP ( iubfmn, r8ary, 10, 8, ierufb, 'TSIG' )
C
C* MDPT
C
DO ii = 1, 10
r8ary ( 1, ii ) = UT_RIBM ( rivals (irshamd(ii)) )
r8ary ( 2, ii ) = UT_RIBM ( rivals (irstmdbst(ii)) )
END DO
CALL UFBREP ( iubfmn, r8ary, MXMN, 10, ierufb,
+ 'HAMD TMDBST' )
C*
RETURN
END