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 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* J. Ator/NCEP 06/22 Decode 3-15-0[12]3 as new NC031008 * C* J. Ator/NCEP 07/23 Use new decod_ut library routines, * C* clean up and simplify logic * C* J. Ator/NCEP 07/23 Handle variation of 3-15-003 sequence * C* which uses extra operator descriptors * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'mfcmn.cmn' CHARACTER*(*) cldt, bufrtn, wgosid C* Maximum number of descriptors within Section 3 of a C* marine subsurface 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, + 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, tagch*4, ptidc*16 INTEGER irundt ( 5 ), irptdt ( 5 ), + ibull ( DCMXBF / 4 ) LOGICAL bullok, msgok, rptok, got157, gotwigos PARAMETER ( MXTRKMN = 1200 ) PARAMETER ( MXTRKLV = 100 ) REAL*8 GETBMISS, GETVALNB, rqfp, rggp, r8v, r8slno, + r8tspf ( MXMN, MXLV ), r8rep ( MXLV ), + r8trk ( MXTRKMN, MXTRKLV ) EQUIVALENCE ( cbull (1:4), ibull (1) ), ( r8slno, cslno ) 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_dcmssf_USA.wigosId" C* containing sample WIGOS ids valid November 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/dcmssf', + 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* edition 4 and up to 100K bytes in size. CALL PKVS01 ( 'BEN', 4 ) CALL MAXOUT ( 100000 ) CALL PKVS01 ( 'MTV', 38 ) 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, 'mssf', 1, ierwbf ) END IF bullok = .false. CYCLE END IF nmsg = nmsg + 1 C* Ensure the message contains marine subsurface data. IF ( mtyp .ne. 31 ) THEN logmsg = 'message does not contain marine subsurface data' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) CYCLE END IF C* Determine the message type. 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 IF ( ( cdesc(ii) .eq. '315013' ) .or. + ( cdesc(ii) .eq. '315023' ) ) THEN subtyp = 'NC031008' 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. 27 ) .and. + ( cdesc( 6) .eq. '002036' ) .and. + ( cdesc(17) .eq. '109000' ) .and. + ( cdesc(22) .eq. '022045' ) .and. + ( cdesc(25) .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' 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 CYCLE END IF END IF cbull = bull ( istart : ibptr ) C* Open the BUFR message for reading. CALL READERME ( ibull, iubfma, bfstyp, ibfdt, ierrme ) IF ( ierrme .ne. 0 ) CYCLE msgok = .true. 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 ( ( subtyp .eq. 'NC031007' ) .or. + ( subtyp .eq. 'NC031008' ) ) THEN C* Treat each replication as a separate output report. IF ( subtyp .eq. 'NC031007' ) THEN tagch = 'SST0' ELSE tagch = 'OSQN' END IF CALL GETTAGPR ( iubfma, tagch, 1, tagpr, iertg ) CALL UFBSEQ ( iubfma, r8trk, MXTRKMN, MXTRKLV, ntrk, + tagpr ) IF ( ntrk .eq. 0 ) CYCLE IF ( subtyp .eq. 'NC031008' ) THEN C* Get the temperature and salinity profile data C* for all replications. CALL GETTAGPR ( iubfma, 'SST1', 1, tagpr, iertg) CALL ST_LSTR ( tagpr, ltagpr, ier ) CALL UFBINT ( iubfma, r8rep, 1, MXLV, nrep, + '(' // tagpr(1:ltagpr) // ')' ) IF ( nrep .ne. ntrk ) CYCLE CALL UFBSEQ ( iubfma, r8tspf, MXMN, MXLV, + ntspf, tagpr(1:ltagpr) ) jjtspf = 1 END IF jjtrk = 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 ( ( subtyp .eq. 'NC031007' ) .or. + ( subtyp .eq. 'NC031008' ) ) THEN IF ( jjtrk .lt. ntrk ) THEN jjtrk = jjtrk + 1 r8in(1,1) = r8trk (1,jjtrk) r8in(2,1) = r8trk (2,jjtrk) r8in(3,1) = r8trk (3,jjtrk) r8in(4,1) = r8trk (4,jjtrk) r8in(5,1) = r8trk (5,jjtrk) 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 ( ( subtyp .eq. 'NC031005' ) .or. + ( subtyp .eq. 'NC031006' ) ) 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 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' ) END IF IF ( subtyp .eq. 'NC031007' ) THEN CALL READLC ( iubfma, smid, 'SMID' ) C* Store the along-track data. DO ii = 1, 16 r8in ( ii, 1 ) = r8trk ( ii, jjtrk ) END DO CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'ALGTRKSQ' ) ELSE IF ( subtyp .eq. 'NC031008' ) THEN DO ii = 1, 10 r8in ( ii, 1 ) = r8trk ( ii, jjtrk ) END DO CALL UFBINT ( iubfmn, r8in, MXMN, 1, nlv2, + 'YEAR MNTH DAYS HOUR MINU ' // + 'CLATH CLONH IDPF OSQN DIPR' ) C* Store the temperature and salinity profile C* for this replication. nlev = IDINT ( r8rep ( jjtrk ) ) kk = 0 DO jj = jjtspf, ( jjtspf + nlev - 1 ) kk = kk + 1 DO ii = 1, 12 r8wk ( ii, kk ) = r8tspf ( ii, jj ) END DO END DO jjtspf = jjtspf + nlev CALL DRFINI ( iubfmn, nlev, 1, '(TMSLPFSQ)' ) CALL UFBSEQ ( iubfmn, r8wk, MXMN, nlev, nlv2, + 'TMSLPFSQ' ) CALL READLC ( iubfma, stnnam, 'LSTN' ) CALL READLC ( iubfma, ptidc, 'PTIDC' ) CALL UT_BFRI ( iubfma, 'DCLS', rval, ier ) CALL UT_RIBF ( iubfmn, 'DCLS', rval, ier ) CALL UT_BFRI ( iubfma, 'SFSTP', rval, ier ) CALL UT_RIBF ( iubfmn, 'SFSTP', rval, ier ) CALL UT_BFRI ( iubfma, 'IWTEMP', rval, ier ) CALL UT_RIBF ( iubfmn, 'IWTEMP', rval, ier ) CALL UT_BFRI ( iubfma, 'WMOP', wmop, ier ) IF ( ERMISS ( wmop ) ) THEN C* Store the 7-digit WGOSLID as the WMOP. CALL ST_CRNM ( wgoslid(10:16), wmop, ier ) END IF CALL UT_RIBF ( iubfmn, 'WMOP', wmop, ier ) ELSE C* Get and store the platform identifier. 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*********** START WIGOS TEST INPUT #3 ********************* IF ( .not. gotwigos ) THEN C* Temporarily manufacture WIGOS ids for USA sites to C* begin populating the downstream database, and until C* these sites begin generating WIGOS ids on their own. IF ( ( cwmop_wigos .ge. '1900000' ) .and. + ( cwmop_wigos .le. '8000000' ) ) THEN CALL DC_BSRC ( cwmop_wigos, 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 = cwmop_wigos // ' ' END IF END IF END IF C************ END WIGOS TEST INPUT #3 ********************** C* Get and store the date and time. 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* Get and store the latitude and longitude. CALL UFBSEQ ( iubfma, r8in, MXMN, MXLV, nlv, 'LTLONH') CALL UFBSEQ ( iubfmn, r8in, MXMN, 1, nlv, 'LTLONH' ) C* Dissolved oxygen profile data. CALL MF_DOXY ( iubfma, iubfmn, subtyp ) IF ( subtyp .eq. 'NC031005' ) THEN C* Additional NC031005 data. C* Float profile level data. 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 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 ) ELSE C* Additional NC031006 data. CALL MF_3106 ( iubfma, iubfmn, got157 ) CALL READLC ( iubfma, smid, 'SMID' ) CALL READLC ( iubfma, stnnam, 'LSTN' ) CALL UFBINT ( iubfma, r8slno, 1, 1, nlv, 'SLNO' ) IF ( IBFMS ( r8slno ) .eq. 0 ) + CALL UT_CIBF ( iubfmn, 'SLNO', cslno, 4, ier ) IF ( got157 ) THEN CALL READLC ( iubfma, icmdc, 'ICMDC' ) ELSE CALL READLC ( iubfma, softv, 'SOFTV' ) END IF END IF END IF C* Store the 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* Store the 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* Store the 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* Write the BUFR output to the BUFR output stream. CALL UT_WBFR ( iubfmn, 'mssf', 0, ierwbf ) 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". IF ( gotwigos ) + CALL WRITLC ( iubfmn, wgoslid, 'WGOSLID' ) 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 IF ( subtyp .eq. 'NC031008' ) THEN CALL WRITLC ( iubfmn, stnnam, 'LSTN' ) CALL WRITLC ( iubfmn, ptidc, 'PTIDC' ) WRITE ( logmsg, FMT = '(A, A, I7)' ) + subtyp, ': station ID = ', INT ( wmop ) 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 ) IF ( ( subtyp .eq. 'NC031005' ) .or. + ( subtyp .eq. 'NC031006' ) ) rptok = .false. END DO END DO END DO END DO RETURN END