SUBROUTINE SP_DCOD ( cldt, rshpfl, bufrtn, nhours, iret ) C************************************************************************ C* SP_DCOD * C* * C* This routine decodes bulletins containing WMO-migrated ship BUFR * C* messages into NCEP BUFR format. * C* * C* SP_DCOD ( CLDT, RSHPFL, BUFRTN, NHOURS, IRET ) * C* * C* Input parameters: * C* CLDT CHAR* Date-time from command line * C* RSHPFL CHAR* List of WMO bulletins which * C* contain restricted ship data * C* BUFRTN CHAR* NCEP BUFR tables 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* M. Weiss/IMSG 11/19 Decode and store WIGOS IDs * C* J. Ator/NCEP 06/21 Process data from 3-08-018 sequence * C* J. Ator/NCEP 07/23 Use new decod_ut library routines, * C* clean up and simplify logic * C* J. Ator/NCEP 07/24 Process data from 3-08-014 sequence * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' CHARACTER*(*) cldt, rshpfl, bufrtn C* Maximum number of restricted ship bulletin headers. PARAMETER ( MXRSHPB = 200 ) C* Maximum number of descriptors within Section 3 of a C* WMO SHIP BUFR message. PARAMETER ( MXDSC = 50 ) PARAMETER ( MXMN = 50 ) CHARACTER bull*(DCMXBF), cbull*(DCMXBF), bfstyp*8, + seqnum*8, buhd*8, cborg*8, bulldt*8, bbb*8, + subtyp*8, logmsg*200, + cdesc( MXDSC )*6, crshpb ( MXRSHPB )*11, + cbb*11, smid*9, bufrdn*(DCMXLN), + bufrbn*(DCMXLN), wgoslid*16, tagpr*10 INTEGER irundt ( 5 ), irptdt ( 5 ), + ibull ( DCMXBF / 4 ) LOGICAL bullok, msgok, gotwigos, got814, got818 REAL*8 r8in ( MXMN ), r8ot ( MXMN ), PKFTBV, + r8gust ( 3, 255 ), r8bfms, GETBMISS, GETVALNB EQUIVALENCE ( cbull (1:4), ibull (1) ) 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, read and close the file of restricted bulletin headers. CALL FL_TBOP ( rshpfl, 'rshp', irshpfl, iertop ) IF ( iertop .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iertop, rshpfl, ierr ) RETURN END IF iostat = 0 nrshpb = 0 DO WHILE ( ( nrshpb .lt. MXRSHPB ) .and. ( iostat .eq. 0 ) ) READ ( irshpfl, FMT = '(A)', IOSTAT = iostat ) + crshpb ( nrshpb + 1 ) IF ( iostat .eq. 0 ) THEN nrshpb = nrshpb + 1 END IF END DO CALL FL_CLOS ( irshpfl, iercls ) 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* 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/dcship', + 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, 'ship', 1, ierwbf ) END IF bullok = .false. CYCLE END IF cbull = bull ( istart : ibptr ) nmsg = nmsg + 1 msgok = .false. got814 = .false. got818 = .false. C* Review the Section 3 descriptors from the message to ensure C* it contains WMO SHIP data. ii = 1 DO WHILE ( ( ii .le. ndesc ) .and. ( .not. msgok ) ) IF ( ( cdesc(ii) .eq. '308009' ) .or. + ( cdesc(ii) .eq. '301093' ) ) THEN msgok = .true. ELSE IF ( cdesc(ii) .eq. '308014' ) THEN msgok = .true. got814 = .true. ELSE IF ( cdesc(ii) .eq. '308018' ) THEN msgok = .true. got818 = .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* Check if this is a restricted bulletin. cbb = buhd (1:6) // ' ' // cborg (1:4) CALL DC_BSRC ( cbb, crshpb, nrshpb, ipos, ierbrc ) IF ( ipos .ne. 0 ) THEN subtyp = 'NC001101' ELSE subtyp = 'NC001113' 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* Get the identification information. CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, 'SHPIDENT' ) 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(5), r8in(6), + r8in(7), r8in(8), r8in(9), 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 identification information. CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'SHPIDENT' ) C* Store the report ID. CALL READLC ( iubfma, smid, 'SMID' ) CALL UT_CIBF ( iubfmn, 'RPID', smid, 8, iercbf ) logmsg = subtyp // ': station ID = ' // smid CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) C* Get and store the pressure data. CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, 'PRESSQ03' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'PRESSQ03' ) C* Get and store the instantaneous data. IF ( got814 ) THEN r8ot (1) = GETVALNB ( iubfma, 'CHPT', 1, 'HSALG', 1 ) r8ot (2) = GETVALNB ( iubfma, 'CHPT', 1, 'HSAWS', 1 ) CALL UFBINT ( iubfma, r8in, MXMN, 1, nlv, + 'TMDB MWBT TMWB TMDP REHU' ) DO ii = 1, 5 r8ot (ii+2) = r8in (ii) END DO CALL UFBSEQ ( iubfmn, r8ot, MXMN, 1, nlv, 'TEHUDAT2' ) ELSE IF ( got818 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, 'TEMHUMDA' ) DO ii = 1, 3 r8ot (ii) = r8in (ii) END DO r8ot (4) = r8bfms r8ot (5) = r8bfms r8ot (6) = r8in (4) r8ot (7) = r8in (5) CALL UFBSEQ ( iubfmn, r8ot, MXMN, 1, nlv, 'TEHUDAT2' ) ELSE CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, 'SHIPINST' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'SHIPINST' ) END IF C* Get and store the icing data. IF ( .not. got818 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, 'ICINGICE' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'ICINGICE' ) END IF C* Get and store the marine data. IF ( got814 .or. got818 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, 'SEATEMPM' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'SEATEMPM' ) ELSE CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, 'SHIPDATA' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'SHIPDATA' ) END IF C* Get and store the period data. IF ( got814 .or. got818 ) THEN CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, 'WINDDATV' ) DO ii = 1, 8 r8ot (ii) = r8in (ii) END DO DO ii = 9, 14 r8ot (ii) = r8bfms END DO CALL GETTAGPR ( iubfma, 'MXGD', 1, tagpr, iertg ) IF ( iertg .eq. 0 ) THEN CALL UFBINT ( iubfma, r8gust, 3, 255, nlv, tagpr ) IF ( nlv .gt. 0 ) THEN r8ot ( 9) = r8gust (1,1) r8ot (10) = r8gust (1,2) r8ot (11) = r8gust (1,3) END IF IF ( nlv .gt. 1 ) THEN r8ot (12) = r8gust (2,1) r8ot (13) = r8gust (2,2) r8ot (14) = r8gust (2,3) END IF END IF CALL UFBSEQ ( iubfmn, r8ot, MXMN, 1, nlv, 'WINDDAT3' ) ELSE CALL UFBSEQ ( iubfma, r8in, MXMN, 1, nlv, 'SHIPPERD' ) CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'SHIPPERD' ) END IF C* Get and store the WIGOS identifier. CALL UFBINT ( iubfma, r8in, MXMN, 1, nlv, + 'WGOSIDS WGOSISID WGOSISNM' ) IF ( ( IBFMS ( r8in (1) ) .eq. 0 ) .or. + ( IBFMS ( r8in (2) ) .eq. 0 ) .or. + ( IBFMS ( r8in (3) ) .eq. 0 ) ) THEN gotwigos = .true. CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'WIGOSID' ) CALL READLC ( iubfma, wgoslid, 'WGOSLID' ) ELSE gotwigos = .false. 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 ) IF ( subtyp .eq. 'NC001101' ) THEN C* Restriction indicator. rsrd = PKFTBV(9,1) CALL UT_RIBF ( iubfmn, 'RSRD', rsrd, ierrbf ) END IF C* Write the BUFR output to the BUFR output stream. CALL UT_WBFR ( iubfmn, 'ship', 0, ierwbf ) IF ( gotwigos ) CALL WRITLC ( iubfmn, wgoslid, 'WGOSLID' ) END DO END DO END DO RETURN END