SUBROUTINE CJ_DCOD( cldt, csjpfl, bufrtb, nhours, iret )
C************************************************************************
C* CJ_DCOD *
C* *
C* This routine decodes CSR (clear-sky radiance) data files from Japan *
C* into NCEP BUFR format. *
C* *
C* CJ_DCOD ( CLDT, CSJPFL, BUFRTB, NHOURS, IRET ) *
C* *
C* Input parameters: *
C* CLDT CHAR* Date-time from command line *
C* CSJPFL CHAR* CSR data file *
C* BUFRTB CHAR* NCEP BUFR table 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* J. Ator/NCEP 03/17 *
C* M. Weiss/IMSG 02/19 Added additional FL_PATH call to get *
C* master table directory location. *
C* M. Weiss/IMSG 06/21 MAXOUT (200000) --> MAXOUT (199900) *
C* J. Ator/NCEP 09/21 Get $DBNROOT for use in locating .dummy *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BRIDGE.PRM'
C*
C* Maximum length of a BUFR message within a CSR data file.
C*
PARAMETER ( MXLBFMG = 600000 )
PARAMETER ( MXLBFMGD4 = MXLBFMG/4 )
C*
CHARACTER*(*) cldt, bufrtb, csjpfl
C*
CHARACTER bfrmg*(MXLBFMG), bfmg(MXLBFMG)*1, logmsg*200,
+ rundt*12, sysdt*12, bfstmf*8, bfstyp*8,
+ csjpfld*(DCMXLN), csjpflb*(DCMXLN),
+ bufrdn*(DCMXLN), bufrbn*(DCMXLN),
+ dbdir*(DCMXLN)
C*
INTEGER irundt ( 5 ), irptdt ( 5 ),
+ ibfrmg(MXLBFMGD4), ibfmg(MXLBFMGD4)
C*
LOGICAL bfrmgok, CJ_BMOK
C*
PARAMETER ( MXR8PR = 15, MXR8LV = 12 )
REAL*8 r8in ( MXR8PR, MXR8LV ),
+ r8out ( MXR8PR, MXR8LV ),
+ r8bfms, GETBMISS
C*
EQUIVALENCE ( bfrmg (1:4), ibfrmg (1) )
EQUIVALENCE ( bfmg(1), ibfmg(1) )
C*
C* Number of expected descriptors within Section 3 of each
C* CSR BUFR message.
C*
PARAMETER ( NXDSC = 10 )
C*
C* The following array will hold the list of expected descriptors
C* within Section 3 of each CSR BUFR message.
C*
CHARACTER cxdsc( NXDSC )*6
C*
C* Expected descriptors within Section 3 of a CSR BUFR message.
C*
DATA ( cxdsc ( ii ), ii = 1, NXDSC )
+ / '310023', '224000', '236000', '101185', '031031', '001031',
+ '001032', '008023', '101010', '224255' /
C*
INCLUDE 'ERMISS.FNC'
C*-----------------------------------------------------------------------
iret = 0
C
C* Extract the basename from the CSR data file and write it to the
C* decoder log.
C
CALL FL_PATH ( csjpfl, csjpfld, csjpflb, ierpth )
logmsg = 'CSR filename: '// csjpflb
CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg )
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 ( bufrtb, bufrdn, bufrbn, ierpth )
C
C* Open the tables file for the NCEP BUFR (i.e. output) stream.
C
CALL FL_SOPN ( bufrtb, iubftn, ierspn )
IF ( ierspn .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', ierspn, bufrtb, ierwlg )
RETURN
END IF
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 encoded
C* using edition 4, compressed, and up to 200K bytes in size.
C
CALL PKVS01 ( 'BEN', 4 )
CALL CMPMSG ( 'Y' )
CALL MAXOUT ( 199900 )
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
C* Open the CSR BUFR messages file.
C
CALL FL_GLUN ( iubfma, iergln )
IF ( iergln .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg )
RETURN
END IF
CALL SS_ENVR ( '$DBNROOT', dbdir, ierenv )
CALL ST_LSTR ( dbdir, ldbd, ierstr )
IF ( ( ierenv .ne. 0 ) .or. ( ldbd .eq. 0 ) ) THEN
logmsg = 'Environment variable $DBNROOT is undefined'
CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg )
RETURN
END IF
OPEN ( UNIT = iubfma, FILE = dbdir(1:ldbd) // '.dummy/dccsjp',
+ FORM = 'UNFORMATTED' )
CALL OPENBF ( iubfma, 'SEC3', iubfma )
CALL MTINFO (bufrdn,98,99)
C
C* Open the CSR input file to the BUFR message reader.
C
CALL COBFL ( csjpfl, 'r' )
C
DO WHILE ( .true. )
C
C* Get a new CSR BUFR message from the input file.
C
CALL CRBMG ( bfmg, MXLBFMG, nbyt, ierr )
IF ( ierr .eq. 0 ) THEN
C
C* Pad the end of the message with zeroed-out bytes up to the
C* next 8-byte boundary.
C
CALL PADMSG ( ibfmg, MXLBFMGD4, npbyt )
lenb = nbyt + npbyt
C
C* Copy the BUFR message character array into a BUFR message
C* character string.
C
DO ii = 1, lenb
bfrmg ( ii:ii ) = bfmg ( ii )(1:1)
END DO
ELSE
IF ( ierr .ne. -1 ) CALL UT_EMSG ( 2, 'CRBMG', ierr )
C
C* Make sure that all BUFR output has been written to the
C* output stream before exiting.
C
CALL UT_WBFR ( iubfmn, 'csjp', 1, ierwbf )
CALL CLOSBF ( iubfmn )
CALL CLOSBF ( iubfma )
CALL FL_CLAL ( iercal )
CALL CCBFL
RETURN
END IF
C
bfrmgok = .true.
IF ( bfrmgok ) 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 )
bfrmgok = .false.
END IF
END IF
IF ( bfrmgok ) THEN
C
C* If a date-time was entered on the command line, then
C* use it as the run date-time. Otherwise, use the
C* system time as 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 )
bfrmgok = .false.
END IF
END IF
END IF
IF ( bfrmgok ) 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 )
bfrmgok = .false.
END IF
END IF
IF ( bfrmgok ) THEN
C
C* Retrieve the Section 3 descriptors from this CSR
C* BUFR message and compare it with the list of
C* expected descriptors
C
CALL UT_CBS3 ( 3, ibfrmg, cxdsc, NXDSC, iercs3 )
IF ( iercs3 .ne. 0 ) THEN
bfrmgok = .false.
logmsg = 'message has unknown format'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
END IF
END IF
IF ( bfrmgok ) THEN
C
C* Open this CSR BUFR message.
C
CALL READERME ( ibfrmg, iubfma, bfstmf, ibfdt, ierrme )
IF ( ierrme .ne. 0 ) THEN
bfrmgok = .false.
ELSE
nrept = 0
END IF
END IF
DO WHILE ( bfrmgok )
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
bfrmgok = .false.
C
C* Print a count of the number of reports processed.
C
WRITE ( UNIT = logmsg, FMT = '( A, I6, A )' )
+ 'contained ', nrept, ' reports'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
ELSE
nrept = nrept + 1
C
icorn = IUPBS01 ( ibfrmg, 'USN' )
IF ( icorn .gt. 0 ) icorn = 1
C
C* Get the identification information.
C
CALL UFBSEQ ( iubfma, r8in, MXR8PR, MXR8LV, ier,
+ 'SIDENSEQ')
C
C* Do not create BUFR output for reports that are more than
C* NHOURS before or more than 3 hours after the run time.
C
rptyr = UT_BMRI ( r8in ( 6,1) )
rptmo = UT_BMRI ( r8in ( 7,1) )
rptdy = UT_BMRI ( r8in ( 8,1) )
rpthr = UT_BMRI ( r8in ( 9,1) )
rptmi = UT_BMRI ( r8in (10,1) )
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, 'NC021044', ibfdt )
C
C* Write the identification information.
C
CALL UFBSEQ ( iubfmn, r8in, MXR8PR, 1, ier, 'SIDENSEQ')
C
C* Get and write the pixel counts, zenith angles and
C* geopotential.
C
CALL UFBINT ( iubfma, r8in, MXR8PR, MXR8LV, ier,
+ 'NPPR NPPC LSQL SAZA SOZA HITE' )
CALL UFBINT ( iubfmn, r8in, MXR8PR, 1, ier,
+ 'NPPR NPPC LSQL SAZA SOZA HITE' )
C
C* Get and store the cloud fraction, clear sky radiance,
C* and first-order statistical values.
C
CALL UFBSEQ ( iubfma, r8in, MXR8PR, MXR8LV, ier,
+ 'CLFRASEQ' )
DO jj = 1, 12
DO ii = 1, 5
r8out ( ii, jj ) = r8in ( ii, jj )
END DO
END DO
CALL UFBSEQ ( iubfma, r8in, MXR8PR, MXR8LV, ier,
+ 'CSRADSEQ' )
DO jj = 1, 12
r8out ( 6, jj ) = r8in ( 1, jj )
r8out ( 7, jj ) = r8in ( 2, jj )
r8out ( 8, jj ) = r8in ( 3, jj )
r8out ( 9, jj ) = r8in ( 8, jj )
r8out ( 10, jj ) = r8bfms
END DO
IF ( CJ_BMOK ( iubfma ) ) THEN
CALL UFBREP ( iubfma, r8in, MXR8PR, MXR8LV, ier,
+ '224255' )
DO jj = 1, 10
r8out ( 10, jj ) = r8in ( 1, jj )
END DO
END IF
CALL UFBREP ( iubfmn, r8out, MXR8PR, 12, ier,
+ 'SCCF SCBW CLDMNT NCLDMNT CLTP ' //
+ 'SIDP RDTP RDCM TMBRST SDTB' )
C
C* Write 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* Write the correction indicator.
C
CALL UT_RIBF ( iubfmn, 'CORN', FLOAT (icorn), ier )
C
C* Write the BUFR output to the BUFR output stream.
C
CALL UT_WBFR ( iubfmn, 'csjp', 0, ierwbf )
END IF
END IF
END DO
END DO
C*
RETURN
END