SUBROUTINE UA_BUFR ( iunbfo, irundt, irptdt,
+ seqnum, buhd, cborg, bulldt, bbb,
+ report, lenr, iret )
C************************************************************************
C* UA_BUFR *
C* *
C* This subroutine retrieves interface-stored data, converts it into *
C* BUFR output, and then writes the BUFR output to the BUFR output *
C* stream. *
C* *
C* UA_BUFR ( IUNBFO, IRUNDT, IRPTDT, *
C* SEQNUM, BUHD, CBORG, BULLDT, BBB, *
C* REPORT, LENR, IRET ) *
C* *
C* Input parameters: *
C* IUNBFO INTEGER BUFR output file unit number *
C* IRUNDT (5) INTEGER Run date-time *
C* (YYYY, MM, DD, HH, MM ) *
C* IRPTDT (5) INTEGER Report 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* REPORT CHAR* Report *
C* LENR INTEGER Length of REPORT *
C* *
C* Output parameters: *
C* IRET INTEGER Return code: *
C* 0 = normal return *
C** *
C* Log: *
C* J. Ator/NCEP 03/96 *
C* J. Ator/NCEP 05/96 Create different roab BUFR subtypes *
C* J. Ator/NCEP 06/96 Remove several diagnostic messages *
C* J. Ator/NCEP 07/96 Use irundt as receipt date-time, *
C* use DCMXBF instead of MXSTRL *
C* J. Ator/NCEP 07/96 IF_C2R8 -> UT_C2R8 *
C* J. Ator/NCEP 08/96 Add UAPART and RCTS to BUFR output *
C* J. Ator/NCEP 10/96 Add CORN to BUFR output *
C* J. Ator/NCEP 10/96 Add leading "0" to RPID for Blocks 01-09*
C* J. Ator/NCEP 11/96 Don't let TEMP reports be PIBAL subtype,*
C* set UAPART=TTAA for TTBB reports which *
C* have only TEMP BB mandatory level data *
C* J. Ator/NCEP 11/96 Store no more than MXBFLV levels of any *
C* descriptor, use GPGRAV instead of GRAVTY*
C* J. Ator/NCEP 12/97 New interface format, style changes *
C* J. Ator/NCEP 03/98 Add calls to UT_CIBF and UT_RIBF, *
C* remove calls to UA_BFOT *
C* J. Ator/NCEP 04/98 Fix bug in storing of UAPART *
C* J. Ator/NCEP 12/98 Move init. of mbstr, lmbstr into code *
C* J. Ator/NCEP 08/99 Set CORN=2 for BBB="SDM" *
C* J. Ator/NCEP 10/99 Change /INTF mnemonics for cloud data, *
C* clean up function declarations *
C* J. Ator/NCEP 03/00 Allow decoding of UA_SNDG data *
C* J. Ator/NCEP 01/01 Store profiler (A4ME=7) as 'NC002007' *
C* J. Ator/NCEP 02/01 Store profiler (A4ME=7) as 'NC002009', *
C* use GP07 instead of HEIT for profiler *
C* J. Ator/NCEP 05/01 Add VSIG to BUFR output for 'NC002009' *
C* J. Ator/NCEP 06/01 Use UT_WBFR and BUFR.CMN, clean up *
C* J. Ator/NCEP 01/02 Add TIWM to BUFR output, HOCB -> HBLCS, *
C* use simplified UT_CIBF *
C* J. Ator/NCEP 02/02 Clean UT_C2R8 calls, check for blank BBB*
C* J. Ator/NCEP 01/04 Prevent UFBINT call for MINU or nclt=0 *
C* J. Ator/NCEP 02/08 Add 100 to certain RATP values *
C* J. Ator/NCEP 07/08 Apply RATP "+100" adjustment for station*
C* table values as well as report values *
C* J. Ator/NCEP 09/11 Add check for lenr > MXBFRR *
C* J. Ator/NCEP 06/12 Update types for RATP "+100" adjustment *
C* J. Ator/NCEP 09/13 Update types for RATP "+100" adjustment *
C* J. Ator/NCEP 01/20 Update types for RATP "+100" adjustment,*
C* add REL, SPG and DLM WND to 'NC002004' *
C* J. Ator/NCEP 04/20 Remove REL, SPG and DLW WND processing *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BUFR.CMN'
INCLUDE 'uacmn.cmn'
INCLUDE 'uacmn_bufr.cmn'
C*
INTEGER irundt (*), irptdt (*)
C*
CHARACTER*(*) report, seqnum, buhd, cborg, bulldt, bbb
C*
CHARACTER cdata*(MXBFRR), bfstyp*8
C*
REAL*8 UT_RIBM
C*
REAL*8 r8cld ( NCCLD, 3 ),
+ r8ary ( MXBFLV ),
+ r8rlv ( NCRLV, MXBFLV ),
+ r8plv ( NCPLV, MXBFLV )
C*
LOGICAL otbmlv
C*
INCLUDE 'ERMISS.FNC'
C------------------------------------------------------------------------
iret = 0
otbmlv = .false.
C
C* Set the raob BUFR message subtype.
C
ia4me = INT ( rivals ( ira4me ) )
IF ( ( ia4me .eq. 1 ) .or. ( ia4me .eq. 7 ) ) THEN
IF ( cftyp .eq. PILOT ) THEN
IF ( ia4me .eq. 1 ) THEN
bfstyp = 'NC002005'
ELSE IF ( ( prttyp .eq. 'BB' ) .or.
+ ( prttyp .eq. 'DD' ) ) THEN
bfstyp = 'NC002009'
ELSE
RETURN
END IF
ELSE
WRITE ( UNIT = logmsg, FMT = '( A, I1, A )' )
+ 'A4ME = ', ia4me, ' within temp report'
CALL DC_WLOG ( 4, 'UA', 1, logmsg, ierwlg )
RETURN
END IF
ELSE IF ( stntyp .eq. LAND ) THEN
bfstyp = 'NC002001'
ELSE IF ( stntyp .eq. MOBIL ) THEN
bfstyp = 'NC002002'
ELSE IF ( stntyp .eq. SHIP ) THEN
bfstyp = 'NC002003'
ELSE IF ( stntyp .eq. DROP ) THEN
bfstyp = 'NC002004'
END IF
C
C* Set the raob BUFR message date-time.
C
ibfdt = ( irptdt (1) * 1000000 ) + ( irptdt (2) * 10000 ) +
+ ( irptdt (3) * 100 ) + irptdt (4)
C
C* Open a raob BUFR message for output.
C
CALL OPENMB ( iunbfo, bfstyp, ibfdt )
C
C* Bulletin ID information.
C
CALL UT_CIBF ( iunbfo, 'SEQNUM', seqnum, 8, iercbf)
CALL UT_CIBF ( iunbfo, 'BUHD', buhd, 8, iercbf)
CALL UT_CIBF ( iunbfo, 'BORG', cborg, 8, iercbf)
CALL UT_CIBF ( iunbfo, 'BULTIM', bulldt, 8, iercbf)
CALL UT_CIBF ( iunbfo, 'BBB', bbb, 8, iercbf)
C
C* Raw report.
C
IF ( lenr .gt. MXBFRR ) THEN
WRITE ( UNIT = logmsg, FMT = '( I4, A )' )
+ MXBFRR, ' bytes of raw report in BUFR'
CALL DC_WLOG ( 4, 'UA', 5, logmsg, ierwlg )
lenr = MXBFRR
END IF
CALL UT_CIBF ( iunbfo, 'RRSTG', report, lenr, iercbf )
C
C* Report date-time.
C
CALL UT_RIBF ( iunbfo, 'YEAR', FLOAT ( irptdt (1) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'MNTH', FLOAT ( irptdt (2) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'DAYS', FLOAT ( irptdt (3) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'HOUR', FLOAT ( irptdt (4) ), ierrbf )
C
C* Latitude.
C
CALL UT_RIBF ( iunbfo, 'CLAT', rivals ( irslat ), ierrbf )
C
C* Longitude.
C
CALL UT_RIBF ( iunbfo, 'CLON', rivals ( irslon ), ierrbf )
C
C* Elevation.
C
CALL UT_RIBF ( iunbfo, 'SELV', rivals ( irselv ), ierrbf )
C
C* Elevation quality flag.
C
CALL UT_RIBF ( iunbfo, 'QCEVR', rivals ( irqcvr ), ierrbf )
C
C* Station identifier.
C
IF ( stntyp .eq. LAND ) THEN
stnm = rivals ( irstnm )
IF ( .not. ERMISS ( stnm ) ) THEN
istnm = INT ( stnm )
wmob = FLOAT ( istnm / 1000 )
CALL UT_RIBF ( iunbfo, 'WMOB', wmob, ierrbf )
wmos = FLOAT ( MOD ( istnm, 1000 ) )
CALL UT_RIBF ( iunbfo, 'WMOS', wmos, ierrbf )
WRITE ( UNIT = cdata (1:5), FMT = '(I5.5)' ) istnm
CALL UT_CIBF ( iunbfo, 'RPID', cdata, 5, iercbf )
END IF
ELSE
CALL UT_CIBF ( iunbfo, 'RSML', civals ( icstid ), 8, iercbf)
CALL UT_CIBF ( iunbfo, 'RPID', civals ( icstid ), 8, iercbf)
END IF
C
C* Region number.
C
CALL UT_RIBF ( iunbfo, 'WMOR', rivals ( irwmor ), ierrbf )
C
C* Multi-level data.
C
nlev = INT ( rivals ( irnlev ) )
C
IF ( nlev .gt. 0 ) THEN
C
IF ( nlev .gt. MXBFLV ) THEN
WRITE ( UNIT = logmsg, FMT = '( I4, A )' )
+ MXBFLV, ' levels of multi-level data in BUFR'
CALL DC_WLOG ( 4, 'UA', 5, logmsg, ierwlg )
nlev = MXBFLV
END IF
C
IF ( bfstyp .eq. 'NC002009' ) THEN
C
C* Multi-level data for profiler.
C
DO jj = 1, nlev
C
C* Initialize this level of the BUFR output array.
C
DO ii = 1, NCPLV
r8plv ( ii, jj ) = r8bfms
END DO
C
C* Vertical sounding significance.
C
r8plv ( LPVSIG, jj ) =
+ UT_RIBM ( rivals ( irvsig ( jj ) ) )
C
C* Height.
C
hgtm = rivals ( irhgtm ( jj ) )
IF ( .not. ERMISS ( hgtm ) ) THEN
r8plv ( LPGP07, jj ) = hgtm * GPGRAV
END IF
C
C* Wind direction.
C
r8plv ( LPWDIR, jj ) =
+ UT_RIBM ( rivals ( irdrct ( jj ) ) )
C
C* Wind speed.
C
r8plv ( LPWSPD, jj ) =
+ UT_RIBM ( rivals ( irsped ( jj ) ) )
END DO
C
CALL UFBINT ( iunbfo, r8plv, NCPLV, nlev, ierufb,
+ CPLVST )
ELSE
C
C* Multi-level data for non-profiler.
C
DO jj = 1, nlev
C
C* Initialize this level of the BUFR output array.
C
DO ii = 1, NCRLV
r8rlv ( ii, jj ) = r8bfms
END DO
C
C* Vertical sounding significance.
C
r8rlv ( LLVSIG, jj ) =
+ UT_RIBM ( rivals ( irvsig ( jj ) ) )
C
C* Pressure.
C
r8rlv ( LLPRLC, jj ) =
+ UT_RIBM ( PR_M100 ( rivals ( irpres ( jj ) ) ) )
C
C* Height.
C
hgtm = rivals ( irhgtm ( jj ) )
IF ( .not. ERMISS ( hgtm ) ) THEN
IF ( ERMISS ( rivals ( irpres ( jj ) ) ) ) THEN
llgp = LLGP07
ELSE
llgp = LLGP10
END IF
r8rlv ( llgp, jj ) = hgtm * GPGRAV
END IF
C
C* Temperature.
C
r8rlv ( LLTMDB, jj ) =
+ UT_RIBM ( PR_TMCK ( rivals ( irtmpc ( jj ) ) ) )
C
C* Dewpoint temperature.
C
r8rlv ( LLTMDP, jj ) =
+ UT_RIBM ( PR_TMCK ( rivals ( irdwpc ( jj ) ) ) )
C
C* Wind direction.
C
r8rlv ( LLWDIR, jj ) =
+ UT_RIBM ( rivals ( irdrct ( jj ) ) )
C
C* Wind speed.
C
r8rlv ( LLWSPD, jj ) =
+ UT_RIBM ( rivals ( irsped ( jj ) ) )
C
C* Wind shear data.
C
r8rlv ( LLAWSB, jj ) =
+ UT_RIBM ( rivals ( irawsb ( jj ) ) )
r8rlv ( LLAWSA, jj ) =
+ UT_RIBM ( rivals ( irawsa ( jj ) ) )
END DO
C
C* If this is a TEMP BB report whose only multi-level data
C* was TEMP BB mandatory level data, then set the logical
C* flag "otbmlv" to .true.
C
IF ( ( cftyp .eq. TEMP ) .and.
+ ( prttyp .eq. BB ) ) THEN
jj = 1
otbmlv = .true.
DO WHILE ( ( jj .le. nlev ) .and. ( otbmlv ) )
ivsig = INT ( rivals ( irvsig ( jj ) ) )
IF ( ivsig .ne. 32 ) THEN
otbmlv = .false.
ELSE
jj = jj + 1
END IF
END DO
END IF
C
CALL UFBINT ( iunbfo, r8rlv, NCRLV, nlev, ierufb,
+ CRLVST )
END IF
C
END IF
C
C* Instrument type.
C
C* The value from the report is used if it exists; otherwise, the
C* value from the station table is used. Per WMO regulations,
C* certain values must be incremented by 100 for reports dated
C* after 6/30/2007.
C
IF ( .not. ERMISS ( rivals ( iritpr ) ) ) THEN
itpr = INT ( rivals ( iritpr ) )
ELSE
itpr = INT ( rivals ( iritpd ) )
END IF
IF ( ( ( ibfdt .ge. 2008010100 ) .and.
+ ( itpr .ge. 10 ) .and. ( itpr .le. 11 ) )
+ .or.
+ ( ( ibfdt .ge. 2015050600 ) .and. ( itpr .eq. 12 ) )
+ .or.
+ ( ( ibfdt .ge. 2010091500 ) .and. ( itpr .eq. 13 ) )
+ .or.
+ ( ( ibfdt .ge. 2011110300 ) .and. ( itpr .eq. 14 ) )
+ .or.
+ ( ( ibfdt .ge. 2011120100 ) .and.
+ ( itpr .ge. 15 ) .and. ( itpr .le. 16 ) )
+ .or.
+ ( ( ibfdt .ge. 2012050200 ) .and. ( itpr .eq. 17 ) )
+ .or.
+ ( ( ibfdt .ge. 2019051500 ) .and. ( itpr .eq. 19 ) )
+ .or.
+ ( ( ibfdt .ge. 2015050600 ) .and. ( itpr .eq. 21 ) )
+ .or.
+ ( ( ibfdt .ge. 2012050200 ) .and. ( itpr .eq. 22 ) )
+ .or.
+ ( ( ibfdt .ge. 2011110300 ) .and.
+ ( itpr .ge. 23 ) .and. ( itpr .le. 25 ) )
+ .or.
+ ( ( ibfdt .ge. 2014050700 ) .and. ( itpr .eq. 26 ) )
+ .or.
+ ( ( ibfdt .ge. 2011091500 ) .and.
+ ( itpr .ge. 28 ) .and. ( itpr .le. 29 ) )
+ .or.
+ ( ( ibfdt .ge. 2010010100 ) .and. ( itpr .eq. 30 ) )
+ .or.
+ ( ( ibfdt .ge. 2011110300 ) .and.
+ ( itpr .ge. 31 ) .and. ( itpr .le. 33 ) )
+ .or.
+ ( ( ibfdt .ge. 2020050600 ) .and. ( itpr .eq. 34 ) )
+ .or.
+ ( ( ibfdt .ge. 2014050700 ) .and. ( itpr .eq. 35 ) )
+ .or.
+ ( ( ibfdt .ge. 2018050200 ) .and. ( itpr .eq. 36 ) )
+ .or.
+ ( ( ibfdt .ge. 2011110300 ) .and.
+ ( itpr .ge. 41 ) .and. ( itpr .le. 42 ) )
+ .or.
+ ( ( ibfdt .ge. 2014050700 ) .and.
+ ( itpr .ge. 43 ) .and. ( itpr .le. 46 ) )
+ .or.
+ ( ( ibfdt .ge. 2012050200 ) .and. ( itpr .eq. 48 ) )
+ .or.
+ ( ( ibfdt .ge. 2016110200 ) .and. ( itpr .eq. 50 ) )
+ .or.
+ ( ( ibfdt .ge. 2011110300 ) .and. ( itpr .eq. 52 ) )
+ .or.
+ ( ( ibfdt .ge. 2015050600 ) .and. ( itpr .eq. 53 ) )
+ .or.
+ ( ( ibfdt .ge. 2019051500 ) .and. ( itpr .eq. 54 ) )
+ .or.
+ ( ( ibfdt .ge. 2015050600 ) .and. ( itpr .eq. 60 ) )
+ .or.
+ ( ( ibfdt .ge. 2015050600 ) .and. ( itpr .eq. 62 ) )
+ .or.
+ ( ( ibfdt .ge. 2018110700 ) .and.
+ ( itpr .ge. 63 ) .and. ( itpr .le. 64 ) )
+ .or.
+ ( ( ibfdt .ge. 2016110200 ) .and. ( itpr .eq. 73 ) )
+ .or.
+ ( ( ibfdt .ge. 2010031500 ) .and. ( itpr .eq. 77 ) )
+ .or.
+ ( ( ibfdt .ge. 2012110700 ) .and.
+ ( itpr .ge. 82 ) .and. ( itpr .le. 83 ) )
+ .or.
+ ( ( ibfdt .ge. 2019110600 ) .and. ( itpr .eq. 84 ) ) )
+ THEN
itpr = itpr + 100
END IF
CALL UT_RIBF ( iunbfo, 'RATP', FLOAT ( itpr ), ierrbf )
C
C* Type of measuring equipment used.
C
a4me = rivals ( ira4me )
IF ( .not. ERMISS ( a4me ) ) THEN
IF ( INT ( a4me ) .eq. 4 ) THEN
bfa4me = 14.0
ELSE IF ( ( INT ( a4me ) .ge. 5 ) .and.
+ ( INT ( a4me ) .le. 8 ) ) THEN
bfa4me = FLOAT ( ( INT ( a4me ) ) - 1 )
ELSE
bfa4me = a4me
END IF
CALL UT_RIBF ( iunbfo, 'A4ME', bfa4me, ierrbf )
END IF
C
C* Corrected report indicator.
C
corn = 0.0
IF ( bbb (1:1) .eq. 'C' ) THEN
corn = 1.0
ELSE IF ( bbb (1:3) .eq. 'SDM' ) THEN
corn = 2.0
ELSE
ii = 1
DO WHILE ( ( INT ( corn ) .eq. 0 ) .and.
+ ( ii .le. INT ( rivals ( irnrdc ) ) ) )
irdc = INT ( rivals ( irurdc ( ii ) ) )
IF ( ( irdc .ge. 80 ) .and. ( irdc .le. 82 ) ) THEN
corn = 1.0
ELSE
ii = ii + 1
END IF
END DO
END IF
CALL UT_RIBF ( iunbfo, 'CORN', corn, ierrbf )
C
C* Raob part name.
C
IF ( otbmlv ) THEN
cdata (1:4) = 'TTAA'
ELSE
cdata (1:4) = civals ( icpart ) (1:4)
END IF
CALL UT_CIBF ( iunbfo, 'UAPART', cdata, 4, iercbf)
C
C* Type of instrumentation for wind measurement
C
CALL UT_RIBF ( iunbfo, 'TIWM', rivals ( irtiwm ), ierrbf )
C
C* Receipt date-time.
C
CALL UT_RIBF ( iunbfo, 'RCYR', FLOAT ( irundt (1) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'RCMO', FLOAT ( irundt (2) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'RCDY', FLOAT ( irundt (3) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'RCHR', FLOAT ( irundt (4) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'RCMI', FLOAT ( irundt (5) ), ierrbf )
IF ( otbmlv ) THEN
ircts = 4
ELSE
IF ( cftyp .eq. TEMP ) THEN
ircts = 4
ELSE
ircts = 8
END IF
IF ( prttyp .eq. BB ) THEN
ircts = ircts + 1
ELSE IF ( prttyp .eq. CC ) THEN
ircts = ircts + 2
ELSE IF ( prttyp .eq. DD ) THEN
ircts = ircts + 3
END IF
END IF
CALL UT_RIBF ( iunbfo, 'RCTS', FLOAT ( ircts ), ierrbf )
C
C* Report diagnostic codes.
C
nrdc = INT ( rivals ( irnrdc ) )
IF ( nrdc .gt. 0 ) THEN
DO ii = 1, nrdc
r8ary (ii) = rivals ( irurdc (ii) )
END DO
CALL UFBINT ( iunbfo, r8ary, 1, nrdc, ierufb, 'UARDC' )
END IF
C
C* Mean layer wind data.
C
CALL UT_RIBF ( iunbfo, 'MWDL', rivals ( irmwdl ), ierrbf )
CALL UT_RIBF ( iunbfo, 'MWSL', rivals ( irmwsl ), ierrbf )
CALL UT_RIBF ( iunbfo, 'MWDH', rivals ( irmwdh ), ierrbf )
CALL UT_RIBF ( iunbfo, 'MWSH', rivals ( irmwsh ), ierrbf )
C
C* Stability index.
C
CALL UT_RIBF ( iunbfo, 'STBS5', rivals ( irstb5 ), ierrbf )
C
C* Extrapolated mandatory level.
C
CALL UT_RIBF ( iunbfo, 'XMPRLC',
+ PR_M100 ( rivals ( irxprs ) ), ierrbf )
C
xmhgtm = rivals ( irxhtm )
IF ( .not. ERMISS ( xmhgtm ) ) THEN
xmgp10 = xmhgtm * GPGRAV
CALL UT_RIBF ( iunbfo, 'XMGP10', xmgp10, ierrbf )
END IF
C
IF ( cftyp .eq. TEMP ) THEN
C
C* Solar and infrared radiation correction.
C
CALL UT_RIBF ( iunbfo, 'SIRC', rivals ( irsirc ), ierrbf )
C
C* Tracking technique/status of system used.
C
CALL UT_RIBF ( iunbfo, 'TTSS', rivals ( irttss ), ierrbf )
C
C* Launch hour and launch minute.
C
CALL UT_RIBF ( iunbfo, 'UALNHR', rivals ( irlnhr ), ierrbf )
CALL UT_RIBF ( iunbfo, 'UALNMN', rivals ( irlnmn ), ierrbf )
C
IF ( stntyp .eq. SHIP ) THEN
C
C* Sea-surface temperature.
C
CALL UT_RIBF ( iunbfo, 'SST1',
+ PR_TMCK ( rivals ( irsstc ) ), ierrbf )
END IF
C
IF ( stntyp .ne. DROP ) THEN
C
C* Cloud data.
C
nclt = INT ( rivals ( irnclt ) )
IF ( nclt .gt. 0 ) THEN
DO jj = 1, 3
DO ii = 1, NCCLD
r8cld ( ii, jj ) = r8bfms
END DO
END DO
r8cld ( LCCLAM, 1 ) = UT_RIBM ( rivals ( irclam ) )
r8cld ( LCHBLC, 1 ) = UT_RIBM ( rivals ( irhblc ) )
DO ii = 1, nclt
r8cld ( LCCLTP, ii ) = rivals ( ircltp ( ii ) )
END DO
CALL UFBINT ( iunbfo, r8cld, NCCLD, nclt, ierufb,
+ CCLDST )
END IF
END IF
END IF
C
CALL UT_WBFR ( iunbfo, 'raob', 0, ierwbf )
C*
RETURN
END