SUBROUTINE NC_DCOD ( cldt, ncldfl, bufrtb, nhours,
+ bufrof, iret )
C************************************************************************
C* NC_DCOD *
C* *
C* This routine decodes NASA Langley cloud data into BUFR format. *
C* *
C* NC_DCOD ( CLDT, NCLDFL, BUFRTB, NHOURS, IRET ) *
C* *
C* Input parameters: *
C* CLDT CHAR* Date-time from command line *
C* NCLDFL CHAR* NCLD data file *
C* BUFRTB CHAR* BUFR tables file *
C* NHOURS INTEGER Max # of hours before run time *
C* for creating BUFR output *
C* BUFROF CHAR* BUFR output file *
C* *
C* Output parameters: *
C* IRET INTEGER Return code: *
C* 0 = normal return *
C* -1 = an error occurred; see *
C* decoder log for details *
C* *
C** *
C* Log: *
C* J. Ator/NCEP 06/10 *
C* J. Ator/NCEP 09/10 Fixes to latitude calculation and array *
C* indices (2D->1D) *
C* J. Ator/NCEP 01/11 Modified in response to NCLDFL changes *
C* J. Ator/NCEP 12/11 Modified to handle G15V3 files *
C* J. Ator/NCEP 09/12 Modified to handle G14V3 files *
C* J. Ator/NCEP 09/13 Improved log messages *
C* J. Ator/NCEP 02/17 Include cloud phase in criteria for *
C* BUFR generation, use NC_GDIM instead of *
C* hard-coding image_y and image_x values *
C* J. Ator/NCEP 11/17 Add processing for G16, G17, G18 and G19*
C* J. Ator/NCEP 05/19 Use INDEX to search for first colon in *
C* base_time string, use GET_ATT functions *
C* to get valid_min and valid_max values, *
C* redesign using NC_GRVA and RVALOK *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BRIDGE.PRM'
INCLUDE 'netcdf.inc'
C*
CHARACTER*(*) cldt, ncldfl, bufrtb, bufrof
C*
CHARACTER rundt*12, sysdt*12, cmvstr*8, basetm*38,
+ nclddn*(DCMXLN), ncldbn*(DCMXLN),
+ logmsg*200
C*
REAL*8 offstm
C*
REAL, ALLOCATABLE :: rlats(:), rlons(:), rclet(:), rclwp(:),
+ rcltp(:), rclbp(:), rclth(:), rclbh(:)
C*
INTEGER, ALLOCATABLE :: iclph(:)
C*
INTEGER irundt (5), irptdt (5)
C*
LOGICAL clphok, RVALOK
C*
RVALOK ( val, valmn, valmx ) =
+ ( ( val .ge. valmn ) .and. ( val .le. valmx ) )
C*-----------------------------------------------------------------------
iret = -1
C
C* Extract the basename from the NCLD data file and write it to
C* the decoder log.
C
CALL FL_PATH ( ncldfl, nclddn, ncldbn, ierpth )
logmsg = 'NCLD DATA FILENAME: ' // ncldbn
CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg )
C
C* Determine the file type.
C
IF ( ncldbn (1:4) .eq. 'G11V' ) THEN
rsaid = 255
ELSE IF ( ncldbn (1:4) .eq. 'G13V' ) THEN
rsaid = 257
ELSE IF ( ncldbn (1:4) .eq. 'G14V' ) THEN
rsaid = 258
ELSE IF ( ncldbn (1:4) .eq. 'G15V' ) THEN
rsaid = 259
ELSE IF ( ncldbn (1:4) .eq. 'G16V' ) THEN
rsaid = 270
ELSE IF ( ncldbn (1:4) .eq. 'G17V' ) THEN
rsaid = 271
ELSE IF ( ncldbn (1:4) .eq. 'G18V' ) THEN
rsaid = 272
ELSE IF ( ncldbn (1:4) .eq. 'G19V' ) THEN
rsaid = 273
ELSE
logmsg = 'Unknown file type for ' // ncldbn
CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg )
RETURN
END IF
IF ( ( ncldbn (5:5) .eq. '3' ) .or.
+ ( ncldbn (6:6) .eq. '3' ) ) THEN
ncfver = 3
ELSE
ncfver = 4
END IF
C
C* Open the input file.
C
ier = NF_OPEN ( ncldfl, NF_NOWRITE, nf_fid )
IF ( ier .ne. NF_NOERR ) THEN
CALL UT_EMSG ( 0, 'NF_OPEN', ier )
RETURN
END IF
C
C* Get the dimensions of the file.
C
CALL NC_GDIM ( nf_fid, 'image_y', iszy, iergdy )
CALL NC_GDIM ( nf_fid, 'image_x', iszx, iergdx )
IF ( ( iergdy .ne. 0 ) .or. ( iergdx .ne. 0 ) ) RETURN
npoints = iszy * iszx
C
C* Allocate array space based on the file type.
C
ALLOCATE ( rlats ( npoints ) )
ALLOCATE ( rlons ( npoints ) )
ALLOCATE ( rclet ( npoints ) )
ALLOCATE ( rclwp ( npoints ) )
ALLOCATE ( rcltp ( npoints ) )
ALLOCATE ( rclbp ( npoints ) )
ALLOCATE ( rclth ( npoints ) )
ALLOCATE ( rclbh ( npoints ) )
ALLOCATE ( iclph ( npoints ) )
C
C* Read the base time.
C
ier = NF_INQ_VARID ( nf_fid, 'time_offset', nf_vid )
IF ( ier .ne. NF_NOERR ) THEN
CALL UT_EMSG ( 0, 'NF_INQ_VARID for time_offset', ier )
RETURN
END IF
ier = NF_GET_ATT_TEXT ( nf_fid, nf_vid, 'units', basetm )
IF ( ier .ne. NF_NOERR ) THEN
CALL UT_EMSG ( 0, 'NF_GET_ATT_TEXT for time_offset', ier )
RETURN
END IF
CALL ST_INTG ( basetm(15:18), irptdt(1), ier )
IF ( ier .ne. 0 ) THEN
CALL UT_EMSG ( 0, 'ST_INTG for base year', ier )
RETURN
END IF
CALL ST_INTG ( basetm(20:21), irptdt(2), ier )
IF ( ier .ne. 0 ) THEN
CALL UT_EMSG ( 0, 'ST_INTG for base month', ier )
RETURN
END IF
CALL ST_INTG ( basetm(23:24), irptdt(3), ier )
IF ( ier .ne. 0 ) THEN
CALL UT_EMSG ( 0, 'ST_INTG for base day', ier )
RETURN
END IF
idxc = INDEX ( basetm(25:35), ':' )
IF ( idxc .eq. 0 ) THEN
CALL UT_EMSG ( 0, 'INDEX for colon search', idxc )
RETURN
END IF
iptc = 24 + idxc
CALL ST_INTG ( basetm((iptc-2):(iptc-1)), irptdt(4), ier )
IF ( ier .ne. 0 ) THEN
CALL UT_EMSG ( 0, 'ST_INTG for base hour', ier )
RETURN
END IF
CALL ST_INTG ( basetm((iptc+1):(iptc+2)), irptdt(5), ier )
IF ( ier .ne. 0 ) THEN
CALL UT_EMSG ( 0, 'ST_INTG for base minute', ier )
RETURN
END IF
C
C* Read the time offset.
C
ier = NF_GET_VAR_DOUBLE ( nf_fid, nf_vid, offstm )
IF ( ier .ne. NF_NOERR ) THEN
CALL UT_EMSG ( 0, 'NF_GET_VAR_DOUBLE for time_offset', ier )
RETURN
END IF
C
C* Use the base time and time offset to compute the report
C* date-time.
C
nmins = IDNINT ( offstm ) / 60
CALL TI_ADDM ( irptdt, nmins, irptdt, ieradm )
IF ( ieradm .ne. 0 ) THEN
CALL UT_EMSG ( 0, 'TI_ADDM', ieradm )
RETURN
END IF
nsecs = MOD ( IDNINT ( offstm ), 60 )
C
C* Read the latitude values.
C
CALL NC_GRVA ( nf_fid, 'latitude', rlats, rlatmn, rlatmx,
+ iergrv )
IF ( iergrv .ne. 0 ) RETURN
C
C* Read the longitude values.
C
CALL NC_GRVA ( nf_fid, 'longitude', rlons, rlonmn, rlonmx,
+ iergrv )
IF ( iergrv .ne. 0 ) RETURN
C
C* Read the cloud top pressure values (in millibars).
C
CALL NC_GRVA ( nf_fid, 'cloud_top_pressure', rcltp,
+ rcltpmn, rcltpmx, iergrv )
IF ( iergrv .ne. 0 ) RETURN
C
C* Read the cloud base pressure values (in millibars).
C
CALL NC_GRVA ( nf_fid, 'cloud_bottom_pressure', rclbp,
+ rclbpmn, rclbpmx, iergrv )
IF ( iergrv .ne. 0 ) RETURN
C
C* Read the cloud top height values (in kilometers).
C
CALL NC_GRVA ( nf_fid, 'cloud_top_height', rclth,
+ rclthmn, rclthmx, iergrv )
IF ( iergrv .ne. 0 ) RETURN
C
C* Read the cloud base height values (in kilometers).
C
CALL NC_GRVA ( nf_fid, 'cloud_bottom_height', rclbh,
+ rclbhmn, rclbhmx, iergrv )
IF ( iergrv .ne. 0 ) RETURN
C
C* Read the cloud effective temperature values (in degrees K).
C
CALL NC_GRVA ( nf_fid, 'cloud_effective_temperature', rclet,
+ rcletmn, rcletmx, iergrv )
IF ( iergrv .ne. 0 ) RETURN
C
C* Read the cloud phase values (as integer code table entries).
C
ier = NF_INQ_VARID ( nf_fid, 'cloud_phase', nf_vid )
IF ( ier .ne. NF_NOERR ) THEN
CALL UT_EMSG ( 0, 'NF_INQ_VARID for cloud phase', ier )
RETURN
END IF
ier = NF_GET_VAR_INT ( nf_fid, nf_vid, iclph )
IF ( ier .ne. NF_NOERR ) THEN
CALL UT_EMSG ( 0, 'NF_GET_VAR_INT for cloud phase', ier )
RETURN
END IF
ier1 = NF_GET_ATT_INT ( nf_fid, nf_vid, 'valid_min', iclphmn )
ier2 = NF_GET_ATT_INT ( nf_fid, nf_vid, 'valid_max', iclphmx )
IF ( ( ier1 .ne. NF_NOERR ) .or. ( ier2 .ne. NF_NOERR ) ) THEN
CALL UT_EMSG ( 0, 'NF_GET_ATT_INT for cloud phase', ier )
RETURN
END IF
C
C* Read the liquid water path values (in grams per square meter).
C
IF ( ncfver .eq. 3 ) THEN
CALL NC_GRVA ( nf_fid, 'liquid_water_path', rclwp,
+ rclwpmn, rclwpmx, iergrv )
ELSE
CALL NC_GRVA ( nf_fid, 'cloud_lwp_iwp', rclwp,
+ rclwpmn, rclwpmx, iergrv )
END IF
IF ( iergrv .ne. 0 ) RETURN
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
OPEN ( UNIT = iunbfo, FILE = bufrof, FORM = 'UNFORMATTED' )
C
C* Connect the BUFR tables and output files to the BUFR interface.
C
CALL OPENBF ( iunbfo, 'NODX', iunbft )
C
C* Specify compression and use of edition 4 for the BUFR output.
C
CALL CMPMSG ( 'Y' )
CALL PKVS01 ( 'BEN', 4 )
CALL PKVS01 ( 'MTV', 31 )
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* Don't create BUFR output for reports that are more than
C* NHOURS before or 3 hours after the run time.
C
CALL DC_TMCK ( 2, irundt, irptdt, nhours, 180, iertmk )
IF ( iertmk .ne. 0 ) THEN
CALL UT_EMSG ( 0, 'DC_TMCK', ier )
RETURN
END IF
C
C* Generate BUFR output for each pixel which has non-missing data.
C
nmpix = 0
ibfdt = ( irptdt (1) * 1000000 ) + ( irptdt (2) * 10000 ) +
+ ( irptdt (3) * 100 ) + irptdt (4)
DO i = 1, npoints
iph = iclph ( i )
clphok = ( ( iph .ge. iclphmn ) .and.
+ ( iph .le. iclphmx ) .and.
+ ( iph .ne. 0 ) .and. ( iph .ne. 3 ) .and.
+ ( iph .ne. 5 ) )
IF ( ( RVALOK ( rlats ( i ), rlatmn, rlatmx ) ) .and.
+ ( RVALOK ( rlons ( i ), rlonmn, rlonmx ) ) .and.
+ ( ( RVALOK ( rclet ( i ), rcletmn, rcletmx ) ) .or.
+ ( RVALOK ( rclth ( i ), rclthmn, rclthmx ) ) .or.
+ ( RVALOK ( rcltp ( i ), rcltpmn, rcltpmx ) ) .or.
+ ( RVALOK ( rclbh ( i ), rclbhmn, rclbhmx ) ) .or.
+ ( RVALOK ( rclbp ( i ), rclbpmn, rclbpmx ) ) .or.
+ ( RVALOK ( rclwp ( i ), rclwpmn, rclwpmx ) ) .or.
+ ( clphok ) ) ) THEN
nmpix = nmpix + 1
CALL OPENMB ( iunbfo, 'NC012150', ibfdt )
C
C* Report date-time.
C
CALL UT_RIBF ( iunbfo, 'YEAR',
+ FLOAT ( irptdt (1) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'MNTH',
+ FLOAT ( irptdt (2) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'DAYS',
+ FLOAT ( irptdt (3) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'HOUR',
+ FLOAT ( irptdt (4) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'MINU',
+ FLOAT ( irptdt (5) ), ierrbf )
CALL UT_RIBF ( iunbfo, 'SECO',
+ FLOAT ( nsecs ), ierrbf )
C
C* Satellite ID.
C
CALL UT_RIBF ( iunbfo, 'SAID', rsaid, ierrbf )
C
C* Latitude.
C
CALL UT_RIBF ( iunbfo, 'CLATH', rlats ( i ), ierrbf )
C
C* Longitude.
C
CALL UT_RIBF ( iunbfo, 'CLONH', rlons ( i ), ierrbf )
C
C* Meteorological feature significance.
C
CALL UT_RIBF ( iunbfo, 'METFET', 12., ierrbf )
C
C* Cloud phase.
C
IF ( clphok ) THEN
rph = iph
IF ( ( iph .eq. 6 ) .or. ( iph .eq. 7 ) ) rph = 0
CALL UT_RIBF ( iunbfo, 'CLDP', rph, ierrbf )
END IF
C
C* Cloud base pressure.
C
IF ( RVALOK ( rclbp ( i ), rclbpmn, rclbpmx ) )
+ CALL UT_RIBF ( iunbfo, 'CDBP',
+ PR_M100 ( rclbp ( i ) ), ierrbf )
C
C* Cloud top pressure.
C
IF ( RVALOK ( rcltp ( i ), rcltpmn, rcltpmx ) )
+ CALL UT_RIBF ( iunbfo, 'CDTP',
+ PR_M100 ( rcltp ( i ) ), ierrbf )
C
C* Cloud base height.
C
IF ( RVALOK ( rclbh ( i ), rclbhmn, rclbhmx ) )
+ CALL UT_RIBF ( iunbfo, 'HOCB',
+ PR_HGKM ( rclbh ( i ) ), ierrbf )
C
C* Cloud top height.
C
IF ( RVALOK ( rclth ( i ), rclthmn, rclthmx ) )
+ CALL UT_RIBF ( iunbfo, 'HOCT',
+ PR_HGKM ( rclth ( i ) ), ierrbf )
C
C* Equivalent black body temperature.
C
IF ( RVALOK ( rclet ( i ), rcletmn, rcletmx ) )
+ CALL UT_RIBF ( iunbfo, 'EBBTH', rclet ( i ), ierrbf )
C
C* Vertically-integrated liquid water content.
C
IF ( RVALOK ( rclwp ( i ), rclwpmn, rclwpmx ) )
+ CALL UT_RIBF ( iunbfo, 'VILWC',
+ PR_HGMK ( rclwp ( i ) ), ierrbf )
C
C* Write the output to the BUFR file.
C
CALL WRITSB ( iunbfo )
C
END IF
END DO
C
C* Print a count of the number of reports.
C
WRITE ( UNIT = logmsg, FMT = '( A, I7, A )' )
+ 'File contained ', nmpix,' reports'
CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg )
C
C* Make sure that all BUFR output has been written out, and close
C* all remaining open files.
C
CALL CLOSBF ( iunbfo )
CALL FL_CLAL ( iercal )
C
C* Deallocate array space.
C
DEALLOCATE ( rlats )
DEALLOCATE ( rlons )
DEALLOCATE ( rclet )
DEALLOCATE ( rclwp )
DEALLOCATE ( rcltp )
DEALLOCATE ( rclbp )
DEALLOCATE ( rclth )
DEALLOCATE ( rclbh )
DEALLOCATE ( iclph )
C
iret = 0
C*
RETURN
END