SUBROUTINE SY_DCOD ( cldt, r40fil, bufrt000, bufrt001, + wgosid, nhours, iret ) C************************************************************************ C* SY_DCOD * C* * C* This routine decodes bulletins containing WMO-migrated synoptic * C* BUFR messages into NCEP BUFR format. * C* * C* SY_DCOD ( CLDT, R40FIL, BUFRT000, BUFRT001, NHOURS, IRET ) * C* * C* Input parameters: * C* CLDT CHAR* Date-time from command line * C* R40FIL CHAR* File of WMO Res40 bulletin hdrs * C* BUFRT000 CHAR* BUFR tables file for type 000 * C* BUFRT001 CHAR* BUFR tables file for type 001 * C* WGOSID CHAR* WIGOS id CWAO test file * C* NHOURS INTEGER Max # of hours before run time * C* for creating NCEP BUFR output * C* * C* Output parameters: * C* IRET INTEGER Return code: * C* 0 = normal return * C* * C** * C* Log: * C* J. Ator/NCEP 01/13 * C* J. Ator/NCEP 12/14 Use r40fil call argument to generate new* C* NC000100 subtype, store RPID in output * C* J. Ator/NCEP 04/15 Process 3-07-091 messages * C* J. Ator/NCEP 02/16 Added processing of messages w/SFIDTIME * C* J. Ator/NCEP 10/16 Handle CTBTO monitoring messages, * C* improve check for corrupt messages * C* J. Ator/NCEP 08/17 Added processing of messages w/SYNOPINS * C* or SYNOPPRD but no 3-07-xxx sequence, * C* decode and store WIGOS IDs when present * C* M. Weiss/IMSG 10/19 WIGOS id testing for Canada and USA * C* J. Ator/NCEP 11/19 Route CMAN rpts to new b001/xx104 tanks * C* J. Ator/NCEP 06/23 Use new decod_ut library routines, * C* clean up and simplify logic * C* J. Ator/NCEP 06/23 Process 3-07-092 messages * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'sycmn.cmn' PARAMETER ( MXBLSZ = 5000000 ) CHARACTER*(*) cldt, r40fil, bufrt000, bufrt001, wgosid C* Maximum number of WMO Resolution 40 bulletin headers. PARAMETER ( MXR40B = 800 ) C*********** START WIGOS TEST INPUT #1 ********************* C* Maximum number of "test" WMO WIGOS ids. PARAMETER ( MXWGID = 1600 ) C*********** END WIGOS TEST INPUT #1 *********************** C* Maximum number of descriptors within Section 3 of a C* WMO synoptic BUFR message. PARAMETER ( MXDSC = 80 ) PARAMETER ( MXCTBLV = 80 ) PARAMETER ( NBUFRO = 2 ) CHARACTER bull*(MXBLSZ), cbull*(MXBLSZ), bfstyp*8, + seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8, + logmsg*200, lstn*40, + cdesc( MXDSC )*6, smid*9, stsn*35, rpid*8, + wkstg*80, wkstg2*8, cr40b(MXR40B)*11, cbb*11, + tagpr*10, wgoslid*16, wgos(MXWGID)*15, sbpi*8, + bufrdn*(DCMXLN), bufrbn*(DCMXLN), + bufrtf(NBUFRO)*(DCMXLN) INTEGER irundt ( 5 ), irptdt ( 5 ), + ibull ( MXBLSZ / 4 ), ibufro ( NBUFRO ) LOGICAL bullok, msgok, rptok, gotctbto, gotwigos REAL*8 r8ctb1 ( 7 ), r8ctb2 ( 21, MXCTBLV ), + GETBMISS, GETVALNB EQUIVALENCE ( cbull (1:4), ibull (1) ) INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 r8bfms = GETBMISS() C bufrtf(1) = bufrt000 bufrtf(2) = bufrt001 C* Get the BUFR tables directory from the tables files. 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 ( bufrtf(1), bufrdn, bufrbn, ierpth ) C*********** START WIGOS TEST INPUT #2 ********************* C* Open, read, and close the "test" WIGOS ids file. CALL FL_TBOP ( wgosid, 'wigo', irwigo, iertop ) IF ( iertop .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iertop, wgosid, ierr ) RETURN END IF iostat = 0 nwgos = 0 DO WHILE ( ( nwgos .lt. MXWGID ) .and. ( iostat .eq. 0 ) ) READ ( irwigo, FMT = '(A)', IOSTAT = iostat ) + wgos ( nwgos + 1 ) IF ( iostat .eq. 0 ) nwgos = nwgos + 1 END DO C************ END WIGOS TEST INPUT #2 ********************** C* Open, read, and close the file of WMO Res40 bulletin headers. CALL FL_TBOP ( r40fil, 'rs40', ir40fl, iertop ) IF ( iertop .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iertop, r40fil, ierr ) RETURN END IF iostat = 0 nr40b = 0 DO WHILE ( ( nr40b .lt. MXR40B ) .and. ( iostat .eq. 0 ) ) READ ( ir40fl, FMT = '(A)', IOSTAT = iostat ) + cr40b ( nr40b + 1 ) IF ( iostat .eq. 0 ) nr40b = nr40b + 1 END DO 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/dcsynp', + FORM = 'UNFORMATTED' ) CALL OPENBF ( iubfma, 'SEC3', iubfma ) CALL MTINFO ( bufrdn, 98, 99 ) DO ii = 1, NBUFRO C* Open the BUFR tables file. CALL FL_SOPN ( bufrtf (ii), iubftn, ierspn ) IF ( ierspn .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ierspn, bufrtf (ii), ierwlg ) RETURN END IF C* Open the BUFR output file. CALL FL_GLUN ( ibufro (ii), 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 ( ibufro (ii), 'NUL', iubftn ) 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 END DO C* Specify that NCEP BUFR (i.e. output) messages are to be C* encoded using edition 4 and up to 100K bytes in size. CALL PKVS01 ( 'BEN', 4 ) CALL MAXOUT ( 100000 ) 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 ) DO ii = 1, NBUFRO CALL CLOSBF ( ibufro (ii) ) END DO 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* Check if this is a WMO Resolution 40 bulletin. ires40 = 0 cbb = buhd (1:6) // ' ' // cborg (1:4) CALL DC_BSRC ( cbb, cr40b, nr40b, ipos, ierbrc ) IF ( ipos .ne. 0 ) ires40 = 1 C* Get the run date-time. CALL UT_GET_RUNDT ( cldt, irundt, iergrd ) IF ( iergrd .ne. 0 ) CYCLE nmsg = 0 bullok = .true. 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 IF ( nmsg .eq. 0 ) THEN IF ( INDEX ( bull (ibptr:lenb), 'NIL' ) .ne. 0 ) THEN logmsg = 'NIL bulletin' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) END IF ELSE 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. DO ii = 1, NBUFRO CALL UT_WBFR ( ibufro (ii), 'synp', 1, ierwbf ) END DO END IF bullok = .false. CYCLE END IF cbull = bull ( istart : ibptr ) nmsg = nmsg + 1 msgok = .false. gots96 = .false. gots91 = .false. gots92 = .false. gotctbto = .false. C* Review the Section 3 descriptors from the message to ensure C* it contains WMO synoptic data. ii = 1 DO WHILE ( ( ii .le. ndesc ) .and. ( .not. msgok ) ) IF ( cdesc(ii) .eq. '307090' ) THEN msgok = .true. subtyp = 'NC000102' ELSE IF ( ( LGE ( cdesc(ii), '307079' ) ) .and. + ( LLE ( cdesc(ii), '307086' ) ) ) THEN msgok = .true. subtyp = 'NC000101' ELSE IF ( cdesc(ii) .eq. '307096' ) THEN msgok = .true. gots96 = .true. subtyp = 'NC000101' ELSE IF ( cdesc(ii) .eq. '307091' ) THEN msgok = .true. gots91 = .true. subtyp = 'NC000101' ELSE IF ( cdesc(ii) .eq. '307092' ) THEN msgok = .true. gots92 = .true. subtyp = 'NC000101' ELSE IF ( cdesc(ii) .eq. '301090' ) THEN msgok = .true. subtyp = 'NC000101' ELSE IF ( ( cdesc(ii) .eq. '302035' ) .or. + ( cdesc(ii) .eq. '302043' ) ) THEN msgok = .true. IF ( ( msbti .ge. 3 ) .and. ( msbti .le. 5 ) ) THEN subtyp = 'NC000102' ELSE subtyp = 'NC000101' END IF ELSE ii = ii + 1 END IF END DO IF ( ( .not. msgok ) .and. ( ndesc .eq. 26 ) .and. + ( cdesc( 1) .eq. '301001' ) .and. + ( cdesc( 4) .eq. '301021' ) .and. + ( cdesc( 7) .eq. '118000' ) .and. + ( cdesc(10) .eq. '301012' ) .and. + ( cdesc(19) .eq. '013011' ) .and. + ( cdesc(24) .eq. '011001' ) ) THEN msgok = .true. gotctbto = .true. subtyp = 'NC000101' END IF 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* If this is a WMO Resolution 40 bulletin, relabel the report C* subtype as NC000100. IF ( ires40 .eq. 1 ) subtyp = 'NC000100' C* If this is a CMAN bulletin, relabel the report subtype C* as NC001104. IF ( ( buhd(1:3) .eq. 'ISA' ) .and. ( buhd(5:5) .eq. '2' ) + .and. ( cborg(1:4) .eq. 'KWNB' ) ) THEN subtyp = 'NC001104' iubfmn = ibufro (2) ELSE iubfmn = ibufro (1) 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. CYCLE END IF IF ( gotctbto ) THEN CALL UFBINT ( iubfma, r8ctb1, 7, 1, nlv, + 'WMOB WMOS TOST CLATH CLONH HSMSL HBMSL' ) CALL GETTAGPR ( iubfma, 'PRES', 1, tagpr, iertg ) CALL UFBSEQ ( iubfma, r8ctb2, 21, MXCTBLV, nctblv, + tagpr ) jjctb = 0 END IF rptok = .true. DO WHILE ( rptok ) C* Don't create BUFR output for reports that are more than C* NHOURS before or more than 3 hours after the run time. IF ( gotctbto ) THEN IF ( jjctb .lt. nctblv ) THEN jjctb = jjctb + 1 r8in(1,1) = r8ctb2(1,jjctb) r8in(2,1) = r8ctb2(2,jjctb) r8in(3,1) = r8ctb2(3,jjctb) r8in(4,1) = r8ctb2(4,jjctb) r8in(5,1) = r8ctb2(5,jjctb) ELSE rptok = .false. CYCLE END IF ELSE CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, 'YYMMDD') CALL UFBSEQ ( iubfma, r8wk, MXMN, MXLV, nlv, 'HHMM' ) r8in(4,1) = r8wk(1,1) r8in(5,1) = r8wk(2,1) END IF CALL UT_CHECK_BUFRRPTDT ( 2, irundt, r8in(1,1), + r8in(2,1), r8in(3,1), r8in(4,1), r8in(5,1), + nhours, 180, irptdt, iercrt ) IF ( iercrt .ne. 0 ) THEN IF ( .not. gotctbto ) rptok = .false. CYCLE END IF C* Open a BUFR message for output. ibfdt = ( irptdt (1) * 1000000 ) + + ( irptdt (2) * 10000 ) + + ( irptdt (3) * 100 ) + irptdt (4) CALL OPENMB ( iubfmn, subtyp, ibfdt ) C* Get and store the report identifying information. C* Also, write the station ID to the decoder log. IF ( subtyp .ne. 'NC000102' ) THEN IF ( gots92 ) THEN CALL READLC ( iubfma, lstn, 'LSTN' ) ELSE CALL READLC ( iubfma, stsn, 'STSN' ) END IF IF ( subtyp .eq. 'NC001104' ) + CALL READLC ( iubfma, sbpi, 'SBPI' ) IF ( gotctbto ) THEN wmob = UT_BMRI ( r8ctb1 (1) ) wmos = UT_BMRI ( r8ctb1 (2) ) r8in (1,1) = r8ctb1 (1) r8in (2,1) = r8ctb1 (2) r8in (3,1) = r8bfms r8in (4,1) = r8ctb1 (3) DO ii = 5, 9 r8in (ii,1) = r8ctb2 (ii-4,jjctb) END DO DO ii = 10, 13 r8in (ii,1) = r8ctb1 (ii-6) END DO ELSE C* Explicitly unpack all elements of SFIDTIME, since C* some incoming reports may not specify the full C* sequence. The use of UFBREP (instead of UFBINT) C* ensures that any unpacked metadata values are the C* actual metadata values following the site ID, rather C* than, e.g. any modified reference values preceding C* the site ID. CALL UFBREP ( iubfma, r8wk, MXMN, MXLV, nlv, + 'WMOB WMOS TOST YEAR MNTH DAYS HOUR ' // + 'MINU CLATH CLONH HSMSL HBMSL' ) r8in (1,1) = r8wk (1,1) r8in (2,1) = r8wk (2,1) wmob = UT_BMRI ( r8in (1,1) ) wmos = UT_BMRI ( r8in (2,1) ) DO ii = 3, 12 r8in (ii+1,1) = r8wk (ii,1) END DO END IF IF ( ( .not. ERMISS ( wmob ) ) .and. + ( .not. ERMISS ( wmos ) ) ) THEN lrpid = 5 WRITE ( rpid(1:lrpid), FMT = '(I2.2, I3.3)' ) + INT ( wmob ), INT ( wmos ) ELSE lrpid = 8 IF ( subtyp .eq. 'NC001104' ) THEN rpid = sbpi(1:lrpid) ELSE IF ( gots92 ) THEN rpid = lstn(1:lrpid) ELSE rpid = stsn(1:lrpid) END IF END IF CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'SFIDTIME' ) ELSE C* Explicitly unpack all elements of MOBIDENT, since some C* incoming reports may not specify the full sequence. C* The use of UFBREP (instead of UFBINT) ensures that any C* unpacked metadata values are the actual metadata values C* following the site ID, rather than, e.g. any modified C* reference values preceding the site ID. CALL UFBREP ( iubfma, r8wk, MXMN, MXLV, nlv, + 'WMOR TOST YEAR MNTH DAYS HOUR MINU ' // + 'CLATH CLONH HSMSL HBMSL QCEVR' ) DO ii = 1, 12 r8in (ii+1,1) = r8wk (ii,1) END DO CALL READLC ( iubfma, smid, 'SMID' ) lrpid = 8 rpid = smid(1:lrpid) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'MOBIDENT' ) END IF CALL UT_CIBF ( iubfmn, 'RPID', rpid, lrpid, iercbf ) logmsg = subtyp // ': station ID = ' // rpid(1:lrpid) CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) C* Get and store the WIGOS identifier. gotwigos = .false. CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'WGOSIDS WGOSISID WGOSISNM' ) IF ( ( IBFMS ( r8in (1,1) ) .eq. 0 ) .or. + ( IBFMS ( r8in (2,1) ) .eq. 0 ) .or. + ( IBFMS ( r8in (3,1) ) .eq. 0 ) ) THEN gotwigos = .true. CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'WIGOSID' ) CALL READLC ( iubfma, wgoslid, 'WGOSLID' ) C*********** START WIGOS TEST INPUT #3 ********************* ELSE IF ( ( lrpid .eq. 5 ) .and. + ( ( rpid(1:2) .ge. '70' ) .and. + ( rpid(1:2) .le. '95' ) ) ) THEN C* Temporarily manufacture WIGOS ids for some Canada and C* USA sites to begin populating the downstream database, C* and until these sites begin generating WIGOS ids on C* their own. C* C* ex. WIGOS indentifier: 0-20000-0-72403 C* WGOSIDS = 0 WGOSISID = 20000 WGOSISNM = 0 WGOSLID = 72403 CALL DC_BSRC ( rpid (1:5), wgos (:)(11:15), + nwgos, kk, ierbrc ) IF ( kk .ne. 0 ) THEN gotwigos = .true. CALL ST_CRNM (wgos(kk)(1:1), rwgosids, ier) CALL ST_CRNM (wgos(kk)(3:7), rwgosisid, ier) CALL ST_CRNM (wgos(kk)(9:9), rwgosisnm, ier) CALL ST_CRNM (wgos(kk)(11:15), rwgoslid, ier) IF (rwgoslid .eq. 71701.) THEN IF ( index(stsn,'AWOS') .gt. 0) THEN rwgosisid = 20000. ELSE rwgosisid = 20001. END IF END IF IF (rwgoslid .EQ. 72262.) THEN IF ( index(stsn,'GUADELUPE') .gt. 0) THEN rwgosisid = 20000. ELSE rwgosisid = 20001. END IF END IF r8wk (1,1) = rwgosids r8wk (2,1) = rwgosisid r8wk (3,1) = rwgosisnm r8wk (4,1) = rwgoslid CALL UFBSEQ ( iubfmn, r8wk, MXMN, 1, nlv, 'WIGOSID') wgoslid = rpid(1:5) // ' ' END IF C************ END WIGOS TEST INPUT #3 ********************** END IF C* Get and store the pressure data. IF ( gots92 ) THEN CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'HBMSL PRES PMSL' ) CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'HBMSL PRES PMSL' ) ELSE IF ( gots91 ) THEN CALL UFBSEQ ( iubfma, r8wk, MXMN, MXLV, nlv, + 'PRESSQ03' ) DO ii = 1, 4 r8in (ii,1) = r8wk (ii,1) END DO DO ii = 5, 7 r8in (ii,1) = r8bfms END DO ELSE IF ( gotctbto ) THEN r8in (1,1) = r8ctb2 (7,jjctb) DO ii = 2, 7 r8in (ii,1) = r8bfms END DO ELSE CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'PRESDATA' ) END IF CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'PRESDATA' ) END IF C* Get and store the temperature and humidity data. IF ( gots96 .or. gots91 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'TEMHUMDA' ) ELSE IF ( gotctbto ) THEN r8in (1,1) = r8ctb2 (8,jjctb) r8in (2,1) = r8bfms DO ii = 3, 5 r8in (ii,1) = r8ctb2 (ii+6,jjctb) END DO ELSE IF ( gots92 ) THEN CALL UFBINT ( iubfma, r8wk, MXMN, MXLV, nlv, + 'HSALG TMDB TMDP REHU' ) ELSE CALL UFBSEQ ( iubfma, r8wk, MXMN, MXLV, nlv, + 'TEHUDATA' ) END IF r8in (1,1) = r8wk (1,1) r8in (2,1) = r8bfms r8in (3,1) = r8wk (2,1) r8in (4,1) = r8wk (3,1) r8in (5,1) = r8wk (4,1) END IF CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'TEMHUMDA' ) C* Get and store the wind data. IF ( gotctbto ) THEN r8in (1,1) = r8ctb2 (15,jjctb) r8in (2,1) = r8bfms DO ii = 3, 8 r8in (ii,1) = r8ctb2 (ii+13,jjctb) END DO DO ii = 9, 11 r8in (ii,1) = r8bfms END DO CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'BSYWND1' ) ELSE CALL SY_WIND ( iubfma, iubfmn ) END IF IF ( .not. gotctbto ) THEN C* Get and store the visibility data. IF ( gots96 .or. gots91 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'VISBSEQN' ) ELSE CALL UFBSEQ ( iubfma, r8wk, MXMN, MXLV, nlv, + 'VISBDATA' ) r8in (1,1) = r8wk (1,1) r8in (2,1) = r8bfms r8in (3,1) = r8bfms r8in (4,1) = r8wk (2,1) END IF CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'VISBSEQN' ) C* Get and store the extreme temperature data. CALL SY_EXTM ( iubfma, iubfmn ) C* Get and store the cloud data. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'GENCLOUD' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'GENCLOUD' ) C* Get and store the supplemental cloud data. CALL SY_SCLD ( iubfma, iubfmn, rptok ) IF ( .not. rptok ) THEN IF ( gotctbto ) rptok = .true. CYCLE END IF C* Get and store the precipitation data. CALL SY_PRCP ( iubfma, iubfmn ) C* Get and store the present and past weather data. CALL SY_PRWX ( iubfma, iubfmn ) C* Get and store the state of ground, snow depth and C* ground minimum temperature data. CALL SY_SGDS ( iubfma, iubfmn ) END IF IF ( subtyp .eq. 'NC001104' ) THEN C* Get and store the basic wave data. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'BASICWAV' ) IF ( nlv .eq. 1 ) THEN CALL DRFINI ( iubfmn, 1, 1, '' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv2, + 'BASICWAV' ) END IF C* Get and store the spectral wave data. CALL GETTAGPR ( iubfma, 'WCFR', 1, tagpr, iertg ) IF ( iertg .eq. 0 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, tagpr ) IF ( nlv .gt. 0 ) THEN C* Only store levels where WCFR > 0. kk = 0 DO jj = 1, nlv IF ( ( IBFMS ( r8in (1,jj) ) .eq. 0 ) .and. + ( r8in (1,jj) ) .gt. 0 ) THEN kk = kk + 1 DO ii = 1, 6 r8wk (ii,kk) = r8in (ii,jj) END DO END IF END DO IF ( kk .gt. 0 ) THEN CALL DRFINI ( iubfmn, 1, 1, '' ) CALL DRFINI ( iubfmn, kk, 1, '{BBYSPWV}' ) CALL UFBSEQ ( iubfmn, r8wk, MXMN, kk, nlv2, + 'BBYSPWV' ) r8in(1,1) = GETVALNB ( iubfma, 'WCFR', 1, + 'DOWR', -1 ) CALL SETVALNB ( iubfmn, 'WCFR', 1, 'DOWR', + -1, r8in(1,1), ier ) r8in(1,1) = GETVALNB ( iubfma, 'WCFR', 1, + 'MXSWD', -1 ) CALL SETVALNB ( iubfmn, 'WCFR', 1, 'MXSWD', + -1, r8in(1,1), ier ) END IF END IF END IF C* Get and store the water temperature data. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'SEATEMPM' ) C* Only store this sequence if SST1 isn't missing. IF ( ( nlv .eq. 1 ) .and. + ( IBFMS ( r8in (3,1) ) .eq. 0 ) ) THEN CALL DRFINI ( iubfmn, 1, 1, '' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv2, + 'SEATEMPM' ) END IF C* Get and store the icing/ice data. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'ICINGICE' ) IF ( nlv .eq. 1 ) THEN CALL DRFINI ( iubfmn, 1, 1, '' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv2, + 'ICINGICE' ) END IF END IF C* Bulletin header. CALL UT_CIBF ( iubfmn, 'SEQNUM', seqnum, 8, ier ) CALL UT_CIBF ( iubfmn, 'BUHD', buhd, 8, ier ) CALL UT_CIBF ( iubfmn, 'BORG', cborg, 8, ier ) CALL UT_CIBF ( iubfmn, 'BULTIM', bulldt, 8, ier ) CALL UT_CIBF ( iubfmn, 'BBB', bbb, 8, ier ) C* Receipt time. CALL UT_RIBF ( iubfmn, 'RCTS', FLOAT (0), ier ) CALL UT_RIBF ( iubfmn, 'RCYR', FLOAT (irundt(1)), ier ) CALL UT_RIBF ( iubfmn, 'RCMO', FLOAT (irundt(2)), ier ) CALL UT_RIBF ( iubfmn, 'RCDY', FLOAT (irundt(3)), ier ) CALL UT_RIBF ( iubfmn, 'RCHR', FLOAT (irundt(4)), ier ) CALL UT_RIBF ( iubfmn, 'RCMI', FLOAT (irundt(5)), ier ) C* Correction indicator. IF ( ( IUPBS01 ( ibull, 'USN' ) .gt. 0 ) .or. + ( bbb(1:1) .eq. 'C' ) ) THEN icorn = 1 ELSE icorn = 0 END IF CALL UT_RIBF ( iubfmn, 'CORN', FLOAT (icorn), ier ) C* Restrictions on redistribution. IF ( ires40 .eq. 1 ) THEN CALL UT_RIBF ( iubfmn, 'RSRD', 224., ier ) END IF C* Write the BUFR output to the BUFR output stream. CALL UT_WBFR ( iubfmn, 'synp', 0, ierwbf ) IF ( gotwigos ) + CALL WRITLC ( iubfmn, wgoslid, 'WGOSLID' ) IF ( subtyp .eq. 'NC000102' ) THEN CALL WRITLC ( iubfmn, smid, 'SMID' ) ELSE IF ( gots92 ) THEN CALL WRITLC ( iubfmn, lstn(1:20), 'STSN' ) ELSE CALL WRITLC ( iubfmn, stsn(1:20), 'STSN' ) END IF IF ( subtyp .eq. 'NC001104' ) + CALL WRITLC ( iubfmn, sbpi, 'SBPI' ) END IF IF ( .not. gotctbto ) rptok = .false. END DO END DO END DO END DO RETURN END