SUBROUTINE AL_DCOD ( cldt, alpsfl, bufrtb, nhours, iret ) C************************************************************************ C* AL_DCOD * C* * C* This routine decodes the NAVOCEANO Altimeter Processing System (ALPS)* C* Sea-Surface Data into BUFR format. * C* * C* AL_DCOD ( CLDT, ALPSFL, BUFRTB, NHOURS, IRET ) * C* * C* Input parameters: * C* CLDT CHAR* Date-time from command line * C* ALPSFL CHAR* ALPS data file * C* BUFRTB CHAR* BUFR tables file * C* NHOURS INTEGER Max # of hours before run time * C* for creating BUFR output * C* * C* Output parameters: * C* IRET INTEGER Return code: * C* 0 = normal return * C* * C** * C* Log: * C* R. Hollern/NCEP 07/02 Based on dcnlsa * C* R. Hollern/NCEP 10/02 Allocated BUFR Code Table 0-01-007 * C* entries for "topex" and "gfo" satellites* C* R. Hollern/NCEP 12/02 Allocated BUFR Code Table 0-01-007 * C* entry for "js1i" satelite * C* R. Hollern/NCEP 01/04 Changed observation quality for jason-1 * C* data from experimental to good. Reduced * C* amount of log message printout. * C* J. Ator/NCEP 08/04 SS_GTIM -> CSS_GTIM * C* C. Caruso Magee/NCEP 03/06 Set observation quality using PKFTBV. * C* J. Ator/NCEP 11/06 Bypass any "error" messages in file * C* C. Caruso Magee/NCEP 05/07 Adding envg (ENVISAT) to list of files * C* to be decoded. Will store into * C* b031/xx109. Also changed gfoo obs * C* quality from experimental to good per * C* L. Russell of NAVO. * C* S. Guan/NCEP 02/09 Added Jason-2 (js2o and js2i) to list * C* of files to be decoded. Stored into * C* b031/xx112 and xx113. * C* S. Guan/NCEP 04/09 Replace js1i with j1ni. * C* J. Ator/NCEP 06/11 Add enli (ENVISAT with new 30-day orbit)* C* J. Ator/NCEP 07/12 Add processing for js1n (new Jason-1) * C* and cryi (Cryosat-2) * C* J. Ator/NCEP 08/13 Add processing for atko and atki * C* J. Ator/NCEP 10/15 Handle corrupt data records * C* J. Ator/NCEP 03/16 Add rptsec, npts, nsmpl to BUFR output * C* J. Ator/NCEP 08/16 Add processing for js3o and js3i * C* J. Ator/NCEP 10/16 Add processing for atno and atni * C* J. Ator+M.Weiss/NCEP 12/16 Add processing for j2no and j2ni, fix * C* read precision for lat, long and date * C* J. Ator/NCEP 04/17 Add processing for s3an and s3as * C* J. Ator/NCEP 08/17 Add processing for j2do and j2di * C* J. Ator/NCEP 08/19 Add processing for j2lo and j2li (new * C* Jason-2) and s3bs and s3bn (Sentinel 3B)* C* J. Ator/NCEP 04/22 Add processing for j3ni and j3no * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'alcmn.cmn' C* CHARACTER*(*) cldt, alpsfl, bufrtb C* CHARACTER rundt*12, sysdt*12, + alpsdn*(DCMXLN), alpsbn*(DCMXLN), + report*(DCMXLN), + rimnem(NRIMN)*8, r8mnem(NR8IMN)*8, + carr(5)*12, cdef*12, sep C* INTEGER irundt (5), irptdt (5) INTEGER cyclnm, orbn, satid C* REAL*8 rnlat, relon, r85day, rh, PKFTBV, GETBMISS C* DATA sep / ' ' / DATA cdef / ' ' / C* INCLUDE 'ERMISS.FNC' C*----------------------------------------------------------------------- iret = 0 ieread = -9 loglev = 3 C C* Extract the basename from the ALPS data file and write it to C* the decoder log. C CALL FL_PATH ( alpsfl, alpsdn, alpsbn, ierpth ) C IF ( alpsbn (1:4) .eq. 'ers2' .or. + alpsbn (1:4) .eq. 'gfoM' .or. + alpsbn (1:4) .eq. 'gfoo' .or. + alpsbn (1:4) .eq. 'tpx1' .or. + alpsbn (1:4) .eq. 'tpx2' .or. + alpsbn (1:4) .eq. 'envg' .or. + alpsbn (1:4) .eq. 'enli' .or. + alpsbn (1:4) .eq. 'js2o' .or. + alpsbn (1:4) .eq. 'js2i' .or. + alpsbn (1:4) .eq. 'j2no' .or. + alpsbn (1:4) .eq. 'j2ni' .or. + alpsbn (1:4) .eq. 'j2do' .or. + alpsbn (1:4) .eq. 'j2di' .or. + alpsbn (1:4) .eq. 'j2lo' .or. + alpsbn (1:4) .eq. 'j2li' .or. + alpsbn (1:4) .eq. 'js3o' .or. + alpsbn (1:4) .eq. 'js3i' .or. + alpsbn (1:4) .eq. 'j3no' .or. + alpsbn (1:4) .eq. 'j3ni' .or. + alpsbn (1:4) .eq. 'js1n' .or. + alpsbn (1:4) .eq. 'cryi' .or. + alpsbn (1:4) .eq. 'atko' .or. + alpsbn (1:4) .eq. 'atki' .or. + alpsbn (1:4) .eq. 'atno' .or. + alpsbn (1:4) .eq. 'atni' .or. + alpsbn (1:4) .eq. 's3an' .or. + alpsbn (1:4) .eq. 's3as' .or. + alpsbn (1:4) .eq. 's3bn' .or. + alpsbn (1:4) .eq. 's3bs' .or. + alpsbn (1:4) .eq. 'j1ni') THEN logmsg = 'ALPS DATA FILENAME: ' // alpsbn CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg ) ELSE logmsg = + 'DID NOT RECOGNIZE THIS ALPS DATA FILENAME: ' // alpsbn CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg ) logmsg = 'NO REPORTS DECODED !!!' CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg ) RETURN END IF C C* Set the pointers for the interface arrays. C CALL AL_IFSP ( rimnem, r8mnem, ierfsp ) IF ( ierfsp .ne. 0 ) THEN RETURN ENDIF C C* Open the ALPS data file. C CALL FL_SOPN ( alpsfl, iunndf, ierspn ) IF ( ierspn .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ierspn, alpsfl, ierwlg ) RETURN END IF C C* Open the BUFR tables file. C CALL FL_SOPN ( bufrtb, iunbft, ierspn ) IF ( ierspn .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ierspn, bufrtb, ierwlg ) RETURN END IF C C* Open the BUFR output file. C CALL FL_GLUN ( iunbfo, iergln ) IF ( iergln .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg ) RETURN END IF C C* Connect the BUFR tables and output files to the BUFR interface. C CALL OPENBF ( iunbfo, 'NUL', iunbft ) r8bfms = GETBMISS() C C* Close the BUFR tables file. C CALL FL_CLOS ( iunbft, iercls ) IF ( iercls .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg ) END IF 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 ) RETURN END IF C C* If a date-time was entered on the command line, then use it as C* the run date-time. Otherwise, use the system time as the run C* 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 ) RETURN END IF END IF 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 ) RETURN END IF C C* Read the header records indicating the altimeter type. C 100 READ ( UNIT = iunndf, FMT = '(A)', ERR = 900, END = 910 ) report IF ( INDEX( report(1:), 'error' ) .ne. 0 ) GOTO 100 200 READ ( UNIT = iunndf, FMT = '(A)', ERR = 900, END = 910 ) report IF ( INDEX( report(1:), 'error' ) .ne. 0 ) GOTO 200 C C* The records of sea surface height are grouped by track number. C* Set nptrec to point to header record for current track. C nptrec = 4 C C* Count records in file. C irc = 3 C C* Number of expected values. C nexp = 5 C DO WHILE ( .true. ) C irc = irc + 1 C C* Read the next report from the ALPS data file. C 300 READ ( UNIT = iunndf, FMT = '(A)', ERR = 900, END = 910 ) + report IF ( INDEX( report(1:), 'error' ) .ne. 0 ) GOTO 300 C IF ( irc .eq. nptrec ) THEN C C* Break header record into a list of strings and store list C* in array carr. C CALL ST_CLST ( report, sep, cdef, nexp, carr, num, iret ) C C* Get cycle number, track number, number of points in track, C* and sat_id from header record. C READ ( UNIT = carr(1), FMT = '(I11)', ERR = 900 ) cyclnm xcylnm = FLOAT ( cyclnm ) READ ( UNIT = carr(2), FMT = '(I11)', ERR = 900 ) orbn xorbn = FLOAT ( orbn ) READ ( UNIT = carr(3), FMT = '(I11)', ERR = 900 ) npts READ ( UNIT = carr(4), FMT = '(I11)', ERR = 900 ) satid xsatid = FLOAT ( satid ) SELECT CASE ( alpsbn (1:4) ) CASE ( 'gfoM', 'gfoo' ) xsatid = 721. CASE ( 'tpx1', 'tpx2' ) xsatid = 720. CASE ( 'j1ni', 'js1n' ) xsatid = 260. CASE ( 'js2o', 'js2i', 'j2no', 'j2ni', 'j2do', 'j2di', + 'j2lo', 'j2li' ) xsatid = 261. CASE ( 'js3o', 'js3i' ) xsatid = 262. CASE ( 'envg', 'enli' ) xsatid = 60. CASE ( 'cryi' ) xsatid = 47. CASE ( 'atki', 'atko', 'atni', 'atno' ) xsatid = 441. CASE ( 's3an', 's3as' ) xsatid = 61. CASE ( 's3bn', 's3bs' ) xsatid = 65. END SELECT C nptrec = nptrec + npts + 1 ELSE C C* Write the report to the decoder log. C CALL DC_WLOG ( 2, 'DC', 2, report, ierwlg ) C C* Break report string into a list of strings and store list C* in array carr. C CALL ST_CLST ( report, sep, cdef, nexp, carr, num, iret ) C C* Get the report values. C READ ( UNIT = carr(1), FMT = '(I11)', ERR = 900 ) nsmpl READ ( UNIT = carr(2), FMT = '(F11.6)', ERR = 900 ) rnlat READ ( UNIT = carr(3), FMT = '(F11.6)', ERR = 900 ) relon READ ( UNIT = carr(4), FMT = '(F12.6)', ERR = 900 ) r85day READ ( UNIT = carr(5), FMT = '(F11.6)', ERR = 900 ) rh C C* Compute the date-time using the "1985 Day". C CALL AL_85DY ( r85day, irptdt, rptsec, ier85d ) IF ( ier85d .ne. 0 ) THEN CALL UT_EMSG ( 0, 'AL_85DY', ier85d ) ELSE C C* Initialize the interface arrays. C CALL AL_IFIV ( ierifi ) C C* Store the date-time. C DO ii = 1, 5 rivals ( ii ) = FLOAT ( irptdt ( ii ) ) END DO C C* Store the cycle number. C rivals ( ircyln ) = xcylnm C C* Store the orbit (track) number. C rivals ( irorbn ) = xorbn C C* Store the satellite ID BUFR Code table 0-01-007 entry. C rivals ( irsaid ) = xsatid C C* Store the satellite classification. See BUFR C* code table 0 02 020 for meaning of value. C SELECT CASE ( alpsbn (1:4) ) CASE ( 'ers2' ) rivals ( irsclf ) = 91. CASE ( 'j1ni', 'js1n', 'js2o', 'js2i', 'j2no', + 'j2ni', 'j2do', 'j2di', 'js3o', 'js3i', + 'j2li', 'j2lo' ) rivals ( irsclf ) = 261. CASE ( 's3an', 's3as', 's3bn', 's3bs' ) rivals ( irsclf ) = 92. END SELECT C C* Observation quality. See BUFR flag table 0 25 053, C* which has a bitwidth of 12. Bit 1 - good. C* Bit 2 - redundant. Bit 3 - questionable. Bit 4 - bad. C* Bit 5 - experimental. Bit 6 - precipitating. C* Bit 7-11 - reserved. All 12 - missing. C IF ( alpsbn (1:4) .eq. 'tpx1' ) THEN rivals ( irobql ) = PKFTBV ( 12, 5 ) ELSE rivals ( irobql ) = PKFTBV ( 12, 1 ) END IF C C* Store the latitude. C r8vals ( irslat ) = rnlat C C* Compute and store the longitude. C r8vals ( irslon ) = relon CALL AL_NLON ( r8vals ( irslon ), iernln ) C C* Store the sea level height deviation from the C* 1993 - 2000 mean. C r8vals ( irshd1 ) = rh C C* Write the interface output to the decoder log. C CALL AL_IFPT ( loglev, rimnem, r8mnem, iret ) C C* Do not create BUFR output for reports that are C* more than NHOURS before or more than 3 hours C* after the run time. C IF ( ( ERMISS ( rivals ( iryear ) ) ) .or. + ( ERMISS ( rivals ( irmnth ) ) ) .or. + ( ERMISS ( rivals ( irdays ) ) ) .or. + ( ERMISS ( rivals ( irhour ) ) ) .or. + ( ERMISS ( rivals ( irminu ) ) ) ) THEN iertmk = -1 ELSE irptdt (1) = INT ( rivals ( iryear ) ) irptdt (2) = INT ( rivals ( irmnth ) ) irptdt (3) = INT ( rivals ( irdays ) ) irptdt (4) = INT ( rivals ( irhour ) ) irptdt (5) = INT ( rivals ( irminu ) ) C CALL DC_TMCK ( 2, irundt, irptdt, nhours, 180, + iertmk ) END IF C IF ( iertmk .eq. 0 ) THEN C C* Convert interface-format data for this report C* into BUFR output and then write the BUFR output C* to the BUFR output stream. C CALL AL_BUFR ( iunbfo, irundt, alpsbn, report, + rptsec, npts, nsmpl, ierbfr ) END IF C END IF C END IF C END DO C 900 ieread = -5 910 CALL DC_WLOG ( 0, 'DC', ieread, ' ', ierwlg ) C C* Make sure that all BUFR output has been written before exiting. C CALL UT_WBFR ( iunbfo, 'alps', 1, ierwbf ) C CALL CLOSBF ( iunbfo ) CALL FL_CLAL ( iercal ) C* RETURN END