SUBROUTINE BY_DCOD ( cldt, bufrtn, wgosid, nhours, iret ) C************************************************************************ C* BY_DCOD * C* * C* This routine decodes bulletins containing WMO-migrated buoy BUFR * C* messages into NCEP BUFR format. * C* * C* BY_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 USA test sites 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 03/15 * C* J. Ator/NCEP 02/16 Added processing for messages with BUYT * C* J. Ator/NCEP 05/16 Change logic for storing RPID * C* J. Ator/NCEP 07/16 Use WMOP and BPID in determination of * C* subtype, ensure first date-time is * C* observation date-time, add WMORS4 * C* J. Ator/NCEP 10/16 Check for missing PTIDC, check for more * C* BUYT values, check for POWV and HOWV * C* J. Ator/NCEP 06/19 Process REHU from saildrone data * C* M. Weiss/IMSG 12/19 Decode and store WIGOS IDs * C* M. Weiss/IMSG 12/19 WIGOS id testing of USA sites. * C* J. Ator/NCEP 06/20 Fork saildrone data to new b001/xx120 * C* tank, handle new 3-15-011 sequence, * C* process wind data not in DBUOYWND * C* J. Ator/NCEP 06/23 Use new decod_ut library routines, * C* clean up and simplify logic * C* J. Ator/NCEP 07/23 Process TAO recap subsurface data * C* M. Weiss/NCEP 10/23 Process SOFAR restricted data to new * C* b001/xx121 tank * C************************************************************************ USE bycmn INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' CHARACTER*(*) cldt, bufrtn, wgosid C* Maximum number of descriptors within Section 3 of a C* WMO BUOY BUFR message. PARAMETER ( MXDSC = 250 ) C*********** START WIGOS TEST INPUT #1 ********************* C* Maximum number of "test" WMO WIGOS ids. 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, + subtyp*8, logmsg*200, + ptidc*16, rpid*8, stnnam*32, tagpr*10, + cdesc( MXDSC )*6, cwmor, cwmors4, + bufrdn*(DCMXLN), bufrbn*(DCMXLN), wgoslid*16, + wgos(MXWGID)*17, opms*32, cidpf*32 INTEGER irundt ( 5 ), irptdt ( 5 ), + ibull ( DCMXBF / 4 ) LOGICAL bullok, msgok, got158, got159, got1511, + got1126, gotbts, gotwigos REAL*8 r8bfms, GETBMISS, UT_RIBM, GETVALNB, PKFTBV EQUIVALENCE ( cbull (1:4), ibull (1) ) INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 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. CALL FL_PATH ( bufrtn, bufrdn, bufrbn, ierpth ) C* Open the BUFR tables file. 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 "decod_dcbuoy_USA.wigosId" C* containing sample WIGOS ids valid November 14, 2019. 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* 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/dcbuoy', + FORM = 'UNFORMATTED' ) CALL OPENBF ( iubfma, 'SEC3', iubftn ) CALL MTINFO ( bufrdn, 98, 99 ) C* Open the BUFR output file. CALL FL_GLUN ( iubfmn, 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 ( iubfmn, 'NUL', iubftn ) r8bfms = GETBMISS() C* Specify that BUFR output messages are to be encoded using C* BUFR edition 4. CALL PKVS01 ( 'BEN', 4 ) 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 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 ) CALL CLOSBF ( iubfmn ) 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* 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. CALL UT_WBFR ( iubfmn, 'buoy', 1, ierwbf ) END IF bullok = .false. CYCLE END IF cbull = bull ( istart : ibptr ) nmsg = nmsg + 1 msgok = .false. got158 = .false. got159 = .false. got1511 = .false. got1126 = .false. gotbts = .false. C* Review the Section 3 descriptors from the message to ensure C* it contains WMO BUOY data. ii = 1 DO WHILE ( ( ii .le. ndesc ) .and. ( .not. msgok ) ) IF ( cdesc(ii) .eq. '315008' ) THEN got158 = .true. msgok = .true. ELSE IF ( cdesc(ii) .eq. '315009' ) THEN got159 = .true. msgok = .true. ELSE IF ( cdesc(ii) .eq. '315011' ) THEN got1511 = .true. msgok = .true. ELSE IF ( cdesc(ii) .eq. '301126' ) THEN got1126 = .true. msgok = .true. ELSE IF ( ( cdesc(ii) .eq. '002036' ) .or. + ( cdesc(ii) .eq. '002149' ) ) THEN gotbts = .true. msgok = .true. ELSE ii = ii + 1 END IF END DO 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* 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 C* Determine the BUFR output subtype. stnnam = ' ' IF ( ( got158 ) .or. ( got1126 ) ) THEN CALL READLC ( iubfma, stnnam(1:20), 'STSN' ) ELSE IF ( got159 ) THEN CALL READLC ( iubfma, stnnam, 'LSTN' ) ELSE IF ( got1511 ) THEN CALL READLC ( iubfma, stnnam(1:20), 'OPMM' ) END IF C* IF ( INDEX ( stnnam, 'aildrone' ) .gt. 0 ) THEN subtyp = 'NC001120' ELSE IF ( ( got158 ) .or. ( got1126 ) ) THEN subtyp = 'NC001103' ELSE IF ( got159 ) THEN C* The definitive identifier for SOFAR reports combines C* the LSTN sequence 'SPOT' and GTS header IORX04 IF ( ( stnnam(1:4) .eq. 'SPOT' ) .and. + ( buhd(1:6) .eq. 'IORX04' ) ) THEN subtyp = 'NC001121' ELSE subtyp = 'NC001102' END IF ELSE CALL UT_BFRI ( iubfma, 'BUYTS', buyts, ier ) ibuyts = INT ( buyts ) CALL UT_BFRI ( iubfma, 'BUYT', buyt, ier ) ibuyt = INT ( buyt ) CALL UT_BFRI ( iubfma, 'SFSTP', sfstp, ier ) isfstp = INT ( sfstp ) IF ( ( ibuyts .eq. 0 ) .or. ( isfstp .eq. 5 ) ) THEN subtyp = 'NC001102' ELSE IF ( ( ibuyts .eq. 1 ) .or. ( isfstp .eq. 4 )) THEN subtyp = 'NC001103' ELSE SELECT CASE ( ibuyt ) CASE ( 0:6, 8:15, 26:27, 29:30, 38:39 ) subtyp = 'NC001102' CASE ( 16:25, 28, 34:37 ) subtyp = 'NC001103' CASE DEFAULT CALL UT_BFRI ( iubfma, 'WMOP', byid, ier ) IF ( ERMISS ( byid ) ) + CALL UT_BFRI ( iubfma, 'BPID', byid, ier ) IF ( ERMISS ( byid ) ) THEN logmsg = 'report contains unknown buoy type' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) CYCLE END IF IF ( AMOD ( byid, 1000. ) .lt. 500 ) THEN subtyp = 'NC001103' ELSE subtyp = 'NC001102' END IF END SELECT END IF END IF C* Get the report date-time and, if available, the date-time C* of the last known position of the buoy. CALL UFBREP ( iubfma, r8in, MXMN, MXLV, nlv, + 'YEAR MNTH DAYS HOUR MINU' ) IF ( got159 ) THEN ! also includes NC001121 jj = 2 ELSE jj = 1 END IF C* Don't create BUFR output for reports that are more than C* NHOURS before or more than 3 hours after the run time. CALL UT_CHECK_BUFRRPTDT ( 2, irundt, r8in(1,jj), + r8in(2,jj), r8in(3,jj), r8in(4,jj), r8in(5,jj), + nhours, 180, irptdt, iercrt ) IF ( iercrt .ne. 0 ) CYCLE 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* Store the report date-time and, if available, the C* date-time of the last known position of the buoy. SELECT CASE ( subtyp ) CASE ( 'NC001102', 'NC001121' ) IF ( got159 ) THEN DO ii = 1, 5 r8wk (ii,1) = r8in (ii,2) r8wk (ii,2) = r8in (ii,1) END DO ELSE DO jj = 1, 2 DO ii = 1, 5 r8wk (ii,jj) = r8in (ii,jj) END DO END DO END IF CALL UFBREP ( iubfmn, r8wk, MXMN, 2, nlv, + 'YEAR MNTH DAYS HOUR MINU' ) CASE DEFAULT CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'YEAR MNTH DAYS HOUR MINU' ) END SELECT C* Time significances. tswd = GETVALNB ( iubfma, 'WDIR', 1, 'TSIG', -1 ) IF ( ( subtyp .eq. 'NC001102' ) .or. + ( subtyp .eq. 'NC001121' ) ) THEN r8wk (1,1) = 25. r8wk (1,2) = tswd r8wk (1,3) = 26. CALL UFBREP ( iubfmn, r8wk, MXMN, 3, nlv, 'TSIG' ) ELSE IF ( gotbts ) THEN r8wk (1,1) = tswd r8wk (1,2) = GETVALNB ( iubfma, 'MXGS', 1, 'TSIG', -1 ) CALL UFBREP ( iubfmn, r8wk, MXMN, 2, nlv, 'TSIG' ) END IF C* Identification information. CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'WMOP BPID BUYT WMOR WMORS4' ) IF ( IBFMS ( r8in (1,1) ) .eq. 0 ) THEN iwmop = IDNINT( r8in (1,1) ) IF ( iwmop .le. 9999999 ) THEN WRITE ( rpid, FMT='(I7.7,1X)' ) iwmop ELSE WRITE ( rpid, FMT='(I8.8)' ) iwmop END IF CALL UT_CIBF ( iubfmn, 'RPID', rpid, 8, iercbf ) ELSE IF ( IBFMS ( r8in (2,1) ) .eq. 0 ) THEN IF ( IBFMS ( r8in (4,1) ) .eq. 0 ) THEN iwmor = IDNINT( r8in (4,1) ) IF ( iwmor .eq. 0 ) iwmor = 7 WRITE ( cwmor, FMT='(I1)' ) iwmor ELSE cwmor = '7' END IF IF ( IBFMS ( r8in (5,1) ) .eq. 0 ) THEN WRITE ( cwmors4, FMT='(I1)' ) IDNINT( r8in (5,1) ) ELSE cwmors4 = 'x' END IF WRITE ( rpid, FMT='(2A1,I5.5,1X)') + cwmor, cwmors4, IDNINT( r8in (2,1) ) CALL UT_CIBF ( iubfmn, 'RPID', rpid, 8, iercbf ) ELSE rpid = 'MISSING ' END IF IF ( subtyp .eq. 'NC001120' ) THEN CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, 'WMOP' ) logmsg = subtyp // ': saildrone ID = ' // rpid ELSE CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'WMOP BPID BUYT WMOR WMORS4' ) logmsg = subtyp // ': buoy ID = ' // rpid END IF CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) C* Latitude and longitude. CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'CLATH CLONH' ) CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'CLATH CLONH' ) C* Depths, temperatures, and salinities. CALL BY_DBTS ( iubfma, iubfmn ) IF ( ( got158 ) .or. ( got1511 ) ) THEN C* Moored buoy observational data. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, 'MBUOYOB2') IF ( subtyp .ne. 'NC001102' ) THEN CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'MBUOYOB2' ) ELSE DO ii = 1, 6 r8wk (ii,1) = r8in (ii,1) END DO CALL UFBINT ( iubfmn, r8wk, MXMN, 1, nlv2, + 'PRES PMSL HSAWS TMDB TMDP REHU' ) r8wk (1,1) = r8bfms DO ii = 7, 11 r8wk ((ii-5),1) = r8in (ii,1) END DO CALL UFBSEQ ( iubfmn, r8wk, MXMN, 1, nlv2, 'DBUOYWND') END IF END IF IF ( got158 ) THEN C* Ancillary meteorologoical data. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, 'ANCMETOB') IF ( nlv .eq. 1 ) THEN CALL DRFINI ( iubfmn, 1, 1, '' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv2, 'ANCMETOB') END IF C* Radiation data. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, 'RADNSEQN') IF ( nlv .eq. 1 ) THEN CALL DRFINI ( iubfmn, 1, 1, '' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv2, 'RADNSEQN') END IF ELSE IF ( got159 ) THEN ! also includes NC001121 C* Sea-surface temperature/salinity data. CALL UT_BFRI ( iubfma, 'SSS0', sss0, ier ) r8wk (2,1) = GETVALNB ( iubfma, 'SSS0', 1, 'SST1', -1 ) IF ( ( .not. ERMISS ( sss0 ) ) .or. + ( IBFMS ( r8wk (2,1) ) .eq. 0 ) ) THEN r8wk (1,1) = GETVALNB( iubfma, 'SSS0', 1, 'PCAT', -1 ) r8wk (3,1) = GETVALNB( iubfma, 'SSS0', 1, 'MSDM', -1 ) r8wk (4,1) = UT_RIBM ( sss0 ) CALL DRFINI ( iubfmn, 1, 1, '' ) CALL UFBSEQ ( iubfmn, r8wk, MXMN, 1, nlv2, 'BBYSSTS' ) END IF C* Drifting buoy wind data. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, 'DBUOYWND') IF ( ( IBFMS ( r8in (5,1) ) .eq. 1 ) .and. + ( IBFMS ( r8in (6,1) ) .eq. 1 ) ) THEN C* Check whether WDIR and WSPD were added on at the tail C* end of the report, instead of being included within C* the DBUOYWND sequence. r8in (5,1) = GETVALNB ( iubfma, 'REHU', 1, 'WDIR', 1 ) r8in (6,1) = GETVALNB ( iubfma, 'REHU', 1, 'WSPD', 1 ) END IF IF ( ( subtyp .eq. 'NC001102' ) .or. + ( subtyp .eq. 'NC001121' ) ) THEN CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'DBUOYWND' ) ELSE r8wk (1,1) = r8in (5,1) r8wk (2,1) = r8in (6,1) CALL UFBINT ( iubfmn, r8wk, MXMN, 1, nlv, 'WDIR WSPD') END IF C* Surface type and ice thickness. CALL UFBINT( iubfma, r8in, MXMN, MXLV, nlv, 'RSST ITHK') CALL UFBINT( iubfmn, r8in, MXMN, 1, nlv, 'RSST ITHK' ) C* Pressure. CALL UFBINT( iubfma, r8in, MXMN, MXLV, nlv, 'PRES PMSL') CALL UFBINT( iubfmn, r8in, MXMN, 1, nlv, 'PRES PMSL' ) C* Temperature. r8wk (1,1) = GETVALNB ( iubfma, 'TMDB', 1, 'HSAWS', -1 ) CALL UFBINT ( iubfmn, r8wk, MXMN, 1, nlv, 'HSAWS' ) CALL UT_BFRI ( iubfma, 'TMDB', tmdb, ier ) CALL UT_RIBF ( iubfmn, 'TMDB', tmdb, ier ) C* Relative humidity. CALL UT_BFRI ( iubfma, 'REHU', rehu, ier ) CALL UT_RIBF ( iubfmn, 'REHU', rehu, ier ) ELSE IF ( got1511 ) THEN C* Surface current. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, 'SFCCURNT') IF ( nlv .eq. 1 ) THEN CALL DRFINI ( iubfmn, 1, 1, '' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv2, 'SFCCURNT') END IF C* Surface salinity. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, 'SFCSLNTY') IF ( nlv .eq. 1 ) THEN CALL DRFINI ( iubfmn, 1, 1, '' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv2, 'SFCSLNTY') END IF C* Skin temperature and instantaneous radiations. CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'HBMSL TMSK ILWRDP ISWRDP' ) CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'HBMSL TMSK ILWRDP ISWRDP' ) C* Other identifying information. CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'AOOP DOMO PLDS ACTH' ) CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'AOOP DOMO PLDS ACTH' ) CALL READLC ( iubfma, opms, 'OPMS' ) CALL READLC ( iubfma, cidpf, 'IDPF' ) ELSE C* Time periods. r8wk (1,1) = GETVALNB ( iubfma, 'WDIR', 1, 'TPMI', -1 ) IF ( subtyp .eq. 'NC001103' ) THEN r8wk (1,2) = GETVALNB( iubfma, 'MXGS', 1, 'TPMI', -1 ) ntpmi = 2 ELSE ntpmi = 1 END IF CALL UFBREP ( iubfmn, r8wk, MXMN, ntpmi, nlv, 'TPMI' ) C* Pressure, change and tendency. CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'PRES PMSL 3HPC CHPT' ) CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'PRES PMSL 3HPC CHPT' ) C* Temperature, humidity and wind data. r8wk (1,1) = GETVALNB ( iubfma, 'TMDB', 1, 'HSAWS', -1 ) r8wk (1,2) = GETVALNB ( iubfma, 'WDIR', 1, 'HSAWS', -1 ) CALL UFBREP ( iubfmn, r8wk, MXMN, 2, nlv, 'HSAWS' ) CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'TMDB TMDP REHU' ) CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'TMDB TMDP REHU' ) CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'ANTP WDIR WSPD' ) CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'ANTP WDIR WSPD' ) END IF C* Basic wave data. IF ( .not. gotbts ) THEN 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 ELSE CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'DOWR SGWH MXWH AVWP SPWP DDWC DSDW POWV HOWV' ) IF ( IBFMS ( r8in (4,1) ) .eq. 1 ) + r8in (4,1) = r8in (8,1) IF ( IBFMS ( r8in (2,1) ) .eq. 1 ) + r8in (2,1) = r8in (9,1) IF ( ( IBFMS ( r8in (1,1) ) .eq. 0 ) .or. + ( IBFMS ( r8in (2,1) ) .eq. 0 ) .or. + ( IBFMS ( r8in (3,1) ) .eq. 0 ) .or. + ( IBFMS ( r8in (4,1) ) .eq. 0 ) .or. + ( IBFMS ( r8in (5,1) ) .eq. 0 ) .or. + ( IBFMS ( r8in (6,1) ) .eq. 0 ) .or. + ( IBFMS ( r8in (7,1) ) .eq. 0 ) ) THEN CALL DRFINI ( iubfmn, 1, 1, '' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'BASICWAV' ) END IF END IF IF ( ( subtyp .eq. 'NC001102' ) .or. + ( subtyp .eq. 'NC001121' ) ) THEN C* Drogue, platform and location quality information. CALL READLC ( iubfma, ptidc, 'PTIDC' ) CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + 'DCLS DOMO PLDS QBST QCIL QCLS' // + ' BVOLH DROT LDDS DROD LDRS' ) CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv, + 'DCLS DOMO PLDS QBST QCIL QCLS' // + ' BVOLH DROT LDDS DROD LDRS' ) ELSE C* Spectral wave data. CALL GETTAGPR ( iubfma, 'WCFR', 1, tagpr, ierptg ) IF ( ierptg .eq. 0 ) THEN CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv, + '{' // tagpr // '}' ) IF ( nlv .gt. 0 ) THEN IF ( got158 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv2, + tagpr ) ELSE CALL UFBINT ( iubfma, r8in, MXMN, MXLV, nlv2, + 'WCFR NUL MDWC PDWC FNPF SNPF' ) END IF r8wk (1,1) = GETVALNB ( iubfma, 'WCFR', 1, + 'DOWR', -1 ) r8wk (2,1) = GETVALNB ( iubfma, 'WCFR', 1, + 'MXSWD', -1 ) CALL UFBINT ( iubfmn, r8wk, MXMN, 1, nlv2, + 'DOWR MXSWD' ) CALL DRFINI ( iubfmn, nlv, 1, '{BBYSPWV}' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, nlv, nlv2, + 'BBYSPWV' ) END IF END IF C* Surface and sub-surface currents. CALL GETTAGPR ( iubfma, 'DROC', 1, tagpr, ierptg ) IF ( ierptg .eq. 0 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, tagpr ) IF ( nlv .gt. 0 ) THEN CALL DRFINI ( iubfmn, 1, 1, '' ) r8wk (1,1) = GETVALNB ( iubfma, 'DROC', 1, + 'DTCC', -1 ) CALL UFBINT ( iubfmn, r8wk, MXMN, 1, nlv2, 'DTCC' ) CALL DRFINI ( iubfmn, nlv, 1, '{BBYCURR}' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, nlv, nlv2, + 'BBYCURR' ) END IF END IF IF ( gotbts ) THEN C* Maximum wind gust. CALL UT_BFRI ( iubfma, 'MXGS', rmxgs, ier ) CALL UT_RIBF ( iubfmn, 'MXGS', rmxgs, ier ) END IF END IF 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 ( ( rpid(1:2) .ge. '13' ) .and. + ( rpid(1:2) .le. '57' ) ) 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* ex. WIGOS indentifier: 0-22000-0-1501550 C* WGOSIDS = 0 WGOSISID = 22000 WGOSISNM = 0 WGOSLID = 1501550 CALL DC_BSRC ( rpid (1:7), wgos (:)(11:17), + 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) r8wk (1,1) = rwgosids r8wk (2,1) = rwgosisid r8wk (3,1) = rwgosisnm r8wk (4,1) = 0 CALL UFBSEQ ( iubfmn, r8wk, MXMN, 1, nlv, 'WIGOSID' ) wgoslid = rpid(1:7) // ' ' END IF C************ END WIGOS TEST INPUT #3 ********************** 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. C* Choose: rsrd table value 5 C* Can redistribute to any U.S. government agency within NOAA IF ( subtyp .eq. 'NC001121' ) THEN rsrd = PKFTBV (9,5) CALL UT_RIBF ( iubfmn, 'RSRD', rsrd, ier ) END IF C* Write the BUFR output to the BUFR output stream. CALL UT_WBFR ( iubfmn, 'buoy', 0, ierwbf ) C********************************************************* C* Special handling for long character strings. IF ( ( subtyp .eq. 'NC001102' ) .or. + ( subtyp .eq. 'NC001121' ) ) THEN CALL NEMSPECS ( iubfma, 'PTIDC', 1, iscl, iref, + ibits, ierns ) IF ( ierns .eq. 0 ) THEN ibyts = ibits / 8 IF ( ICBFMS ( ptidc, ibyts ) .eq. 0 ) + CALL WRITLC ( iubfmn, ptidc, 'PTIDC' ) END IF END IF IF ( ( got158 ) .or. ( got1126 ) ) THEN CALL WRITLC ( iubfmn, stnnam(1:20), 'STSN' ) ELSE IF ( got159 ) THEN ! also includes NC001121 CALL WRITLC ( iubfmn, stnnam, 'LSTN' ) ELSE IF ( ( got1511 ) .and. + ( subtyp .eq. 'NC001120' ) ) THEN CALL WRITLC ( iubfmn, stnnam(1:20), 'OPMM' ) CALL WRITLC ( iubfmn, opms, 'OPMS' ) CALL WRITLC ( iubfmn, cidpf, 'IDPF' ) ENDIF IF ( gotwigos ) CALL WRITLC ( iubfmn, wgoslid, 'WGOSLID' ) END DO END DO END DO RETURN END