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* M. Weiss/NCEP 03/24 Added processing for HM9V (Himawari-9) * C* M. Weiss/NCEP 03/24 Use new decod_ut library routines, * C* to clean up and simplify logic * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'netcdf.inc' C* CHARACTER*(*) cldt, ncldfl, bufrtb, bufrof C* CHARACTER 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* Extract the basename from the NCLD data file and write it to C* the decoder log. CALL FL_PATH ( ncldfl, nclddn, ncldbn, ierpth ) logmsg = 'NCLD DATA FILENAME: ' // ncldbn CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg ) C* Determine the file type. SELECT CASE ( ncldbn (1:4) ) CASE ( 'G11V' ) rsaid = 255 CASE ( 'G13V' ) rsaid = 257 CASE ( 'G14V' ) rsaid = 258 CASE ( 'G15V' ) rsaid = 259 CASE ( 'G16V' ) rsaid = 270 CASE ( 'G17V' ) rsaid = 271 CASE ( 'G18V' ) rsaid = 272 CASE ( 'G19V' ) rsaid = 273 CASE ( 'HM9V' ) rsaid = 174 CASE DEFAULT logmsg = 'Unknown file type for ' // ncldbn CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg ) RETURN END SELECT C* IF ( ( ncldbn (5:5) .eq. '3' ) .or. + ( ncldbn (6:6) .eq. '3' ) ) THEN ncfver = 3 ELSE ncfver = 4 END IF C* Open the input file. 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* Get the dimensions of the file. 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* Allocate array space based on the file type. 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* Read the time offset. 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* Use the base time and time offset to compute the report C* date-time. 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* Read the latitude values. CALL NC_GRVA ( nf_fid, 'latitude', rlats, rlatmn, rlatmx, + iergrv ) IF ( iergrv .ne. 0 ) RETURN C* Read the longitude values. CALL NC_GRVA ( nf_fid, 'longitude', rlons, rlonmn, rlonmx, + iergrv ) IF ( iergrv .ne. 0 ) RETURN C* Read the cloud top pressure values (in millibars). CALL NC_GRVA ( nf_fid, 'cloud_top_pressure', rcltp, + rcltpmn, rcltpmx, iergrv ) IF ( iergrv .ne. 0 ) RETURN C* Read the cloud base pressure values (in millibars). CALL NC_GRVA ( nf_fid, 'cloud_bottom_pressure', rclbp, + rclbpmn, rclbpmx, iergrv ) IF ( iergrv .ne. 0 ) RETURN C* Read the cloud top height values (in kilometers). CALL NC_GRVA ( nf_fid, 'cloud_top_height', rclth, + rclthmn, rclthmx, iergrv ) IF ( iergrv .ne. 0 ) RETURN C* Read the cloud base height values (in kilometers). CALL NC_GRVA ( nf_fid, 'cloud_bottom_height', rclbh, + rclbhmn, rclbhmx, iergrv ) IF ( iergrv .ne. 0 ) RETURN C* Read the cloud effective temperature values (in degrees K). CALL NC_GRVA ( nf_fid, 'cloud_effective_temperature', rclet, + rcletmn, rcletmx, iergrv ) IF ( iergrv .ne. 0 ) RETURN C* Read the cloud phase values (as integer code table entries). 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* Read the liquid water path values (in grams per square meter). 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* Open the BUFR tables file. CALL FL_SOPN ( bufrtb, iunbft, ierspn ) IF ( ierspn .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ierspn, bufrtb, ierwlg ) RETURN END IF C* Open the BUFR output file. 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* Connect the BUFR tables and output files to the BUFR interface. CALL OPENBF ( iunbfo, 'NODX', iunbft ) C* Specify compression and use of edition 4 for the BUFR output. CALL CMPMSG ( 'Y' ) CALL PKVS01 ( 'BEN', 4 ) CALL PKVS01 ( 'MTV', 31 ) C* Close the BUFR tables file. CALL FL_CLOS ( iunbft, iercls ) IF ( iercls .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg ) END IF C* Get the run date-time. CALL UT_GET_RUNDT ( cldt, irundt, iergrd ) IF ( iergrd .ne. 0 ) RETURN C* Don't create BUFR output for reports that are more than C* NHOURS before or 3 hours after the run time. 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* Generate BUFR output for each pixel which has non-missing data. 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* Report date-time. 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* Satellite ID. CALL UT_RIBF ( iunbfo, 'SAID', rsaid, ierrbf ) C* Latitude. CALL UT_RIBF ( iunbfo, 'CLATH', rlats ( i ), ierrbf ) C* Longitude. CALL UT_RIBF ( iunbfo, 'CLONH', rlons ( i ), ierrbf ) C* Meteorological feature significance. CALL UT_RIBF ( iunbfo, 'METFET', 12., ierrbf ) C* Cloud phase. 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* Cloud base pressure. IF ( RVALOK ( rclbp ( i ), rclbpmn, rclbpmx ) ) + CALL UT_RIBF ( iunbfo, 'CDBP', + PR_M100 ( rclbp ( i ) ), ierrbf ) C* Cloud top pressure. IF ( RVALOK ( rcltp ( i ), rcltpmn, rcltpmx ) ) + CALL UT_RIBF ( iunbfo, 'CDTP', + PR_M100 ( rcltp ( i ) ), ierrbf ) C* Cloud base height. IF ( RVALOK ( rclbh ( i ), rclbhmn, rclbhmx ) ) + CALL UT_RIBF ( iunbfo, 'HOCB', + PR_HGKM ( rclbh ( i ) ), ierrbf ) C* Cloud top height. IF ( RVALOK ( rclth ( i ), rclthmn, rclthmx ) ) + CALL UT_RIBF ( iunbfo, 'HOCT', + PR_HGKM ( rclth ( i ) ), ierrbf ) C* Equivalent black body temperature. IF ( RVALOK ( rclet ( i ), rcletmn, rcletmx ) ) + CALL UT_RIBF ( iunbfo, 'EBBTH', rclet ( i ), ierrbf ) C* Vertically-integrated liquid water content. IF ( RVALOK ( rclwp ( i ), rclwpmn, rclwpmx ) ) + CALL UT_RIBF ( iunbfo, 'VILWC', + PR_HGMK ( rclwp ( i ) ), ierrbf ) C* Write the output to the BUFR file. CALL WRITSB ( iunbfo ) END IF END DO C* Print a count of the number of reports. WRITE ( UNIT = logmsg, FMT = '( A, I7, A )' ) + 'File contained ', nmpix,' reports' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) C* Make sure that all BUFR output has been written out, and close C* all remaining open files. CALL CLOSBF ( iunbfo ) CALL FL_CLAL ( iercal ) C* Deallocate array space. DEALLOCATE ( rlats ) DEALLOCATE ( rlons ) DEALLOCATE ( rclet ) DEALLOCATE ( rclwp ) DEALLOCATE ( rcltp ) DEALLOCATE ( rclbp ) DEALLOCATE ( rclth ) DEALLOCATE ( rclbh ) DEALLOCATE ( iclph ) iret = 0 C* RETURN END