SUBROUTINE MF_DCOD ( cldt, bufrtn, wgosid, nhours, iret ) C************************************************************************ C* MF_DCOD * C* * C* This routine decodes bulletins containing WMO-migrated marine * C* subsurface BUFR data into NCEP BUFR format. * C* * C* MF_DCOD ( CLDT, BUFRTN, NHOURS, IRET ) * C* * C* Input parameters: * C* CLDT CHAR* Date-time from command line * C* BUFRTN CHAR* NCEP BUFR tables file * C* WGOSID CHAR* WIGOS id KWNB 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/14 * C* J. Ator/NCEP 07/16 Handle all migrated TESAC and TRACKOB * C* J. Ator/NCEP 08/17 Split NC031007 replications into their * C* own separate reports * C* M. Weiss/IMSG 11/19 Decode and store WIGOS IDs when present * C* M. Weiss/IMSG 11/19 WIGOS id testing for USA * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'mfcmn.cmn' C* CHARACTER*(*) cldt, bufrtn, wgosid C* C* Maximum number of descriptors within Section 3 of a C* marine subsurface BUFR message. C* PARAMETER ( MXDSC = 250 ) C* 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 *********************** CHARACTER bull*(DCMXBF), cbull*(DCMXBF), bfstyp*8, + seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8, + rundt*12, sysdt*12, subtyp*8, logmsg*200, + cdesc(MXDSC)*6, tagpr*10, opmm*20, opms*32, + smid*9, stnnam*32, cslno*8, icmdc*20, softv*12, + cwmop*9, wgoslid*16, wgos(MXWGID)*17, + bufrdn*(DCMXLN), bufrbn*(DCMXLN), + cwmop_wigos*7 C* INTEGER irundt ( 5 ), irptdt ( 5 ), + ibull ( DCMXBF / 4 ) C* LOGICAL bullok, msgok, rptok, got157, gotwigos C* REAL*8 GETBMISS, GETVALNB, rqfp, rggp, r8v, r8slno, + r8trkob ( MXMN, MXLV ) C* EQUIVALENCE ( cbull (1:4), ibull (1) ), ( r8slno, cslno ) C* INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 C C* Get the BUFR tables directory from the tables file. 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 ( bufrtn, bufrdn, bufrbn, ierpth ) C C* Open the tables file for the NCEP BUFR (i.e. output) stream. C CALL FL_SOPN ( bufrtn, iubftn, ierspn ) IF ( ierspn .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ierspn, bufrtn, ierwlg ) RETURN END IF 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 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/dcmssf', + FORM = 'UNFORMATTED' ) CALL OPENBF ( iubfma, 'SEC3', iubftn ) C CALL MTINFO ( bufrdn, 98, 99 ) C C* Open the messages file for the NCEP BUFR (i.e. output) stream. C CALL FL_GLUN ( iubfmn, iergln ) IF ( iergln .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg ) RETURN END IF C C* Connect the tables and messages files for the C* NCEP BUFR (i.e. output) stream. C CALL OPENBF ( iubfmn, 'NUL', iubftn ) r8bfms = GETBMISS() 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 ) CALL PKVS01 ( 'MTV', 20 ) C C* Close the tables file for the NCEP BUFR (i.e. output) stream. C CALL FL_CLOS ( iubftn, iercls ) IF ( iercls .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg ) END IF 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 ) CALL CLOSBF ( iubfmn ) 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 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 CALL UT_WBFR ( iubfmn, 'mssf', 1, ierwbf ) END IF ELSE istart = ibptr + ipt1 - 1 ibptr = istart + 4 cbull = bull ( istart : lenb ) C C* Ensure the message contains marine subsurface data. C* Also check for a garbled or corrupt message. C msgok = .false. msglen = IUPBS01( ibull, 'LENM' ) IF ( ( msglen .gt. lenb ) .or. + ( cbull ( msglen-3 : msglen ) .ne. '7777' ) ) THEN logmsg = 'ERROR: corrupt BUFR message' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) ELSE IF ( IUPBS01( ibull, 'MTYP' ) .ne. 31 ) THEN logmsg = 'message does not contain ' // + 'marine subsurface data' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) ELSE msgok = .true. END IF C IF ( msgok ) THEN C C* Determine the message type. C CALL UPDS3 ( ibull, MXDSC, cdesc, ndesc ) ii = 1 subtyp = '????????' DO WHILE ( ( ii .le. ndesc ) .and. + ( subtyp(1:1) .eq. '?' ) ) IF ( cdesc(ii) .eq. '315003' ) THEN subtyp = 'NC031005' ELSE IF ( ( cdesc(ii) .eq. '315004' ) .or. + ( cdesc(ii) .eq. '315007' ) ) THEN subtyp = 'NC031006' IF ( cdesc(ii) .eq. '315007' ) THEN got157 = .true. ELSE got157 = .false. END IF ELSE IF ( cdesc(ii) .eq. '308010' ) THEN subtyp = 'NC031007' ELSE ii = ii + 1 END IF END DO IF ( subtyp(1:1) .eq. '?' ) THEN IF ( ( ndesc .eq. 25 ) .and. + ( cdesc( 4) .eq. '002036' ) .and. + ( cdesc(15) .eq. '109000' ) .and. + ( cdesc(20) .eq. '022045' ) .and. + ( cdesc(23) .eq. '022064' ) ) THEN subtyp = 'NC031005' ELSE IF ( ( ndesc .eq. 16 ) .and. + ( cdesc( 1) .eq. '001011' ) .and. + ( cdesc( 2) .eq. '113000' ) .and. + ( cdesc( 8) .eq. '022049' ) .and. + ( cdesc(15) .eq. '002042' ) ) THEN subtyp = 'NC031007' END IF END IF IF ( subtyp(1:1) .eq. '?' ) THEN msgok = .false. 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 IF ( msgok ) THEN C C* Open the BUFR message for reading. C CALL READERME ( ibull, iubfma, bfstyp, ibfdt, ierrme ) IF ( ierrme .ne. 0 ) THEN msgok = .false. ELSE nmsg = nmsg + 1 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 ( subtyp .eq. 'NC031007' ) THEN C C* Get the ship identifier. C CALL READLC ( iubfma, smid, 'SMID' ) C C* Get the along-track data. C CALL GETTAGPR ( iubfma, 'SST0', 1, tagpr, iertg ) CALL UFBSEQ ( iubfma, r8trkob, MXMN, MXLV, ntrklv, + tagpr ) IF ( ntrklv .gt. 0 ) THEN jjtrk = 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 ( subtyp .eq. 'NC031007' ) THEN rptyr = UT_BMRI ( r8trkob (1,jjtrk) ) rptmo = UT_BMRI ( r8trkob (2,jjtrk) ) rptdy = UT_BMRI ( r8trkob (3,jjtrk) ) rpthr = UT_BMRI ( r8trkob (4,jjtrk) ) rptmi = UT_BMRI ( r8trkob (5,jjtrk) ) 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 IF ( subtyp .eq. 'NC031007' ) THEN C C* Store the along-track data. C DO ii = 1, 16 r8in ( ii, 1 ) = r8trkob ( ii, jjtrk ) END DO CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'ALGTRKSQ' ) ELSE C C* Get and store the platform identifier. C CALL UT_BFRI ( iubfma, 'WMOP', rval, ier ) CALL UT_RIBF ( iubfmn, 'WMOP', rval, ier ) IF ( ERMISS ( rval ) ) THEN cwmop = 'MISSING ' ELSE WRITE ( cwmop,'(I9.9)' ) INT ( rval ) cwmop_wigos = cwmop(3:9) END IF C C* Get and store the WIGOS identifier. C* Also, write the station ID to the decoder log. 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 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-1901369 C* WGOSIDS = 0 WGOSISID = 20000 WGOSISNM = 0 WGOSLID = 1901369 C IF ( ( cwmop_wigos .ge. '1900000' ) .and. + ( cwmop_wigos .le. '8000000' ) ) THEN kk=0 CALL DC_BSRC ( cwmop_wigos, wgos (:)(11:17), + 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) C r8wk (1,1) = rwgosids ! WGOSIDS r8wk (2,1) = rwgosisid ! WGOSISID r8wk (3,1) = rwgosisnm ! WGOSISNM r8wk (4,1) = 0 ! WGOSLID (Character) CALL UFBSEQ ( iubfmn, r8wk, MXMN, 1, nlv, + 'WIGOSID' ) wgoslid = cwmop_wigos // ' ' END IF ELSE gotwigos = .false. END IF END IF C************ END WIGOS TEST INPUT #3 ********************** C C* Get and store the date and time. C CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'YYMMDD' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'YYMMDD' ) CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'HHMM' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'HHMM' ) C C* Get and store the latitude and longitude. C CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'LTLONH' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'LTLONH' ) C C* Dissolved oxygen profile data. C CALL MF_DOXY ( iubfma, iubfmn, subtyp ) END IF C IF ( subtyp .eq. 'NC031005' ) THEN C C* Float profile level data. C CALL GETTAGPR ( iubfma, 'WPRES', 1, tagpr, iertg ) CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + tagpr ) IF ( nlv .gt. 0 ) THEN CALL DRFINI ( iubfmn, nlv, 1, '(GLPFDATA)' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, nlv, nlv2, + 'GLPFDATA' ) END IF C rqfp = GETVALNB ( iubfma, 'CLATH', 1, 'QFQF', 1 ) CALL SETVALNB ( iubfmn, 'CLATH', 1, 'QFQF', 1, + rqfp, ier ) rggp = GETVALNB ( iubfma, 'CLATH', 1, 'GGQF', 1 ) CALL SETVALNB ( iubfmn, 'CLATH', 1, 'GGQF', 1, + rggp, ier ) CALL READLC ( iubfma, opmm, 'OPMM' ) CALL READLC ( iubfma, opms, 'OPMS' ) CALL UT_BFRI ( iubfma, 'BUYTS', rval, ier ) CALL UT_RIBF ( iubfmn, 'BUYTS', rval, ier ) CALL UT_BFRI ( iubfma, 'DCLS', rval, ier ) CALL UT_RIBF ( iubfmn, 'DCLS', rval, ier ) CALL UT_BFRI ( iubfma, 'BUYT', rval, ier ) CALL UT_RIBF ( iubfmn, 'BUYT', rval, ier ) CALL UT_BFRI ( iubfma, 'FCYN', rval, ier ) CALL UT_RIBF ( iubfmn, 'FCYN', rval, ier ) CALL UT_BFRI ( iubfma, 'DIPR', rval, ier ) CALL UT_RIBF ( iubfmn, 'DIPR', rval, ier ) CALL UT_BFRI ( iubfma, 'IWTEMP', rval, ier ) CALL UT_RIBF ( iubfmn, 'IWTEMP', rval, ier ) C ELSE IF ( subtyp .eq. 'NC031006' ) THEN C C* Get the platform identifier. C CALL READLC ( iubfma, smid, 'SMID' ) C C* Get and store the wind data. C IF ( got157 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'WINDDAT3' ) ELSE DO ii = 1, 14 r8in(ii,1) = r8bfms END DO CALL UFBREP ( iubfma, r8wk, MXMN, MXLV, nlv, + 'HSALG HSAWS' ) r8in(1,1) = r8wk(1,1) r8in(2,1) = r8wk(2,1) CALL UT_BFRI ( iubfma, 'TIWM', rval, ier ) r8in(3,1) = UT_RIBM ( rval ) CALL UT_BFRI ( iubfma, 'WDIR', rval, ier ) r8in(6,1) = UT_RIBM ( rval ) CALL UT_BFRI ( iubfma, 'WSPD', rval, ier ) r8in(7,1) = UT_RIBM ( rval ) END IF CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'WINDDAT3' ) C C* Get and store the temperature and humidity data. C IF ( got157 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'TEHUDAT2' ) ELSE DO ii = 1, 7 r8in(ii,1) = r8bfms END DO r8in(1,1) = r8wk(1,2) r8in(2,1) = r8wk(2,2) CALL UT_BFRI ( iubfma, 'TMDB', rval, ier ) r8in(3,1) = UT_RIBM ( rval ) CALL UT_BFRI ( iubfma, 'TMDP', rval, ier ) r8in(6,1) = UT_RIBM ( rval ) END IF CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'TEHUDAT2' ) C C* Temperature/salinity profile. C CALL MF_TMPF ( iubfma, iubfmn, got157 ) C C* Get and store the surface current. C IF ( got157 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'SFCCURNT' ) ELSE DO ii = 1, 5 r8in(ii,1) = r8bfms END DO CALL UT_BFRI ( iubfma, 'DTCC', rval, ier ) r8in(1,1) = UT_RIBM ( rval ) CALL UT_BFRI ( iubfma, 'MCMS', rval, ier ) IF ( INT ( rval ) .lt. 7 ) + r8in(2,1) = UT_RIBM ( rval ) CALL UT_BFRI ( iubfma, 'DSSC', rval, ier ) r8in(4,1) = UT_RIBM ( rval ) CALL UT_BFRI ( iubfma, 'SSSC', rval, ier ) r8in(5,1) = UT_RIBM ( rval ) END IF CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'SFCCURNT' ) C C* Get and store the wave data. C CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'DPHGTWAV' ) IF ( nlv .gt. 0 ) + CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'DPHGTWAV' ) C C* Get and store the sea-surface temperature. C CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'SEATEMPH' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'SEATEMPH' ) C CALL READLC ( iubfma, stnnam, 'LSTN' ) CALL UT_BFRI ( iubfma, 'IDPF', rval, ier ) CALL UT_RIBF ( iubfmn, 'IDPF', rval, ier ) CALL UT_BFRI ( iubfma, 'DOMO', rval, ier ) CALL UT_RIBF ( iubfmn, 'DOMO', rval, ier ) CALL UT_BFRI ( iubfma, 'SMMO', rval, ier ) CALL UT_RIBF ( iubfmn, 'SMMO', rval, ier ) CALL UT_BFRI ( iubfma, 'IMON', rval, ier ) CALL UT_RIBF ( iubfmn, 'IMON', rval, ier ) CALL UT_BFRI ( iubfma, 'AOOP', rval, ier ) CALL UT_RIBF ( iubfmn, 'AOOP', rval, ier ) CALL UFBINT ( iubfma, r8slno, 1, 1, nlv, 'SLNO' ) IF ( IBFMS ( r8slno ) .eq. 0 ) + CALL UT_CIBF ( iubfmn, 'SLNO', cslno, 4, ier ) CALL UT_BFRI ( iubfma, 'STNO', rval, ier ) CALL UT_RIBF ( iubfmn, 'STNO', rval, ier ) r8v = GETVALNB ( iubfma, 'WTEMPR', 1, + 'IWTEMP', -1 ) CALL SETVALNB ( iubfmn, 'WTEMPR', 1, + 'IWTEMP', -1, r8v, ier ) CALL UT_BFRI ( iubfma, 'WTEMPR', rval, ier ) CALL UT_RIBF ( iubfmn, 'WTEMPR', rval, ier ) CALL UT_BFRI ( iubfma, 'TOWD', rval, ier ) CALL UT_RIBF ( iubfmn, 'TOWD', rval, ier ) C IF ( got157 ) THEN CALL READLC ( iubfma, icmdc, 'ICMDC' ) CALL UT_BFRI ( iubfma, 'OSQN', rval, ier ) CALL UT_RIBF ( iubfmn, 'OSQN', rval, ier ) CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, + 'SFCSLNTY' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, + 'SFCSLNTY' ) CALL MF_CRPF ( iubfma, iubfmn ) ELSE CALL READLC ( iubfma, softv, 'SOFTV' ) CALL UT_BFRI ( iubfma, 'XXLT', rval, ier ) CALL UT_RIBF ( iubfmn, 'XXLT', rval, ier ) CALL UT_BFRI ( iubfma, 'HXXL', rval, ier ) CALL UT_RIBF ( iubfmn, 'HXXL', rval, ier ) r8v = GETVALNB ( iubfma, 'DYEAR', 1, + 'DATSIG', -1 ) CALL SETVALNB ( iubfmn, 'DYEAR', 1, + 'DATSIG', -1, r8v, ier ) CALL UT_BFRI ( iubfma, 'DYEAR', rval, ier ) CALL UT_RIBF ( iubfmn, 'DYEAR', rval, ier ) CALL UT_BFRI ( iubfma, 'DMNTH', rval, ier ) CALL UT_RIBF ( iubfmn, 'DMNTH', rval, ier ) CALL UT_BFRI ( iubfma, 'DDAYS', rval, ier ) CALL UT_RIBF ( iubfmn, 'DDAYS', rval, ier ) END IF END IF C C* Store the 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* Store the 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* Store the 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* Write the BUFR output to the BUFR output stream. C CALL UT_WBFR ( iubfmn, 'mssf', 0, ierwbf ) C C* Write each long string value to the BUFR output C* stream, unless it consists of all blank spaces, C* and in which case just let it default to "missing". C IF ( gotwigos ) + CALL WRITLC ( iubfmn, wgoslid, 'WGOSLID' ) C IF ( subtyp .eq. 'NC031005' ) THEN CALL ST_LDSP ( opmm, opmm, nchr, ierlds ) IF ( nchr .ne. 0 ) + CALL WRITLC ( iubfmn, opmm, 'OPMM' ) CALL ST_LDSP ( opms, opms, nchr, ierlds ) IF ( nchr .ne. 0 ) + CALL WRITLC ( iubfmn, opms, 'OPMS' ) logmsg = subtyp // ': station ID = ' // cwmop ELSE CALL ST_LDSP ( smid, smid, nchr, ierlds ) IF ( nchr .ne. 0 ) + CALL WRITLC ( iubfmn, smid, 'SMID' ) IF ( subtyp .eq. 'NC031006' ) THEN CALL WRITLC ( iubfmn, stnnam, 'LSTN' ) IF ( got157 ) THEN CALL ST_LDSP ( icmdc, icmdc, nchr, ierlds ) IF ( nchr .ne. 0 ) + CALL WRITLC ( iubfmn, icmdc, 'ICMDC' ) ELSE CALL ST_LDSP ( softv, softv, nchr, ierlds ) IF ( nchr .ne. 0 ) + CALL WRITLC ( iubfmn, softv, 'SOFTV' ) END IF END IF logmsg = subtyp // ': station ID = ' // smid END IF CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) END IF IF ( ( subtyp .eq. 'NC031007' ) .and. + ( jjtrk .lt. ntrklv ) ) THEN C C* Store the next replication as a separate report. C jjtrk = jjtrk + 1 GO TO 100 END IF END IF END DO END IF END DO END DO C* RETURN END