diff --git a/schemes/musica/musica_ccpp.F90 b/schemes/musica/musica_ccpp.F90 index d372d2f..d5526f5 100644 --- a/schemes/musica/musica_ccpp.F90 +++ b/schemes/musica/musica_ccpp.F90 @@ -2,7 +2,7 @@ module musica_ccpp use musica_ccpp_micm, only: micm_register, micm_init, micm_run, micm_final use musica_ccpp_namelist, only: filename_of_tuvx_micm_mapping_configuration - use musica_ccpp_tuvx, only: tuvx_init, tuvx_run, tuvx_final + use musica_ccpp_tuvx, only: tuvx_register, tuvx_init, tuvx_run, tuvx_final use musica_util, only: index_mappings_t implicit none @@ -24,29 +24,42 @@ subroutine musica_ccpp_register(micm_solver_type, number_of_grid_cells, & character(len=512), intent(out) :: errmsg integer, intent(out) :: errcode - call micm_register(micm_solver_type, number_of_grid_cells, constituent_props, & + type(ccpp_constituent_properties_t), allocatable :: constituent_props_subset(:) + + call micm_register(micm_solver_type, number_of_grid_cells, constituent_props_subset, & errmsg, errcode) + if (errcode /= 0) return + constituent_props = constituent_props_subset + deallocate(constituent_props_subset) + + call tuvx_register(constituent_props_subset, errmsg, errcode) + if (errcode /= 0) return + constituent_props = [ constituent_props, constituent_props_subset ] end subroutine musica_ccpp_register !> \section arg_table_musica_ccpp_init Argument Table !! \htmlinclude musica_ccpp_init.html subroutine musica_ccpp_init(vertical_layer_dimension, vertical_interface_dimension, & - photolysis_wavelength_grid_interfaces, errmsg, errcode) + photolysis_wavelength_grid_interfaces, & + constituent_props, errmsg, errcode) + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t use ccpp_kinds, only : kind_phys use musica_ccpp_micm, only: micm use musica_ccpp_util, only: has_error_occurred - integer, intent(in) :: vertical_layer_dimension ! (count) - integer, intent(in) :: vertical_interface_dimension ! (count) - real(kind_phys), intent(in) :: photolysis_wavelength_grid_interfaces(:) ! m - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errcode + integer, intent(in) :: vertical_layer_dimension ! (count) + integer, intent(in) :: vertical_interface_dimension ! (count) + real(kind_phys), intent(in) :: photolysis_wavelength_grid_interfaces(:) ! m + type(ccpp_constituent_prop_ptr_t), intent(in) :: constituent_props(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errcode call micm_init(errmsg, errcode) if (errcode /= 0) return call tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & photolysis_wavelength_grid_interfaces, & - micm%user_defined_reaction_rates, errmsg, errcode) + micm%user_defined_reaction_rates, & + constituent_props, errmsg, errcode) if (errcode /= 0) return end subroutine musica_ccpp_init @@ -62,8 +75,9 @@ subroutine musica_ccpp_run(time_step, temperature, pressure, dry_air_density, co geopotential_height_wrt_surface_at_interface, surface_geopotential, & surface_temperature, surface_albedo, & number_of_photolysis_wavelength_grid_sections, & - photolysis_wavelength_grid_interfaces, extraterrestrial_flux, & - standard_gravitational_acceleration, errmsg, errcode) + photolysis_wavelength_grid_interfaces, extraterrestrial_flux, & + standard_gravitational_acceleration, cloud_area_fraction, & + air_pressure_thickness, errmsg, errcode) use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t use ccpp_kinds, only: kind_phys use musica_ccpp_micm, only: number_of_rate_parameters @@ -85,6 +99,8 @@ subroutine musica_ccpp_run(time_step, temperature, pressure, dry_air_density, co real(kind_phys), intent(in) :: photolysis_wavelength_grid_interfaces(:) ! nm real(kind_phys), intent(in) :: extraterrestrial_flux(:) ! photons cm-2 s-1 nm-1 real(kind_phys), intent(in) :: standard_gravitational_acceleration ! m s-2 + real(kind_phys), intent(in) :: cloud_area_fraction(:,:) ! unitless (column, level) + real(kind_phys), intent(in) :: air_pressure_thickness(:,:) ! Pa (column, level) character(len=512), intent(out) :: errmsg integer, intent(out) :: errcode @@ -105,7 +121,8 @@ subroutine musica_ccpp_run(time_step, temperature, pressure, dry_air_density, co photolysis_wavelength_grid_interfaces, & extraterrestrial_flux, & standard_gravitational_acceleration, & - rate_parameters, & + cloud_area_fraction, constituents, & + air_pressure_thickness, rate_parameters, & errmsg, errcode) ! Get the molar mass that is set in the call to instantiate() @@ -150,4 +167,4 @@ subroutine musica_ccpp_final(errmsg, errcode) end subroutine musica_ccpp_final -end module musica_ccpp \ No newline at end of file +end module musica_ccpp diff --git a/schemes/musica/musica_ccpp.meta b/schemes/musica/musica_ccpp.meta index 59efdfe..e69afa3 100644 --- a/schemes/musica/musica_ccpp.meta +++ b/schemes/musica/musica_ccpp.meta @@ -59,6 +59,12 @@ type = real | kind = kind_phys dimensions = (photolysis_wavelength_grid_interface_dimension) intent = in +[ constituent_props ] + standard_name = ccpp_constituent_properties + units = None + type = ccpp_constituent_prop_ptr_t + dimensions = (number_of_ccpp_constituents) + intent = in [ errmsg ] standard_name = ccpp_error_message units = none @@ -165,6 +171,18 @@ type = real | kind = kind_phys dimensions = () intent = in +[ cloud_area_fraction ] + standard_name = cloud_area_fraction + units = fraction + type = real | kind = kind_phys + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + intent = in +[ air_pressure_thickness ] + standard_name = air_pressure_thickness + units = Pa + type = real | kind = kind_phys + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + intent = in [ errmsg ] standard_name = ccpp_error_message units = none diff --git a/schemes/musica/tuvx/musica_ccpp_tuvx.F90 b/schemes/musica/tuvx/musica_ccpp_tuvx.F90 index a972b15..700b894 100644 --- a/schemes/musica/tuvx/musica_ccpp_tuvx.F90 +++ b/schemes/musica/tuvx/musica_ccpp_tuvx.F90 @@ -5,25 +5,36 @@ module musica_ccpp_tuvx use ccpp_kinds, only: kind_phys use musica_ccpp_namelist, only: filename_of_tuvx_configuration use musica_ccpp_util, only: has_error_occurred - use musica_tuvx, only: tuvx_t, grid_t, profile_t + use musica_tuvx, only: tuvx_t, grid_t, profile_t, radiator_t use musica_util, only: mappings_t, index_mappings_t implicit none private - public :: tuvx_init, tuvx_run, tuvx_final - - type(tuvx_t), pointer :: tuvx => null() - type(grid_t), pointer :: height_grid => null() - type(grid_t), pointer :: wavelength_grid => null() - type(profile_t), pointer :: temperature_profile => null() - type(profile_t), pointer :: surface_albedo_profile => null() - type(profile_t), pointer :: extraterrestrial_flux_profile => null() - type(index_mappings_t), pointer :: photolysis_rate_constants_mapping => null( ) - integer :: number_of_photolysis_rate_constants = 0 + public :: tuvx_register, tuvx_init, tuvx_run, tuvx_final + + type(tuvx_t), pointer :: tuvx => null() + type(grid_t), pointer :: height_grid => null() + type(grid_t), pointer :: wavelength_grid => null() + type(profile_t), pointer :: temperature_profile => null() + type(profile_t), pointer :: surface_albedo_profile => null() + type(profile_t), pointer :: extraterrestrial_flux_profile => null() + type(radiator_t), pointer :: cloud_optics => null() + type(index_mappings_t), pointer :: photolysis_rate_constants_mapping => null( ) + integer, parameter :: DEFAULT_NUM_PHOTOLYSIS_RATE_CONSTANTS = 0 + integer :: number_of_photolysis_rate_constants = DEFAULT_NUM_PHOTOLYSIS_RATE_CONSTANTS + integer, parameter :: DEFAULT_INDEX_NOT_FOUND = -1 + character(len=*), parameter :: CLOUD_LIQUID_WATER_CONTENT_LABEL = & + 'cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water' + character(len=*), parameter :: CLOUD_LIQUID_WATER_CONTENT_LONG_NAME = & + 'Cloud water mass mixing ratio with respect to moist air plus all airborne condensates' + character(len=*), parameter :: CLOUD_LIQUID_WATER_CONTENT_UNITS = 'kg kg-1' + real(kind_phys), parameter :: CLOUD_LIQUID_WATER_CONTENT_MOLAR_MASS = 0.018_kind_phys ! kg mol-1 + integer :: index_cloud_liquid_water_content = DEFAULT_INDEX_NOT_FOUND contains + !> Deallocates TUV-x resources subroutine reset_tuvx_map_state( grids, profiles, radiators ) use musica_tuvx, only: grid_map_t, profile_map_t, radiator_map_t @@ -65,6 +76,11 @@ subroutine cleanup_tuvx_resources() extraterrestrial_flux_profile => null() end if + if (associated( cloud_optics )) then + deallocate( cloud_optics ) + cloud_optics => null() + end if + if (associated( photolysis_rate_constants_mapping )) then deallocate( photolysis_rate_constants_mapping ) photolysis_rate_constants_mapping => null() @@ -72,10 +88,44 @@ subroutine cleanup_tuvx_resources() end subroutine cleanup_tuvx_resources + !> Registers constituent properties with the CCPP needed by TUV-x + subroutine tuvx_register(constituent_props, errmsg, errcode) + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + use musica_util, only: error_t + + type(ccpp_constituent_properties_t), allocatable, intent(out) :: constituent_props(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errcode + + allocate(constituent_props(1), stat=errcode) + if (errcode /= 0) then + errmsg = "[MUSICA Error] Failed to allocate memory for constituent properties." + return + end if + + ! Register cloud liquid water content needed for cloud optics calculations + call constituent_props(1)%instantiate( & + std_name = CLOUD_LIQUID_WATER_CONTENT_LABEL, & + long_name = CLOUD_LIQUID_WATER_CONTENT_LONG_NAME, & + units = CLOUD_LIQUID_WATER_CONTENT_UNITS, & + vertical_dim = "vertical_layer_dimension", & + default_value = 0.0_kind_phys, & + min_value = 0.0_kind_phys, & + molar_mass = CLOUD_LIQUID_WATER_CONTENT_MOLAR_MASS, & + advected = .true., & + errcode = errcode, & + errmsg = errmsg & + ) + if (errcode /= 0) return + + end subroutine tuvx_register + !> Initializes TUV-x subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & wavelength_grid_interfaces, micm_rate_parameter_ordering, & - errmsg, errcode) + constituent_props, errmsg, errcode) + use ccpp_const_utils, only: ccpp_const_get_idx + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t use musica_tuvx, only: grid_map_t, profile_map_t, radiator_map_t use musica_util, only: error_t, configuration_t use musica_ccpp_namelist, only: filename_of_tuvx_micm_mapping_configuration @@ -90,13 +140,16 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & use musica_ccpp_tuvx_extraterrestrial_flux, & only: create_extraterrestrial_flux_profile, extraterrestrial_flux_label, & extraterrestrial_flux_unit + use musica_ccpp_tuvx_cloud_optics, & + only: create_cloud_optics_radiator, cloud_optics_label - integer, intent(in) :: vertical_layer_dimension ! (count) - integer, intent(in) :: vertical_interface_dimension ! (count) - real(kind_phys), intent(in) :: wavelength_grid_interfaces(:) ! m - type(mappings_t), intent(in) :: micm_rate_parameter_ordering ! index mappings for MICM rate parameters - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errcode + integer, intent(in) :: vertical_layer_dimension ! (count) + integer, intent(in) :: vertical_interface_dimension ! (count) + real(kind_phys), intent(in) :: wavelength_grid_interfaces(:) ! m + type(mappings_t), intent(in) :: micm_rate_parameter_ordering ! index mappings for MICM rate parameters + type(ccpp_constituent_prop_ptr_t), intent(in) :: constituent_props(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errcode ! local variables type(grid_map_t), pointer :: grids @@ -106,6 +159,16 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & type(mappings_t), pointer :: photolysis_rate_constants_ordering type(error_t) :: error + ! Get needed indices in constituents array + call ccpp_const_get_idx(constituent_props, CLOUD_LIQUID_WATER_CONTENT_LABEL, & + index_cloud_liquid_water_content, errmsg, errcode) + if (errcode /= 0) return + if (index_cloud_liquid_water_content == DEFAULT_INDEX_NOT_FOUND) then + errmsg = "[MUSICA Error] Unable to find index for cloud liquid water content." + errcode = 1 + return + end if + grids => grid_map_t( error ) if (has_error_occurred( error, errmsg, errcode )) return @@ -196,6 +259,21 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & return end if + cloud_optics => create_cloud_optics_radiator( height_grid, wavelength_grid, & + errmsg, errcode ) + if (errcode /= 0) then + call reset_tuvx_map_state( grids, profiles, radiators ) + call cleanup_tuvx_resources() + return + endif + + call radiators%add( cloud_optics, error ) + if (has_error_occurred( error, errmsg, errcode )) then + call reset_tuvx_map_state( grids, profiles, radiators ) + call cleanup_tuvx_resources() + return + end if + tuvx => tuvx_t( trim(filename_of_tuvx_configuration), grids, profiles, & radiators, error ) if (has_error_occurred( error, errmsg, errcode )) then @@ -211,13 +289,17 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & grids => tuvx%get_grids( error ) if (has_error_occurred( error, errmsg, errcode )) then deallocate( tuvx ) + tuvx => null() + call cleanup_tuvx_resources() return end if height_grid => grids%get( height_grid_label, height_grid_unit, error ) if (has_error_occurred( error, errmsg, errcode )) then deallocate( tuvx ) + tuvx => null() call reset_tuvx_map_state( grids, null(), null() ) + call cleanup_tuvx_resources() return end if @@ -225,6 +307,7 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & error ) if (has_error_occurred( error, errmsg, errcode )) then deallocate( tuvx ) + tuvx => null() call reset_tuvx_map_state( grids, null(), null() ) call cleanup_tuvx_resources() return @@ -233,6 +316,7 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & profiles => tuvx%get_profiles( error ) if (has_error_occurred( error, errmsg, errcode )) then deallocate( tuvx ) + tuvx => null() call reset_tuvx_map_state( grids, null(), null() ) call cleanup_tuvx_resources() return @@ -241,6 +325,7 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & temperature_profile => profiles%get( temperature_label, temperature_unit, error ) if (has_error_occurred( error, errmsg, errcode )) then deallocate( tuvx ) + tuvx => null() call reset_tuvx_map_state( grids, profiles, null() ) call cleanup_tuvx_resources() return @@ -249,6 +334,7 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & surface_albedo_profile => profiles%get( surface_albedo_label, surface_albedo_unit, error ) if (has_error_occurred( error, errmsg, errcode )) then deallocate( tuvx ) + tuvx => null() call reset_tuvx_map_state( grids, profiles, null() ) call cleanup_tuvx_resources() return @@ -258,18 +344,39 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & profiles%get( extraterrestrial_flux_label, extraterrestrial_flux_unit, error ) if (has_error_occurred( error, errmsg, errcode )) then deallocate( tuvx ) + tuvx => null() call reset_tuvx_map_state( grids, profiles, null() ) call cleanup_tuvx_resources() return end if - call reset_tuvx_map_state( grids, profiles, null() ) + radiators => tuvx%get_radiators( error ) + if (has_error_occurred( error, errmsg, errcode )) then + deallocate( tuvx ) + tuvx => null() + call reset_tuvx_map_state( grids, profiles, null() ) + call cleanup_tuvx_resources() + return + end if + + cloud_optics => radiators%get( cloud_optics_label, error ) + if (has_error_occurred( error, errmsg, errcode )) then + deallocate( tuvx ) + tuvx => null() + call reset_tuvx_map_state( grids, profiles, radiators ) + call cleanup_tuvx_resources() + return + end if + + call reset_tuvx_map_state( grids, profiles, radiators ) ! 'photolysis_rate_constants_ordering' is a local variable photolysis_rate_constants_ordering => & tuvx%get_photolysis_rate_constants_ordering( error ) if (has_error_occurred( error, errmsg, errcode )) then deallocate( tuvx ) + tuvx => null() + call cleanup_tuvx_resources() return end if number_of_photolysis_rate_constants = photolysis_rate_constants_ordering%size() @@ -277,6 +384,8 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & call config%load_from_file( trim(filename_of_tuvx_micm_mapping_configuration), error ) if (has_error_occurred( error, errmsg, errcode )) then deallocate( tuvx ) + tuvx => null() + call cleanup_tuvx_resources() deallocate( photolysis_rate_constants_ordering ) return end if @@ -286,6 +395,8 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, & micm_rate_parameter_ordering, error ) if (has_error_occurred( error, errmsg, errcode )) then deallocate( tuvx ) + tuvx => null() + call cleanup_tuvx_resources() deallocate( photolysis_rate_constants_ordering ) return end if @@ -304,13 +415,16 @@ subroutine tuvx_run(temperature, dry_air_density, & photolysis_wavelength_grid_interfaces, & extraterrestrial_flux, & standard_gravitational_acceleration, & - rate_parameters, errmsg, errcode) - use musica_util, only: error_t - use musica_ccpp_tuvx_height_grid, only: set_height_grid_values, calculate_heights - use musica_ccpp_tuvx_temperature, only: set_temperature_values - use musica_ccpp_util, only: has_error_occurred - use musica_ccpp_tuvx_surface_albedo, only: set_surface_albedo_values - use musica_ccpp_tuvx_extraterrestrial_flux, only: set_extraterrestrial_flux_values + cloud_area_fraction, constituents, & + air_pressure_thickness, rate_parameters, & + errmsg, errcode) + use musica_util, only: error_t + use musica_ccpp_tuvx_height_grid, only: set_height_grid_values, calculate_heights + use musica_ccpp_tuvx_temperature, only: set_temperature_values + use musica_ccpp_util, only: has_error_occurred + use musica_ccpp_tuvx_surface_albedo, only: set_surface_albedo_values + use musica_ccpp_tuvx_extraterrestrial_flux, only: set_extraterrestrial_flux_values + use musica_ccpp_tuvx_cloud_optics, only: set_cloud_optics_values real(kind_phys), intent(in) :: temperature(:,:) ! K (column, layer) real(kind_phys), intent(in) :: dry_air_density(:,:) ! kg m-3 (column, layer) @@ -323,6 +437,9 @@ subroutine tuvx_run(temperature, dry_air_density, & real(kind_phys), intent(in) :: photolysis_wavelength_grid_interfaces(:) ! nm real(kind_phys), intent(in) :: extraterrestrial_flux(:) ! photons cm-2 s-1 nm-1 real(kind_phys), intent(in) :: standard_gravitational_acceleration ! m s-2 + real(kind_phys), intent(in) :: cloud_area_fraction(:,:) ! unitless (column, layer) + real(kind_phys), intent(in) :: constituents(:,:,:) ! various (column, layer, constituent) + real(kind_phys), intent(in) :: air_pressure_thickness(:,:) ! Pa (column, layer) real(kind_phys), intent(inout) :: rate_parameters(:,:,:) ! various units (column, layer, reaction) character(len=512), intent(out) :: errmsg integer, intent(out) :: errcode @@ -365,6 +482,13 @@ subroutine tuvx_run(temperature, dry_air_density, & surface_temperature(i_col), errmsg, errcode ) if (errcode /= 0) return + call set_cloud_optics_values( cloud_optics, cloud_area_fraction(i_col,:), & + air_pressure_thickness(i_col,:), & + constituents(i_col,:,index_cloud_liquid_water_content), & + reciprocal_of_gravitational_acceleration, & + errmsg, errcode ) + if (errcode /= 0) return + ! temporary values until these are available from the host model solar_zenith_angle = 0.0_kind_phys earth_sun_distance = 1.0_kind_phys @@ -397,13 +521,13 @@ subroutine tuvx_final(errmsg, errcode) errmsg = '' errcode = 0 + call cleanup_tuvx_resources() + if (associated( tuvx )) then deallocate( tuvx ) tuvx => null() end if - call cleanup_tuvx_resources() - end subroutine tuvx_final end module musica_ccpp_tuvx \ No newline at end of file diff --git a/schemes/musica/tuvx/musica_ccpp_tuvx_cloud_optics.F90 b/schemes/musica/tuvx/musica_ccpp_tuvx_cloud_optics.F90 new file mode 100644 index 0000000..8632176 --- /dev/null +++ b/schemes/musica/tuvx/musica_ccpp_tuvx_cloud_optics.F90 @@ -0,0 +1,127 @@ +! Copyright (C) 2024 National Science Foundation-National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +module musica_ccpp_tuvx_cloud_optics + implicit none + + private + public :: create_cloud_optics_radiator, set_cloud_optics_values + + ! This module is used to set the optical properties of clouds in TUV-x. + ! Optical properties are defined as a function of wavelength and height, + ! and include the cloud optical depth, single scattering albedo, + ! and asymmetry parameter. + ! + ! See musica_ccpp_tuvx_height_grid for the definition of the height grid + ! and its mapping to the CAM-SIMA vertical grid. + + !> Label for cloud optical properties in TUV-x + character(len=*), parameter, public :: cloud_optics_label = "clouds" + !> Default value of number of vertical levels + integer, parameter :: DEFAULT_NUM_VERTICAL_LEVELS = 0 + !> Number of vertical levels + integer, protected :: num_vertical_levels = DEFAULT_NUM_VERTICAL_LEVELS + !> Default value of number of wavelength bins + integer, parameter :: DEFAULT_NUM_WAVELENGTH_BINS = 0 + !> Number of wavelength bins + integer, protected :: num_wavelength_bins = DEFAULT_NUM_WAVELENGTH_BINS + +contains + + !> Creates a TUV-x cloud optics radiator from the host-model wavelength grid + function create_cloud_optics_radiator( height_grid, wavelength_grid, & + errmsg, errcode ) result( radiator ) + use musica_ccpp_util, only: has_error_occurred + use musica_tuvx_grid, only: grid_t + use musica_tuvx_radiator, only: radiator_t + use musica_util, only: error_t + + type(grid_t), intent(inout) :: height_grid + type(grid_t), intent(inout) :: wavelength_grid + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errcode + type(radiator_t), pointer :: radiator + + ! local variables + type(error_t) :: error + + num_vertical_levels = height_grid%number_of_sections( error ) + if ( has_error_occurred( error, errmsg, errcode ) ) return + + num_wavelength_bins = wavelength_grid%number_of_sections( error ) + if ( has_error_occurred( error, errmsg, errcode ) ) return + + radiator => radiator_t( cloud_optics_label, height_grid, wavelength_grid, & + error ) + if ( has_error_occurred( error, errmsg, errcode ) ) return + + end function create_cloud_optics_radiator + + !> Sets TUV-x cloud optics values + subroutine set_cloud_optics_values( radiator, cloud_fraction, delta_pressure, & + cloud_liquid_water_content, & + reciprocal_of_gravitational_acceleration, & + errmsg, errcode ) + use ccpp_kinds, only: kind_phys + use musica_ccpp_util, only: has_error_occurred + use musica_tuvx_radiator, only: radiator_t + use musica_util, only: error_t + + type(radiator_t), intent(inout) :: radiator + real(kind_phys), intent(in) :: cloud_fraction(:) ! (unitless) + real(kind_phys), intent(in) :: delta_pressure(:) ! pressure delta about vertical level midpoints (Pa) + real(kind_phys), intent(in) :: cloud_liquid_water_content(:) ! (kg/kg) + real(kind_phys), intent(in) :: reciprocal_of_gravitational_acceleration ! (s^2/m) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errcode + + ! local variables + type(error_t) :: error + real(kind_phys) :: optical_depth(num_vertical_levels) ! working array for cloud optical depth + real(kind_phys) :: cloud_optical_depth(num_vertical_levels, num_wavelength_bins) + integer :: i_level, size_cloud_fraction + + size_cloud_fraction = size(cloud_fraction) + if ( size_cloud_fraction + 1 /= num_vertical_levels ) then + errmsg = "[MUSICA Error] Invalid size of cloud fraction for TUV-x." + errcode = 1 + return + end if + if ( size(delta_pressure) /= size_cloud_fraction ) then + errmsg = "[MUSICA Error] Invalid size of cloud pressure delta for TUV-x." + errcode = 1 + return + end if + if ( size(cloud_liquid_water_content) /= size_cloud_fraction ) then + errmsg = "[MUSICA Error] Invalid size of cloud liquid water content for TUV-x." + errcode = 1 + return + end if + + ! Estimate cloud optical depth (od) [unitless] from cloud fraction (cf) + ! [unitless] and liquid water content (lwc) [kg kg-1] by first calculating + ! the cloud liquid water path (lwp) [kg m-2]: + ! lwp = 1/g * lwc * dP / cf + ! where g is the gravitational acceleration [m s-2] and dP is the change in + ! pressure across the vertical level [Pa]. + ! The cloud optical depth is then estimated as: + ! od = lwp * 155 * cf^1.5 + ! A constant cloud optical depth is used for all wavelengths. + do i_level = 1, size_cloud_fraction + if ( cloud_fraction(i_level) > 0.0_kind_phys ) then + optical_depth(i_level) = ( reciprocal_of_gravitational_acceleration & + * cloud_liquid_water_content(i_level) * delta_pressure(i_level) & + / cloud_fraction(i_level) ) * 155.0_kind_phys * cloud_fraction(i_level)**1.5_kind_phys + else + optical_depth(i_level) = 0.0_kind_phys + end if + end do + do i_level = 1, size_cloud_fraction + cloud_optical_depth(i_level, :) = optical_depth(size_cloud_fraction-i_level+1) + end do + cloud_optical_depth(num_vertical_levels, :) = 0.0_kind_phys + call radiator%set_optical_depths( cloud_optical_depth, error ) + if ( has_error_occurred( error, errmsg, errcode ) ) return + + end subroutine set_cloud_optics_values + +end module musica_ccpp_tuvx_cloud_optics diff --git a/test/musica/CMakeLists.txt b/test/musica/CMakeLists.txt index 8f65f82..0d187cf 100644 --- a/test/musica/CMakeLists.txt +++ b/test/musica/CMakeLists.txt @@ -29,6 +29,7 @@ target_sources(test_musica_api PUBLIC ${MUSICA_CCPP_SOURCES} ${TO_BE_CCPPIZED_SRC_PATH}/ccpp_tuvx_utils.F90 + ${TO_BE_CCPPIZED_SRC_PATH}/ccpp_const_utils.F90 ${CCPP_SRC_PATH}/ccpp_constituent_prop_mod.F90 ${CCPP_SRC_PATH}/ccpp_hash_table.F90 ${CCPP_SRC_PATH}/ccpp_hashable.F90 diff --git a/test/musica/test_musica_api.F90 b/test/musica/test_musica_api.F90 index cc7272b..eb185fb 100644 --- a/test/musica/test_musica_api.F90 +++ b/test/musica/test_musica_api.F90 @@ -144,7 +144,8 @@ subroutine test_chapman() implicit none - integer, parameter :: NUM_SPECIES = 5 + integer, parameter :: NUM_SPECIES = 5 + integer, parameter :: NUM_TUVX_CONSTITUENTS = 1 ! This test requires that the number of grid cells = 4, which is the default ! vector dimension for MICM. This restriction will be removed once ! https://github.com/NCAR/musica/issues/217 is finished. @@ -169,8 +170,12 @@ subroutine test_chapman() real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS) :: temperature ! K real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS) :: pressure ! Pa real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS) :: dry_air_density ! kg m-3 - real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS,NUM_SPECIES) :: constituents ! kg kg-1 - real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS,NUM_SPECIES) :: initial_constituents ! kg kg-1 + real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS) :: cloud_area_fraction ! unitless + real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS) :: air_pressure_thickness ! Pa + real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS, & + NUM_SPECIES+NUM_TUVX_CONSTITUENTS) :: constituents ! kg kg-1 + real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS, & + NUM_SPECIES+NUM_TUVX_CONSTITUENTS) :: initial_constituents ! kg kg-1 type(ccpp_constituent_prop_ptr_t), allocatable :: constituent_props_ptr(:) type(ccpp_constituent_properties_t), allocatable, target :: constituent_props(:) type(ccpp_constituent_properties_t), pointer :: const_prop @@ -205,6 +210,10 @@ subroutine test_chapman() extraterrestrial_flux(:) = & (/ 1.5e13_kind_phys, 1.5e13_kind_phys, 1.4e13_kind_phys, 1.4e13_kind_phys, & 1.3e13_kind_phys, 1.2e13_kind_phys, 1.1e13_kind_phys, 1.0e13_kind_phys /) + cloud_area_fraction(:,1) = (/ 0.1_kind_phys, 0.2_kind_phys /) + cloud_area_fraction(:,2) = (/ 0.3_kind_phys, 0.4_kind_phys /) + air_pressure_thickness(:,1) = (/ 900.0_kind_phys, 905.0_kind_phys /) + air_pressure_thickness(:,2) = (/ 910.0_kind_phys, 915.0_kind_phys /) filename_of_micm_configuration = 'musica_configurations/chapman/micm/config.json' filename_of_tuvx_configuration = 'musica_configurations/chapman/tuvx/config.json' @@ -216,7 +225,7 @@ subroutine test_chapman() stop 3 endif ASSERT(allocated(constituent_props)) - ASSERT(size(constituent_props) == NUM_SPECIES) + ASSERT(size(constituent_props) == NUM_SPECIES+NUM_TUVX_CONSTITUENTS) do i = 1, size(constituent_props) ASSERT(constituent_props(i)%is_instantiated(errcode, errmsg)) ASSERT(errcode == 0) @@ -230,7 +239,9 @@ subroutine test_chapman() (trim(species_name) == "O" .and. molar_mass == 0.0159994_kind_phys .and. .not. is_advected) .or. & (trim(species_name) == "O1D" .and. molar_mass == 0.0159994_kind_phys .and. .not. is_advected) .or. & (trim(species_name) == "O3" .and. molar_mass == 0.0479982_kind_phys .and. is_advected) .or. & - (trim(species_name) == "N2" .and. molar_mass == 0.0280134_kind_phys .and. is_advected) + (trim(species_name) == "N2" .and. molar_mass == 0.0280134_kind_phys .and. is_advected) .or. & + (trim(species_name) == "cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water" .and. & + molar_mass == 0.018_kind_phys .and. is_advected) ASSERT(tmp_bool) call constituent_props(i)%units(units, errcode, errmsg) if (errcode /= 0) then @@ -251,7 +262,7 @@ subroutine test_chapman() end do call musica_ccpp_init(NUM_LAYERS, NUM_LAYERS+1, photolysis_wavelength_grid_interfaces, & - errmsg, errcode) + constituent_props_ptr, errmsg, errcode) if (errcode /= 0) then write(*,*) trim(errmsg) stop 3 @@ -284,6 +295,12 @@ subroutine test_chapman() end do end do end do + ! set initial cloud liquid water mixing ratio to ~1e-3 kg kg-1 + do j = 1, NUM_COLUMNS + do k = 1, NUM_LAYERS + constituents(j,k,NUM_SPECIES+1) = 1.0e-3_kind_phys * (1.0 + 0.1 * (j-1) + 0.01 * (k-1)) + end do + end do initial_constituents(:,:,:) = constituents(:,:,:) write(*,*) "[MUSICA INFO] Initial Time Step" @@ -300,7 +317,7 @@ subroutine test_chapman() geopotential_height_wrt_surface_at_interface, surface_geopotential, & surface_temperature, surface_albedo, num_photolysis_wavelength_grid_sections, & flux_data_photolysis_wavelength_interfaces, extraterrestrial_flux, & - standard_gravitational_acceleration, errmsg, errcode ) + standard_gravitational_acceleration, cloud_area_fraction, air_pressure_thickness, errmsg, errcode ) if (errcode /= 0) then write(*,*) trim(errmsg) stop 3 @@ -332,6 +349,8 @@ subroutine test_chapman() constituents(i,j,O2_index) + constituents(i,j,O3_index) total_O_init = initial_constituents(i,j,O_index) + initial_constituents(i,j,O1D_index) + & initial_constituents(i,j,O2_index) + initial_constituents(i,j,O3_index) + ! cloud liquid water mixing ratio should be unchanged + ASSERT_NEAR(constituents(i,j,NUM_SPECIES+1), initial_constituents(i,j,NUM_SPECIES+1), 1.0e-13) ASSERT_NEAR(total_O, total_O_init, 1.0e-13) end do end do @@ -353,7 +372,8 @@ subroutine test_terminator() implicit none - integer, parameter :: NUM_SPECIES = 2 + integer, parameter :: NUM_SPECIES = 2 + integer, parameter :: NUM_TUVX_CONSTITUENTS = 1 ! This test requires that the number of grid cells = 4, which is the default ! vector dimension for MICM. This restriction will be removed once ! https://github.com/NCAR/musica/issues/217 is finished. @@ -378,8 +398,12 @@ subroutine test_terminator() real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS) :: temperature ! K real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS) :: pressure ! Pa real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS) :: dry_air_density ! kg m-3 - real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS,NUM_SPECIES) :: constituents ! kg kg-1 - real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS,NUM_SPECIES) :: initial_constituents ! kg kg-1 + real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS) :: cloud_area_fraction ! unitless + real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS) :: air_pressure_thickness ! Pa + real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS, & + NUM_SPECIES+NUM_TUVX_CONSTITUENTS) :: constituents ! kg kg-1 + real(kind_phys), dimension(NUM_COLUMNS,NUM_LAYERS, & + NUM_SPECIES+NUM_TUVX_CONSTITUENTS) :: initial_constituents ! kg kg-1 type(ccpp_constituent_prop_ptr_t), allocatable :: constituent_props_ptr(:) type(ccpp_constituent_properties_t), allocatable, target :: constituent_props(:) type(ccpp_constituent_properties_t), pointer :: const_prop @@ -414,6 +438,10 @@ subroutine test_terminator() extraterrestrial_flux(:) = & (/ 1.5e13_kind_phys, 1.5e13_kind_phys, 1.4e13_kind_phys, 1.4e13_kind_phys, & 1.3e13_kind_phys, 1.2e13_kind_phys, 1.1e13_kind_phys, 1.0e13_kind_phys /) + cloud_area_fraction(:,1) = (/ 0.1_kind_phys, 0.2_kind_phys /) + cloud_area_fraction(:,2) = (/ 0.3_kind_phys, 0.4_kind_phys /) + air_pressure_thickness(:,1) = (/ 900.0_kind_phys, 905.0_kind_phys /) + air_pressure_thickness(:,2) = (/ 910.0_kind_phys, 915.0_kind_phys /) filename_of_micm_configuration = 'musica_configurations/terminator/micm/config.json' filename_of_tuvx_configuration = 'musica_configurations/terminator/tuvx/config.json' @@ -425,7 +453,7 @@ subroutine test_terminator() stop 3 endif ASSERT(allocated(constituent_props)) - ASSERT(size(constituent_props) == NUM_SPECIES) + ASSERT(size(constituent_props) == NUM_SPECIES+NUM_TUVX_CONSTITUENTS) do i = 1, size(constituent_props) ASSERT(constituent_props(i)%is_instantiated(errcode, errmsg)) ASSERT(errcode == 0) @@ -436,7 +464,9 @@ subroutine test_terminator() call constituent_props(i)%is_advected(is_advected, errcode, errmsg) ASSERT(errcode == 0) tmp_bool = (trim(species_name) == "Cl" .and. molar_mass == 0.035453_kind_phys .and. is_advected) .or. & - (trim(species_name) == "Cl2" .and. molar_mass == 0.070906_kind_phys .and. is_advected) + (trim(species_name) == "Cl2" .and. molar_mass == 0.070906_kind_phys .and. is_advected) .or. & + (trim(species_name) == "cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water" & + .and. molar_mass == 0.018_kind_phys .and. is_advected) ASSERT(tmp_bool) call constituent_props(i)%units(units, errcode, errmsg) if (errcode /= 0) then @@ -457,7 +487,7 @@ subroutine test_terminator() end do call musica_ccpp_init(NUM_LAYERS, NUM_LAYERS+1, photolysis_wavelength_grid_interfaces, & - errmsg, errcode) + constituent_props_ptr, errmsg, errcode) if (errcode /= 0) then write(*,*) trim(errmsg) stop 3 @@ -481,6 +511,12 @@ subroutine test_terminator() end do end do end do + ! set initial cloud liquid water mixing ratio to ~1e-3 kg kg-1 + do j = 1, NUM_COLUMNS + do k = 1, NUM_LAYERS + constituents(j,k,NUM_SPECIES+1) = 1.0e-3_kind_phys * (1.0 + 0.1 * (j-1) + 0.01 * (k-1)) + end do + end do initial_constituents(:,:,:) = constituents(:,:,:) write(*,*) "[MUSICA INFO] Initial Time Step" @@ -497,7 +533,7 @@ subroutine test_terminator() geopotential_height_wrt_surface_at_interface, surface_geopotential, & surface_temperature, surface_albedo, num_photolysis_wavelength_grid_sections, & flux_data_photolysis_wavelength_interfaces, extraterrestrial_flux, & - standard_gravitational_acceleration, errmsg, errcode ) + standard_gravitational_acceleration, cloud_area_fraction, air_pressure_thickness, errmsg, errcode ) if (errcode /= 0) then write(*,*) trim(errmsg) stop 3 @@ -524,6 +560,8 @@ subroutine test_terminator() total_Cl = constituents(i,j,Cl_index) + constituents(i,j,Cl2_index) total_Cl_init = initial_constituents(i,j,Cl_index) + initial_constituents(i,j,Cl2_index) ASSERT_NEAR(total_Cl, total_Cl_init, 1.0e-13) + ! cloud liquid water should be unchanged + ASSERT_NEAR(constituents(i,j,NUM_SPECIES+1), initial_constituents(i,j,NUM_SPECIES+1), 1.0e-13) end do end do diff --git a/test/musica/tuvx/CMakeLists.txt b/test/musica/tuvx/CMakeLists.txt index ecd179b..21301b0 100644 --- a/test/musica/tuvx/CMakeLists.txt +++ b/test/musica/tuvx/CMakeLists.txt @@ -140,4 +140,34 @@ add_test( WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} ) -add_memory_check_test(test_tuvx_extraterrestrial_flux $ "" ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}) \ No newline at end of file +add_memory_check_test(test_tuvx_extraterrestrial_flux $ "" ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}) + +# Cloud optics +add_executable(test_tuvx_cloud_optics test_tuvx_cloud_optics.F90) + +target_sources(test_tuvx_cloud_optics + PUBLIC + ${MUSICA_SRC_PATH}/tuvx/musica_ccpp_tuvx_height_grid.F90 + ${MUSICA_SRC_PATH}/tuvx/musica_ccpp_tuvx_wavelength_grid.F90 + ${MUSICA_SRC_PATH}/tuvx/musica_ccpp_tuvx_cloud_optics.F90 + ${MUSICA_SRC_PATH}/musica_ccpp_util.F90 + ${CCPP_TEST_SRC_PATH}/ccpp_kinds.F90 +) + +target_link_libraries(test_tuvx_cloud_optics + PRIVATE + musica::musica-fortran +) + +set_target_properties(test_tuvx_cloud_optics + PROPERTIES + LINKER_LANGUAGE Fortran +) + +add_test( + NAME test_tuvx_cloud_optics + COMMAND $ + WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} +) + +add_memory_check_test(test_tuvx_cloud_optics $ "" ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}) diff --git a/test/musica/tuvx/test_tuvx_cloud_optics.F90 b/test/musica/tuvx/test_tuvx_cloud_optics.F90 new file mode 100644 index 0000000..b01e75a --- /dev/null +++ b/test/musica/tuvx/test_tuvx_cloud_optics.F90 @@ -0,0 +1,115 @@ +! Copyright (C) 2024 National Science Foundation-National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +program test_tuvx_cloud_optics + + use musica_ccpp_tuvx_cloud_optics + +#define ASSERT(x) if (.not.(x)) then; write(*,*) "Assertion failed[", __FILE__, ":", __LINE__, "]: x"; stop 1; endif +#define ASSERT_NEAR( a, b, abs_error ) if( (abs(a - b) >= abs_error) .and. (abs(a - b) /= 0.0) ) then; write(*,*) "Assertion failed[", __FILE__, ":", __LINE__, "]: a, b"; stop 1; endif + + real, parameter :: ABS_ERROR = 1e-5 + + call test_create_cloud_optics_radiator() + +contains + + subroutine test_create_cloud_optics_radiator() + + use musica_util, only: error_t + use musica_ccpp_tuvx_height_grid, only: create_height_grid + use musica_ccpp_tuvx_wavelength_grid, only: create_wavelength_grid + use musica_tuvx_grid, only: grid_t + use musica_tuvx_radiator, only: radiator_t + use ccpp_kinds, only: kind_phys + + integer, parameter :: NUM_HOST_HEIGHT_MIDPOINTS = 2 + integer, parameter :: NUM_HOST_HEIGHT_INTERFACES = 3 + integer, parameter :: NUM_WAVELENGTH_MIDPOINTS = 3 + integer, parameter :: NUM_WAVELENGTH_INTERFACES = 4 + real(kind_phys) :: host_wavelength_interfaces(NUM_WAVELENGTH_INTERFACES) = [180.0e-9_kind_phys, 200.0e-9_kind_phys, 240.0e-9_kind_phys, 300.0e-9_kind_phys] + real(kind_phys) :: delta_pressure(NUM_HOST_HEIGHT_MIDPOINTS) = [100.0_kind_phys, 200.0_kind_phys] + real(kind_phys) :: cloud_fraction(NUM_HOST_HEIGHT_MIDPOINTS) = [0.1_kind_phys, 0.0_kind_phys] + real(kind_phys) :: liquid_water_content(NUM_HOST_HEIGHT_MIDPOINTS) = [0.0003_kind_phys, 0.0004_kind_phys] + real(kind_phys) :: reciprocal_of_gravitational_acceleration = 0.1_kind_phys + real(kind_phys) :: cloud_optical_depth(NUM_HOST_HEIGHT_MIDPOINTS+1, NUM_WAVELENGTH_MIDPOINTS) + real(kind_phys) :: expected_cloud_optical_depth(NUM_HOST_HEIGHT_MIDPOINTS+1, NUM_WAVELENGTH_MIDPOINTS) = & + reshape([ 0.0_kind_phys, 0.14704591_kind_phys, 0.0_kind_phys, 0.0_kind_phys, 0.14704591_kind_phys, 0.0_kind_phys, 0.0_kind_phys, 0.14704591_kind_phys, 0.0_kind_phys, 0.0_kind_phys, 0.14704591_kind_phys, 0.0_kind_phys ], & + [ NUM_HOST_HEIGHT_MIDPOINTS+1, NUM_WAVELENGTH_MIDPOINTS ]) + real(kind_phys) :: single_scattering_albedo(NUM_HOST_HEIGHT_MIDPOINTS+1, NUM_WAVELENGTH_MIDPOINTS) + real(kind_phys) :: asymmetry_parameter(NUM_HOST_HEIGHT_MIDPOINTS+1, NUM_WAVELENGTH_MIDPOINTS,1) + type(grid_t), pointer :: height_grid => null() + type(grid_t), pointer :: wavelength_grid => null() + type(radiator_t), pointer :: clouds => null() + type(error_t) :: error + character(len=512) :: errmsg + integer :: errcode + integer :: i + + height_grid => create_height_grid(NUM_HOST_HEIGHT_MIDPOINTS, NUM_HOST_HEIGHT_INTERFACES, & + errmsg, errcode) + ASSERT(errcode == 0) + ASSERT(associated(height_grid)) + + wavelength_grid => create_wavelength_grid(host_wavelength_interfaces, errmsg, errcode) + ASSERT(errcode == 0) + ASSERT(associated(wavelength_grid)) + + clouds => create_cloud_optics_radiator(height_grid, wavelength_grid, errmsg, errcode) + ASSERT(errcode == 0) + ASSERT(associated(clouds)) + + call set_cloud_optics_values(clouds, cloud_fraction, [ 0.0_kind_phys ], & + liquid_water_content, & + reciprocal_of_gravitational_acceleration, & + errmsg, errcode) + ASSERT(errcode == 1) + + call set_cloud_optics_values(clouds, cloud_fraction, delta_pressure, & + [ 1.0_kind_phys ], & + reciprocal_of_gravitational_acceleration, & + errmsg, errcode) + ASSERT(errcode == 1) + + call set_cloud_optics_values(clouds, [ 1.0_kind_phys ], delta_pressure, & + liquid_water_content, & + reciprocal_of_gravitational_acceleration, & + errmsg, errcode) + ASSERT(errcode == 1) + + call set_cloud_optics_values(clouds, cloud_fraction, delta_pressure, & + liquid_water_content, & + reciprocal_of_gravitational_acceleration, & + errmsg, errcode) + ASSERT(errcode == 0) + + call clouds%get_optical_depths(cloud_optical_depth, error) + ASSERT(error%is_success()) + do i = 1, size(cloud_optical_depth, dim=1) + do j = 1, size(cloud_optical_depth, dim=2) + ASSERT_NEAR(cloud_optical_depth(i,j), expected_cloud_optical_depth(i,j), ABS_ERROR) + end do + end do + + call clouds%get_single_scattering_albedos(single_scattering_albedo, error) + ASSERT(error%is_success()) + do i = 1, size(single_scattering_albedo, dim=1) + do j = 1, size(single_scattering_albedo, dim=2) + ASSERT_NEAR(single_scattering_albedo(i,j), 0.0_kind_phys, ABS_ERROR) + end do + end do + + call clouds%get_asymmetry_factors(asymmetry_parameter, error) + ASSERT(error%is_success()) + do i = 1, size(asymmetry_parameter, dim=1) + do j = 1, size(asymmetry_parameter, dim=2) + ASSERT_NEAR(asymmetry_parameter(i,j,1), 0.0_kind_phys, ABS_ERROR) + end do + end do + + deallocate( height_grid ) + deallocate( wavelength_grid ) + deallocate( clouds ) + + end subroutine test_create_cloud_optics_radiator + +end program test_tuvx_cloud_optics diff --git a/test/valgrind.supp b/test/valgrind.supp index ed4ee49..ee1ba85 100644 --- a/test/valgrind.supp +++ b/test/valgrind.supp @@ -35,4 +35,47 @@ fun:__tuvx_core_MOD_constructor fun:InternalCreateTuvx ... +} +{ + Suppress_MUSICA_TUV-x_CreateRadiator + Memcheck:Leak + match-leak-kinds: definite + fun:malloc + fun:__musica_string_MOD_string_assign_char + fun:__tuvx_radiator_from_host_MOD_constructor_char + fun:__tuvx_radiator_from_host_MOD_constructor_string + fun:InternalCreateRadiator + ... +} +{ + Suppress_MUSICA_TUV-x_AddRadiator + Memcheck:Leak + match-leak-kinds: definite + fun:malloc + fun:__tuvx_radiator_from_host_MOD___copy_tuvx_radiator_from_host_Radiator_from_host_t + fun:__tuvx_radiator_warehouse_MOD_add_radiator + fun:InternalAddRadiator + ... +} +{ + Suppress_MUSICA_TUV-x_GetRadiator + Memcheck:Leak + match-leak-kinds: definite + fun:malloc + fun:__tuvx_radiator_from_host_MOD___copy_tuvx_radiator_from_host_Radiator_from_host_t + fun:InternalGetRadiator + ... +} +{ + Suppress_MUSICA_TUV-x_CreateTuvx-RadiatorFromHost + Memcheck:Leak + match-leak-kinds: definite + fun:malloc + fun:__tuvx_radiator_from_host_MOD___copy_tuvx_radiator_from_host_Radiator_from_host_t + fun:__tuvx_radiator_warehouse_MOD_add_radiator + fun:__tuvx_radiator_warehouse_MOD_add_radiators + fun:__tuvx_radiative_transfer_MOD_constructor + fun:__tuvx_core_MOD_constructor + fun:InternalCreateTuvx + ... } \ No newline at end of file diff --git a/to_be_ccppized/ccpp_const_utils.F90 b/to_be_ccppized/ccpp_const_utils.F90 index 902d605..e20aed3 100644 --- a/to_be_ccppized/ccpp_const_utils.F90 +++ b/to_be_ccppized/ccpp_const_utils.F90 @@ -13,13 +13,13 @@ subroutine ccpp_const_get_idx(constituent_props, name, cindex, errmsg, errflg) use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t ! Input arguments - type(ccpp_constituent_prop_ptr_t), pointer, intent(in) :: constituent_props(:) - character(len=*), intent(in) :: name ! constituent name + type(ccpp_constituent_prop_ptr_t), intent(in) :: constituent_props(:) + character(len=*), intent(in) :: name ! constituent name ! Output arguments - integer, intent(out) :: cindex ! global constituent index - character(len=512), intent(out) :: errmsg ! error message - integer, intent(out) :: errflg ! error flag + integer, intent(out) :: cindex ! global constituent index + character(len=512), intent(out) :: errmsg ! error message + integer, intent(out) :: errflg ! error flag ! Local variables integer :: t_cindex