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************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'sycmn.cmn' C* PARAMETER ( MXBLSZ = 5000000 ) C* CHARACTER*(*) cldt, r40fil, bufrt000, bufrt001, wgosid C* C* Maximum number of WMO Resolution 40 bulletin headers. C* PARAMETER ( MXR40B = 800 ) C*********** START WIGOS TEST INPUT #1 ********************* C* C* Maximum number of "test" WMO WIGOS ids. C* PARAMETER ( MXWGID = 1600 ) C*********** END WIGOS TEST INPUT #1 *********************** C* C* Maximum number of descriptors within Section 3 of a C* WMO synoptic BUFR message. C* PARAMETER ( MXDSC = 80 ) C* PARAMETER ( MXCTBLV = 80 ) C* PARAMETER ( NBUFRO = 2 ) C* CHARACTER bull*(MXBLSZ), cbull*(MXBLSZ), bfstyp*8, + seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8, + rundt*12, sysdt*12, logmsg*200, + 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) C* INTEGER irundt ( 5 ), irptdt ( 5 ), + ibull ( MXBLSZ / 4 ), ibufro ( NBUFRO ) C* LOGICAL bullok, msgok, rptok, gotctbto, gotwigos C* REAL*8 r8ctb1 ( 7 ), r8ctb2 ( 21, MXCTBLV ), + GETBMISS, GETVALNB C* EQUIVALENCE ( cbull (1:4), ibull (1) ) C* INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 C r8bfms = GETBMISS() C bufrtf(1) = bufrt000 bufrtf(2) = bufrt001 C 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. C CALL FL_PATH ( bufrtf(1), bufrdn, bufrbn, ierpth ) C*********** START WIGOS TEST INPUT #2 ********************* C* Open, read, and close the file C* "decod_dcsynp_Canada_USA.wigosId" C* containing sample WIGOS ids valid October 17, 2019. C 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 ) THEN nwgos = nwgos + 1 END IF END DO C************ END WIGOS TEST INPUT #2 ********************** C C* Open, read, and close the file of WMO Res40 bulletin headers. C 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 ) THEN nr40b = nr40b + 1 END IF END DO C C* Open the BUFR messages file. C 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 ) C DO ii = 1, NBUFRO C C* Open the BUFR tables file. C 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 C* Open the BUFR output file. C CALL FL_GLUN ( ibufro (ii), iergln ) IF ( iergln .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg ) RETURN END IF C C* Connect the BUFR tables file to the BUFR output file. C CALL OPENBF ( ibufro (ii), 'NUL', iubftn ) C C* Close the BUFR tables file. C CALL FL_CLOS ( iubftn, iercls ) IF ( iercls .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg ) END IF END DO C C* Specify that NCEP BUFR (i.e. output) messages are to be C* encoded using edition 4 and up to 100K bytes in size. C CALL PKVS01 ( 'BEN', 4 ) CALL MAXOUT ( 100000 ) 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 ) CALL CLOSBF ( iubfma ) DO ii = 1, NBUFRO CALL CLOSBF ( ibufro (ii) ) END DO 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 C 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 C IF ( bullok ) THEN C C* If a date-time was entered on the command line, then use it C* as the run date-time. Otherwise, use the system time as C* 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 C 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. ELSE nmsg = 0 END IF END IF C C* Check if this is a WMO Resolution 40 bulletin. C ires40 = 0 cbb = buhd (1:6) // ' ' // cborg (1:4) CALL DC_BSRC ( cbb, cr40b, nr40b, ipos, ierbrc ) IF ( ipos .ne. 0 ) THEN ires40 = 1 END IF C DO WHILE ( bullok ) C C* Locate the next BUFR message within the bulletin, and C* store it within an equivalenced integer array. C ipt1 = INDEX ( bull (ibptr:lenb), 'BUFR' ) IF ( ipt1 .eq. 0 ) THEN bullok = .false. 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 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. C DO ii = 1, NBUFRO CALL UT_WBFR ( ibufro (ii), 'synp', 1, ierwbf ) END DO END IF ELSE istart = ibptr + ipt1 - 1 ibptr = istart + 4 cbull = bull ( istart : lenb ) C nmsg = nmsg + 1 msgok = .false. C C* Check for a corrupt BUFR message. C msglen = IUPBS01 ( ibull, 'LENM' ) CALL GETLENS ( ibull, 3, ls0, ls1, ls2, ls3, ls4, ls5 ) IF ( ( msglen .gt. lenb ) .or. + ( cbull ( msglen-3 : msglen ) .ne. '7777' ) .or. + ( ls3 .gt. ( ( MXDSC * 2 ) + 7 ) ) ) THEN logmsg = 'ERROR: corrupt BUFR message' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) ELSE gots96 = .false. gots91 = .false. gotctbto = .false. C C* Retrieve the Section 3 descriptors from the message to C* ensure it contains WMO synoptic data. C CALL UPDS3 ( ibull, MXDSC, cdesc, ndesc ) 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. '301090' ) THEN msgok = .true. subtyp = 'NC000101' ELSE IF ( ( cdesc(ii) .eq. '302035' ) .or. + ( cdesc(ii) .eq. '302043' ) ) THEN msgok = .true. msbti = IUPBS01 ( ibull, 'MSBTI' ) 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 ( msgok ) THEN C C* If this is a WMO Resolution 40 bulletin, relabel the C* report subtype as NC000100. C IF ( ires40 .eq. 1 ) subtyp = 'NC000100' C C* If this is a CMAN bulletin, relabel the report subtype C* as NC001104. C 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 C* Open the BUFR message for reading. C CALL READERME ( ibull, iubfma, bfstyp, ibfdt, ierrme ) IF ( ierrme .ne. 0 ) THEN msgok = .false. END IF ELSE 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 END IF END IF C DO WHILE ( msgok ) C C* Get the next report from this BUFR message. C IF ( IREADSB ( iubfma ) .ne. 0 ) THEN C C* There are no more reports in this message. C msgok = .false. rptok = .false. ELSE rptok = .true. 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 ) IF ( nctblv .gt. 0 ) THEN jjctb = 1 ELSE rptok = .false. END IF END IF END IF C IF ( rptok ) THEN C C* Don't create BUFR output for reports that are more C* than NHOURS before or more than 3 hours after the C* run time. C 100 IF ( gotctbto ) THEN rptyr = UT_BMRI ( r8ctb2 (1,jjctb) ) rptmo = UT_BMRI ( r8ctb2 (2,jjctb) ) rptdy = UT_BMRI ( r8ctb2 (3,jjctb) ) rpthr = UT_BMRI ( r8ctb2 (4,jjctb) ) rptmi = UT_BMRI ( r8ctb2 (5,jjctb) ) ELSE CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'YYMMDD' ) rptyr = UT_BMRI ( r8in (1,1) ) rptmo = UT_BMRI ( r8in (2,1) ) rptdy = UT_BMRI ( r8in (3,1) ) CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'HHMM' ) rpthr = UT_BMRI ( r8in (1,1) ) rptmi = UT_BMRI ( r8in (2,1) ) END IF IF ( ( ERMISS ( rptyr ) ) .or. + ( ERMISS ( rptmo ) ) .or. + ( ERMISS ( rptdy ) ) .or. + ( ERMISS ( rpthr ) ) .or. + ( ERMISS ( rptmi ) ) ) THEN iertmk = -1 ELSE irptdt (1) = INT ( rptyr ) irptdt (2) = INT ( rptmo ) irptdt (3) = INT ( rptdy ) irptdt (4) = INT ( rpthr ) irptdt (5) = INT ( rptmi ) CALL DC_TMCK ( 2, irundt, irptdt, nhours, 180, + iertmk ) END IF C IF ( iertmk .eq. 0 ) THEN C C* Open a BUFR message for output. C ibfdt = ( irptdt (1) * 1000000 ) + + ( irptdt (2) * 10000 ) + + ( irptdt (3) * 100 ) + irptdt (4) CALL OPENMB ( iubfmn, subtyp, ibfdt ) C C* Get and store the report identifying information. C* Also, write the station ID to the decoder log. C IF ( subtyp .ne. 'NC000102' ) THEN CALL READLC ( iubfma, stsn, 'STSN' ) 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, C* since some incoming reports may not specify C* the full sequence. The use of UFBREP (instead C* of UFBINT) ensures that any unpacked metadata C* values are the actual metadata values following C* the site ID, rather than, e.g. any modified C* reference values preceding 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 rpid = stsn(1:lrpid) END IF END IF CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'SFIDTIME' ) ELSE C* Explicitly unpack all elements of MOBIDENT, C* since some incoming reports may not specify C* the full sequence. The use of UFBREP (instead C* of UFBINT) ensures that any unpacked metadata C* values are the actual metadata values following C* 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 C* Get and store the WIGOS identifier. C 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' ) ELSE C*********** START WIGOS TEST INPUT #3 ********************* C* Temporarily manufacture WIGOS ids for some Canada and USA C* sites to begin populating the downstream database, and until C* these sites begin generating WIGOS ids own their own. C* C* ex. WIGOS indentifier: 0-20000-0-72403 C* WGOSIDS = 0 WGOSISID = 20000 WGOSISNM = 0 WGOSLID = 72403 C IF ( ( lrpid .eq. 5 ) .and. + ( ( rpid(1:2) .ge. '70' ) .and. + ( rpid(1:2) .le. '95' ) ) ) THEN CALL DC_BSRC ( rpid (1:5), wgos (:)(11:15), + nwgos, kk, ierbrc ) IF ( kk .ne. 0 ) THEN gotwigos = .true. ! MATCH 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) C IF (rwgoslid .EQ. 71701.) THEN !Canada site IF ( index(stsn,'AWOS') .gt. 0) THEN rwgosisid = 20000. ELSE rwgosisid = 20001. END IF END IF IF (rwgoslid .EQ. 72262.) THEN !USA site IF ( index(stsn,'GUADELUPE') .gt. 0) THEN rwgosisid = 20000. ELSE rwgosisid = 20001. END IF END IF r8wk (1,1) = rwgosids ! WGOSIDS r8wk (2,1) = rwgosisid ! WGOSISID r8wk (3,1) = rwgosisnm ! WGOSISNM r8wk (4,1) = rwgoslid ! WGOSLID CALL UFBSEQ ( iubfmn, r8wk, MXMN, 1, nlv, + 'WIGOSID' ) wgoslid = rpid(1:5) // ' ' END IF ELSE gotwigos = .false. END IF END IF C************ END WIGOS TEST INPUT #3 ********************** C C* Get and store the pressure data. C 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' ) C C* Get and store the temperature and humidity data. C 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 CALL UFBSEQ ( iubfma, r8wk, MXMN, MXLV, nlv, + 'TEHUDATA' ) 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 C* Get and store the wind data. C 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 C IF ( .not. gotctbto ) THEN C C* Get and store the visibility data. C 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 C* Get and store the extreme temperature data. C CALL SY_EXTM ( iubfma, iubfmn ) C C* Get and store the cloud data. C CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'GENCLOUD' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'GENCLOUD' ) C C* Get and store the supplemental cloud data. C CALL SY_SCLD ( iubfma, iubfmn, rptok ) C C* Get and store the precipitation data. C CALL SY_PRCP ( iubfma, iubfmn ) C C* Get and store the present and past weather data. C CALL SY_PRWX ( iubfma, iubfmn ) C C* Get and store the state of ground, snow depth and C* ground minimum temperature data. C CALL SY_SGDS ( iubfma, iubfmn ) END IF C IF ( subtyp .eq. 'NC001104' ) THEN C C* Get and store the basic wave data. C 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 C* Get and store the spectral wave data. C 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 C* Get and store the water temperature data. C 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 C* Get and store the icing/ice data. C 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 C* Bulletin header. C 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 C* Receipt time. C 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 C* Correction indicator. C 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 C* Restrictions on redistribution. C IF ( ires40 .eq. 1 ) THEN CALL UT_RIBF ( iubfmn, 'RSRD', 224., ier ) END IF C IF ( rptok ) THEN C C* Write the BUFR output to the BUFR output stream. C 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 CALL WRITLC ( iubfmn, stsn(1:20), 'STSN' ) IF ( subtyp .eq. 'NC001104' ) + CALL WRITLC ( iubfmn, sbpi, 'SBPI' ) END IF END IF END IF IF ( ( gotctbto ) .and. ( jjctb .lt. nctblv ) ) THEN jjctb = jjctb + 1 GO TO 100 END IF END IF END DO END IF END DO END DO C* RETURN END