From e6b2c2a7147d622bc209fde29ad4fbb918a62e8e Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 10:55:22 -0600 Subject: [PATCH 01/31] add radiator wrapper --- fortran/tuvx/grid.F90 | 2 +- fortran/tuvx/radiator.F90 | 294 ++++++++++++++++++++++++ fortran/tuvx/radiator_map.F90 | 180 +++++++++++++++ include/musica/tuvx/grid.hpp | 1 - include/musica/tuvx/grid_map.hpp | 1 - include/musica/tuvx/radiator_map.hpp | 95 ++++++++ src/tuvx/interface_grid.F90 | 331 +++++++++++++-------------- src/tuvx/interface_grid_map.F90 | 150 ++++++------ src/tuvx/interface_radiator.F90 | 279 ++++++++++++++++++++++ src/tuvx/interface_radiator_map.F90 | 168 ++++++++++++++ 10 files changed, 1257 insertions(+), 244 deletions(-) create mode 100644 fortran/tuvx/radiator.F90 create mode 100644 fortran/tuvx/radiator_map.F90 create mode 100644 include/musica/tuvx/radiator_map.hpp create mode 100644 src/tuvx/interface_radiator.F90 create mode 100644 src/tuvx/interface_radiator_map.F90 diff --git a/fortran/tuvx/grid.F90 b/fortran/tuvx/grid.F90 index b0a99a04..202b1b94 100644 --- a/fortran/tuvx/grid.F90 +++ b/fortran/tuvx/grid.F90 @@ -82,7 +82,7 @@ end subroutine get_grid_midpoints_c procedure :: set_edges ! Get grid edges procedure :: get_edges - ! Set the grid edges and midpoints + ! Set the grid midpoints procedure :: set_midpoints ! Get the grid midpoints procedure :: get_midpoints diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 new file mode 100644 index 00000000..dc550290 --- /dev/null +++ b/fortran/tuvx/radiator.F90 @@ -0,0 +1,294 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module musica_tuvx_radiator + use iso_c_binding, only: c_ptr, c_null_ptr + + implicit none + +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + + private + public :: radiator_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_radiator_c(radiator_name, height_grid, wavelength_grid, error) & + bind(C, name="CreateRadiator") + use iso_c_binding, only : c_ptr, c_char + use musica_util, only: error_t_c + character(len=1, kind=c_char), intent(in) :: radiator_name(*) + type(c_ptr), intent(in) :: height_grid + type(c_ptr), intent(in) :: wavelength_grid + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_radiator_c + end function create_radiator_c + + subroutine delete_radiator_c(radiator, error) bind(C, name="DeleteRadiator") + use iso_c_binding, only : c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(error_t_c), intent(inout) :: error + end subroutine delete_radiator_c + + subroutine set_optical_depths_c(radiator, optical_depths, num_vertical_layers, & + num_wavelength_bins, error) bind(C, name="SetOpticalDepths") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: optical_depths + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + type(error_t_c), intent(inout) :: error + end subroutine set_optical_depths_c + + subroutine get_optical_depths_c(radiator, optical_depths, num_vertical_layers, & + num_wavelength_bins, error) bind(C, name="GetOpticalDepths") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: optical_depths + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + type(error_t_c), intent(inout) :: error + end subroutine get_optical_depths_c + + subroutine set_single_scattering_albedos_c(radiator, single_scattering_albedos, & + num_vertical_layers, num_wavelength_bins, error) & + bind(C, name="SetSingleScatteringAlbedos") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: single_scattering_albedos + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + type(error_t_c), intent(inout) :: error + end subroutine set_single_scattering_albedos_c + + subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, & + num_vertical_layers, num_wavelength_bins, error) & + bind(C, name="GetSingleScatteringAlbedos") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: single_scattering_albedos + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + type(error_t_c), intent(inout) :: error + end subroutine get_single_scattering_albedos_c + + subroutine set_asymmetry_factor_c(radiator, symmetry_factor, num_vertical_layers, & + num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactor") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: asymmetry_factor + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + integer(c_size_t), value, intent(in) :: num_streams + type(error_t_c), intent(inout) :: error + end subroutine set_asymmetry_factor_c + + subroutine get_asymmetry_factor_c(radiator, symmetry_factor, num_vertical_layers, & + num_wavelength_bins, num_streams, error) bind(C, name="GetAsymmetryFactor") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: asymmetry_factor + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + integer(c_size_t), value, intent(in) :: num_streams + type(error_t_c), intent(inout) :: error + end subroutine get_asymmetry_factor_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: radiator_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Set radiator optical depths + procedure :: set_optical_depths + ! Get radiator optical depths + procedure :: get_optical_depths + ! Set the radiator single scattering albedos + procedure :: set_single_scattering_albedos + ! Get the radiator single scattering albedos + procedure :: get_single_scattering_albedos + ! Set the radiator asymmetry_factor + procedure :: set_asymmetry_factor + ! Get the radiator asymmetry factor + procedure :: get_asymmetry_factor + ! Deallocate the radiator instance + final :: finalize_radiator_t + end type radiator_t + + interface radiator_t + procedure radiator_t_ptr_constructor + procedure radiator_t_constructor + end interface radiator_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a radiator instance that wraps an existing TUV-x radiator + function radiator_t_ptr_constructor(radiator_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: radiator_c_ptr + + ! Return value + type(radiator_t), pointer :: this + + allocate( this ) + this%ptr_ = radiator_c_ptr + + end function radiator_t_ptr_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a radiator instance that allocates a new TUV-x radiator + function radiator_t_constructor(radiator_name, height_grid, wavelength_grid, error) & + result(this) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, to_c_string + + ! Arguments + character(len=*), intent(in) :: radiator_name + real(dk), target, dimension(:,:), intent(in) :: height_grid + real(dk), target, dimension(:,:), intent(in) :: wavelength_grid + type(error_t), intent(inout) :: error + + ! Return value + type(radiator_t), pointer :: this + + type(error_t_c) :: error_c + + allocate( this ) + !! + !! TODO(jiwon) - is it okay to c_loc() 2d array or should i create a new function + !! that does memory layout conversion + !! + this%ptr_ = create_radiator_c(to_c_string(radiator_name), c_loc(height_grid), & + c_loc(avelength_grid), error_c) + error = error_t(error_c) + + end function radiator_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_edges(this, edges, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:), intent(in) :: edges + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edges + + n_edges = size(edges) + + call set_radiator_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + error = error_t(error_c) + + end subroutine set_edges + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_edges(this, edges, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:), intent(inout) :: edges + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edges + + n_edges = size(edges) + + call get_radiator_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + error = error_t(error_c) + + end subroutine get_edges + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_midpoints(this, midpoints, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:), intent(in) :: midpoints + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoints + + n_midpoints = size(midpoints) + + call set_radiator_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + error = error_t(error_c) + + end subroutine set_midpoints + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_midpoints(this, midpoints, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:), intent(inout) :: midpoints + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoints + + n_midpoints = size(midpoints) + + call get_radiator_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + error = error_t(error_c) + + end subroutine get_midpoints + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Deallocate the radiator instance + subroutine finalize_radiator_t(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(radiator_t), intent(inout) :: this + + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error + + if (c_associated(this%ptr_)) then + call delete_radiator_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end if + + end subroutine finalize_radiator_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_tuvx_radiator \ No newline at end of file diff --git a/fortran/tuvx/radiator_map.F90 b/fortran/tuvx/radiator_map.F90 new file mode 100644 index 00000000..f9cbdd61 --- /dev/null +++ b/fortran/tuvx/radiator_map.F90 @@ -0,0 +1,180 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module musica_tuvx_radiator_map + use iso_c_binding, only: c_ptr, c_null_ptr + + implicit none + +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + + private + public :: radiator_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_radiator_map_c(error) bind(C, name="CreateRadiatorMap") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_radiator_map_c + end function create_radiator_map_c + + subroutine delete_radiator_map_c(radiator_map, error) & + bind(C, name="DeleteRadiatorMap") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator_map + type(error_t_c), intent(inout) :: error + end subroutine delete_radiator_map_c + + subroutine add_radiator_c(radiator_map, radiator, error) & + bind(C, name="AddRadiator") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator_map + type(c_ptr), value, intent(in) :: radiator + type(error_t_c), intent(inout) :: error + end subroutine add_radiator_c + + function get_radiator_c(radiator_map, radiator_name, error) & + bind(C, name="GetRadiator") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr, c_char + type(c_ptr), value, intent(in) :: radiator_map + character(len=1, kind=c_char), intent(in) :: radiator_name(*) + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_radiator_c + end function get_radiator_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: radiator_map_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Adds a radiator to the radiator map + procedure :: add => add_radiator + ! Get a radiator given its name + procedure :: get => get_radiator + ! Deallocate the radiator map instance + final :: finalize_radiator_map_t + end type radiator_map_t + + interface radiator_map_t + procedure radiator_map_t_ptr_constructor + procedure radiator_map_t_constructor + end interface radiator_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Wraps an existing radiator map + function radiator_map_t_ptr_constructor(radiator_map_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: radiator_map_c_ptr + ! Return value + type(radiator_map_t), pointer :: this + + allocate( this ) + this%ptr_ = radiator_map_c_ptr + + end function radiator_map_t_ptr_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Creates a new radiator map + function radiator_map_t_constructor(error) result(this) + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(error_t), intent(inout) :: error + + ! Return value + type(radiator_map_t), pointer :: this + + ! Local variables + type(error_t_c) :: error_c + + allocate( this ) + this%ptr_ = create_radiator_map_c(error_c) + error = error_t(error_c) + + end function radiator_map_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a radiator to a radiator map + subroutine add_radiator(this, radiator, error) + use musica_tuvx_radiator, only: radiator_t + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + class(radiator_map_t), intent(inout) :: this + type(radiator_t), intent(in) :: radiator + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + call add_radiator_c(this%ptr_, radiator%ptr_, error_c) + error = error_t(error_c) + + end subroutine add_radiator + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a radiator given its name + function get_radiator(this, radiator_name, error) result(radiator) + use iso_c_binding, only: c_char + use musica_tuvx_radiator, only : radiator_t + use musica_util, only: error_t, error_t_c, to_c_string + + ! Arguments + class(radiator_map_t), intent(in) :: this + character(len=*), intent(in) :: radiator_name + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + ! Return value + type(radiator_t), pointer :: radiator + + radiator => radiator_t(get_radiator_c(this%ptr_, to_c_string(radiator_name), & + error_c)) + + error = error_t(error_c) + + end function get_radiator + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Deallocates the radiator map instance + subroutine finalize_radiator_map_t(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(radiator_map_t), intent(inout) :: this + + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error + + if (c_associated(this%ptr_)) then + call delete_radiator_map_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end if + + end subroutine finalize_radiator_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_tuvx_radiator_map diff --git a/include/musica/tuvx/grid.hpp b/include/musica/tuvx/grid.hpp index 3d52174e..c8bb4a60 100644 --- a/include/musica/tuvx/grid.hpp +++ b/include/musica/tuvx/grid.hpp @@ -2,7 +2,6 @@ // SPDX-License-Identifier: Apache-2.0 #pragma once -#include #include #include diff --git a/include/musica/tuvx/grid_map.hpp b/include/musica/tuvx/grid_map.hpp index 48a02e01..b1d95ae0 100644 --- a/include/musica/tuvx/grid_map.hpp +++ b/include/musica/tuvx/grid_map.hpp @@ -3,7 +3,6 @@ #pragma once #include -#include #include #include diff --git a/include/musica/tuvx/radiator_map.hpp b/include/musica/tuvx/radiator_map.hpp new file mode 100644 index 00000000..980b65a7 --- /dev/null +++ b/include/musica/tuvx/radiator_map.hpp @@ -0,0 +1,95 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include +#include + +#include +#include +#include + +namespace musica +{ + + /// @brief A radiator map struct used to access radiator information in tuvx + struct RadiatorMap + { + RadiatorMap(void *radiator_map) + : radiator_map_(radiator_map), + owns_radiator_map_(false) + { + } + + /// @brief @brief Creates a radiator map instance + /// @param error The error struct to indicate success or failure + RadiatorMap(Error *error); + + ~RadiatorMap(); + + /// @brief Adds a radiator to the radiator map + /// @param radiator The radiator to add + /// @param error The error struct to indicate success or failure + void AddRadiator(Radiator *radiator, Error *error); + + /// @brief Returns a radiator. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on to + /// be transparent to downstream projects + /// @param radiator_name The name of the radiator + /// @param error The error struct to indicate success or failure + /// @return a radiator pointer + Radiator *GetRadiator(const char *radiator_name, Error *error); + + private: + void *radiator_map_; + bool owns_radiator_map_; + }; + +#ifdef __cplusplus + extern "C" + { +#endif + + // The external C API for TUVX + // callable by wrappers in other languages + + /// @brief Creates a radiator map instance + /// @param error The error struct to indicate success or failure + /// @return a pointer to the radiator map + RadiatorMap *CreateRadiatorMap(Error *error); + + /// @brief Deletes a radiator map instance + /// @param radiator_map The radiator map to delete + /// @param error The error struct to indicate success or failure + void DeleteRadiatorMap(RadiatorMap *radiator_map, Error *error); + + /// @brief Adds a radiator to the radiator map + /// @param radiator_map The radiator map to add the radiator to + /// @param radiator The radiator to add + /// @param error The error struct to indicate success or failure + void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error); + + /// @brief Returns a radiator from the radiator map + /// @param radiator_map The radiator map to get the radiator from + /// @param radiator_name The name of the radiator + /// @param error The error struct to indicate success or failure + /// @return The radiator pointer, or nullptr if the radiator is not found + Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error); + + // INTERNAL USE. If tuvx ever gets rewritten in C++, these functions will + // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will + // not need to change + void *InternalCreateRadiatorMap(int *error_code); + void InternalDeleteRadiatordMap(void *radiator_map, int *error_code); + void InternalAddRadiator(void *radiator_map, void *radiator, int *error_code); + void *InternalGetRadiator( + void *radiator_map, + const char *radiator_name, + std::size_t radiator_name_length, + int *error_code); + void *InternalGetRadiatorUpdaterFromMap(void *radiator_map, void *radiator, int *error_code); + +#ifdef __cplusplus + } +#endif + +} // namespace musica diff --git a/src/tuvx/interface_grid.F90 b/src/tuvx/interface_grid.F90 index 62bb09a1..6e211695 100644 --- a/src/tuvx/interface_grid.F90 +++ b/src/tuvx/interface_grid.F90 @@ -16,12 +16,11 @@ module tuvx_interface_grid function internal_create_grid(grid_name, grid_name_length, units, & units_length, num_sections, error_code) & bind(C, name="InternalCreateGrid") result(grid) - use iso_c_binding, only: c_ptr, c_f_pointer, c_char, c_loc, c_size_t, & - c_int + use iso_c_binding, only: c_ptr, c_f_pointer, c_char, c_loc, c_size_t, c_int use musica_tuvx_util, only: to_f_string use musica_string, only: string_t use tuvx_grid_from_host, only: grid_from_host_t - + ! arguments type(c_ptr) :: grid character(kind=c_char, len=1), dimension(*), intent(in) :: grid_name @@ -30,12 +29,12 @@ function internal_create_grid(grid_name, grid_name_length, units, & integer(kind=c_size_t), intent(in), value :: units_length integer(kind=c_size_t), intent(in), value :: num_sections integer(kind=c_int), intent(out) :: error_code - + ! variables type(grid_from_host_t), pointer :: f_grid type(string_t) :: f_name, f_units integer :: i - + allocate(character(len=grid_name_length) :: f_name%val_) do i = 1, grid_name_length f_name%val_(i:i) = grid_name(i) @@ -48,190 +47,190 @@ function internal_create_grid(grid_name, grid_name_length, units, & f_grid => grid_from_host_t(f_name, f_units, int(num_sections)) grid = c_loc(f_grid) - + end function internal_create_grid +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_grid(grid, error_code) & + bind(C, name="InternalDeleteGrid") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + + ! arguments + type(c_ptr), value, intent(in) :: grid + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_t), pointer :: f_grid + + call c_f_pointer(grid, f_grid) + if (associated(f_grid)) then + deallocate(f_grid) + end if + + end subroutine internal_delete_grid + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function internal_get_grid_updater(grid, error_code) & - bind(C, name="InternalGetGridUpdater") result(updater) - use iso_c_binding, only: c_ptr, c_f_pointer, c_loc, c_int - use tuvx_grid_from_host, only: grid_from_host_t, grid_updater_t - - ! arguments - type(c_ptr), value, intent(in) :: grid - integer(kind=c_int), intent(out) :: error_code - - ! output - type(c_ptr) :: updater - - ! variables - type(grid_from_host_t), pointer :: f_grid - type(grid_updater_t), pointer :: f_updater - - call c_f_pointer(grid, f_grid) - allocate(f_updater, source = grid_updater_t(f_grid)) - updater = c_loc(f_updater) - + bind(C, name="InternalGetGridUpdater") result(updater) + use iso_c_binding, only: c_ptr, c_f_pointer, c_loc, c_int + use tuvx_grid_from_host, only: grid_from_host_t, grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: grid + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(grid_from_host_t), pointer :: f_grid + type(grid_updater_t), pointer :: f_updater + + call c_f_pointer(grid, f_grid) + allocate(f_updater, source = grid_updater_t(f_grid)) + updater = c_loc(f_updater) + end function internal_get_grid_updater !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_delete_grid(grid, error_code) & - bind(C, name="InternalDeleteGrid") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int - - ! arguments - type(c_ptr), value, intent(in) :: grid - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(grid_t), pointer :: f_grid - - call c_f_pointer(grid, f_grid) - if (associated(f_grid)) then - deallocate(f_grid) - end if - - end subroutine internal_delete_grid + subroutine internal_delete_grid_updater(updater, error_code) & + bind(C, name="InternalDeleteGridUpdater") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + use tuvx_grid_from_host, only: grid_updater_t -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! arguments + type(c_ptr), value, intent(in) :: updater + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_updater + + call c_f_pointer(updater, f_updater) + if (associated(f_updater)) then + deallocate(f_updater) + end if - subroutine internal_delete_grid_updater(updater, error_code) & - bind(C, name="InternalDeleteGridUpdater") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int - use tuvx_grid_from_host, only: grid_updater_t - - ! arguments - type(c_ptr), value, intent(in) :: updater - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(grid_updater_t), pointer :: f_updater - - call c_f_pointer(updater, f_updater) - if (associated(f_updater)) then - deallocate(f_updater) - end if - - end subroutine internal_delete_grid_updater + end subroutine internal_delete_grid_updater !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_set_edges(grid_updater, edges, num_edges, error_code) & - bind(C, name="InternalSetEdges") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t - use musica_constants, only: dk => musica_dk - use tuvx_grid_from_host, only: grid_updater_t - - ! arguments - type(c_ptr), value, intent(in) :: grid_updater - type(c_ptr), value, intent(in) :: edges - integer(kind=c_size_t), intent(in), value :: num_edges - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(grid_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_edges(:) - - call c_f_pointer(grid_updater, f_updater) - call c_f_pointer(edges, f_edges, [num_edges]) - - if (size(f_updater%grid_%edge_) /= num_edges) then - error_code = 1 - return - end if - f_updater%grid_%edge_(:) = f_edges(:) - - end subroutine internal_set_edges + subroutine internal_set_edges(grid_updater, edges, num_edges, error_code) & + bind(C, name="InternalSetEdges") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_grid_from_host, only: grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: grid_updater + type(c_ptr), value, intent(in) :: edges + integer(kind=c_size_t), intent(in), value :: num_edges + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_edges(:) + + call c_f_pointer(grid_updater, f_updater) + call c_f_pointer(edges, f_edges, [num_edges]) + + if (size(f_updater%grid_%edge_) /= num_edges) then + error_code = 1 + return + end if + f_updater%grid_%edge_(:) = f_edges(:) + + end subroutine internal_set_edges !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_get_edges(grid_updater, edges, num_edges, error_code) & - bind(C, name="InternalGetEdges") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t - use musica_constants, only: dk => musica_dk - use tuvx_grid_from_host, only: grid_updater_t - - ! arguments - type(c_ptr), value, intent(in) :: grid_updater - type(c_ptr), value, intent(in) :: edges - integer(kind=c_size_t), intent(in), value :: num_edges - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(grid_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_edges(:) - - call c_f_pointer(grid_updater, f_updater) - call c_f_pointer(edges, f_edges, [num_edges]) - - if (size(f_updater%grid_%edge_) /= num_edges) then - error_code = 1 - return - end if - f_edges(:) = f_updater%grid_%edge_(:) - - end subroutine internal_get_edges + subroutine internal_get_edges(grid_updater, edges, num_edges, error_code) & + bind(C, name="InternalGetEdges") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_grid_from_host, only: grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: grid_updater + type(c_ptr), value, intent(in) :: edges + integer(kind=c_size_t), intent(in), value :: num_edges + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_edges(:) + + call c_f_pointer(grid_updater, f_updater) + call c_f_pointer(edges, f_edges, [num_edges]) + + if (size(f_updater%grid_%edge_) /= num_edges) then + error_code = 1 + return + end if + f_edges(:) = f_updater%grid_%edge_(:) + + end subroutine internal_get_edges !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_set_midpoints(grid_updater, midpoints, num_midpoints, & - error_code) bind(C, name="InternalSetMidpoints") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double, c_size_t - use musica_constants, only: dk => musica_dk - use tuvx_grid_from_host, only: grid_updater_t - - ! arguments - type(c_ptr), value, intent(in) :: grid_updater - type(c_ptr), value, intent(in) :: midpoints - integer(kind=c_int), intent(in), value :: num_midpoints - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(grid_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_midpoints(:) - - call c_f_pointer(grid_updater, f_updater) - call c_f_pointer(midpoints, f_midpoints, [num_midpoints]) - - if (size(f_updater%grid_%mid_) /= num_midpoints) then - error_code = 1 - return - end if - f_updater%grid_%mid_(:) = f_midpoints(:) - - end subroutine internal_set_midpoints + subroutine internal_set_midpoints(grid_updater, midpoints, num_midpoints, & + error_code) bind(C, name="InternalSetMidpoints") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_grid_from_host, only: grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: grid_updater + type(c_ptr), value, intent(in) :: midpoints + integer(kind=c_int), intent(in), value :: num_midpoints + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_midpoints(:) + + call c_f_pointer(grid_updater, f_updater) + call c_f_pointer(midpoints, f_midpoints, [num_midpoints]) + + if (size(f_updater%grid_%mid_) /= num_midpoints) then + error_code = 1 + return + end if + f_updater%grid_%mid_(:) = f_midpoints(:) + + end subroutine internal_set_midpoints !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_get_midpoints(grid_updater, midpoints, num_midpoints, & - error_code) bind(C, name="InternalGetMidpoints") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double, c_size_t - use musica_constants, only: dk => musica_dk - use tuvx_grid_from_host, only: grid_updater_t - - ! arguments - type(c_ptr), value, intent(in) :: grid_updater - type(c_ptr), value, intent(in) :: midpoints - integer(kind=c_int), intent(in), value :: num_midpoints - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(grid_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_midpoints(:) - - call c_f_pointer(grid_updater, f_updater) - call c_f_pointer(midpoints, f_midpoints, [num_midpoints]) - - if (size(f_updater%grid_%mid_) /= num_midpoints) then - error_code = 1 - return - end if - f_midpoints(:) = f_updater%grid_%mid_(:) - - end subroutine internal_get_midpoints + subroutine internal_get_midpoints(grid_updater, midpoints, num_midpoints, & + error_code) bind(C, name="InternalGetMidpoints") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_grid_from_host, only: grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: grid_updater + type(c_ptr), value, intent(in) :: midpoints + integer(kind=c_int), intent(in), value :: num_midpoints + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_midpoints(:) + + call c_f_pointer(grid_updater, f_updater) + call c_f_pointer(midpoints, f_midpoints, [num_midpoints]) + + if (size(f_updater%grid_%mid_) /= num_midpoints) then + error_code = 1 + return + end if + f_midpoints(:) = f_updater%grid_%mid_(:) + + end subroutine internal_get_midpoints !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -end module tuvx_interface_grid +end module tuvx_interface_grid \ No newline at end of file diff --git a/src/tuvx/interface_grid_map.F90 b/src/tuvx/interface_grid_map.F90 index 977eca1a..c0eaf250 100644 --- a/src/tuvx/interface_grid_map.F90 +++ b/src/tuvx/interface_grid_map.F90 @@ -17,31 +17,31 @@ module tuvx_interface_grid_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_create_grid_map(error_code) result(grid_map) & - bind(C, name="InternalCreateGridMap") - use iso_c_binding, only: c_ptr, c_int, c_null_ptr - use tuvx_grid_warehouse, only: grid_warehouse_t - - ! arguments - integer(kind=c_int), intent(out) :: error_code - - ! result - type(c_ptr) :: grid_map - - ! variables - class(grid_warehouse_t), pointer :: f_grid_warehouse - - f_grid_warehouse => grid_warehouse_t() - select type(f_grid_warehouse) - type is(grid_warehouse_t) - grid_map = c_loc(f_grid_warehouse) - error_code = 0 - class default - error_code = 1 - grid_map = c_null_ptr - end select - - end function internal_create_grid_map + function internal_create_grid_map(error_code) result(grid_map) & + bind(C, name="InternalCreateGridMap") + use iso_c_binding, only: c_ptr, c_int, c_null_ptr + use tuvx_grid_warehouse, only: grid_warehouse_t + + ! arguments + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: grid_map + + ! variables + class(grid_warehouse_t), pointer :: f_grid_warehouse + + f_grid_warehouse => grid_warehouse_t() + select type(f_grid_warehouse) + type is(grid_warehouse_t) + grid_map = c_loc(f_grid_warehouse) + error_code = 0 + class default + error_code = 1 + grid_map = c_null_ptr + end select + + end function internal_create_grid_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -90,56 +90,56 @@ end subroutine internal_add_grid !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function interal_get_grid(grid_map, c_grid_name, c_grid_name_length, & - c_grid_units, c_grid_units_length, error_code) & - result(grid_ptr) bind(C, name="InternalGetGrid") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_char, c_size_t, & - c_null_ptr, c_loc - use tuvx_grid_from_host, only: grid_from_host_t - - ! arguments - type(c_ptr), intent(in), value :: grid_map - character(len=1, kind=c_char), dimension(*), intent(in) :: c_grid_name - integer(kind=c_size_t), value :: c_grid_name_length - character(len=1, kind=c_char), dimension(*), intent(in) :: c_grid_units - integer(kind=c_size_t), value :: c_grid_units_length - integer(kind=c_int), intent(out) :: error_code - - ! variables - class(grid_t), pointer :: f_grid - type(grid_warehouse_t), pointer :: grid_warehouse - character(len=:), allocatable :: f_grid_name - character(len=:), allocatable :: f_grid_units - integer :: i - - ! result - type(c_ptr) :: grid_ptr - - allocate(character(len=c_grid_name_length) :: f_grid_name) - do i = 1, c_grid_name_length - f_grid_name(i:i) = c_grid_name(i) - end do - - allocate(character(len=c_grid_units_length) :: f_grid_units) - do i = 1, c_grid_units_length - f_grid_units(i:i) = c_grid_units(i) - end do - - call c_f_pointer(grid_map, grid_warehouse) - - f_grid => grid_warehouse%get_grid(f_grid_name, f_grid_units) - - select type(f_grid) - type is(grid_from_host_t) - error_code = 0 - grid_ptr = c_loc(f_grid) - class default - error_code = 1 - deallocate(f_grid) - grid_ptr = c_null_ptr - end select - - end function interal_get_grid + function interal_get_grid(grid_map, c_grid_name, c_grid_name_length, & + c_grid_units, c_grid_units_length, error_code) & + result(grid_ptr) bind(C, name="InternalGetGrid") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_char, c_size_t, & + c_null_ptr, c_loc + use tuvx_grid_from_host, only: grid_from_host_t + + ! arguments + type(c_ptr), intent(in), value :: grid_map + character(len=1, kind=c_char), dimension(*), intent(in) :: c_grid_name + integer(kind=c_size_t), value :: c_grid_name_length + character(len=1, kind=c_char), dimension(*), intent(in) :: c_grid_units + integer(kind=c_size_t), value :: c_grid_units_length + integer(kind=c_int), intent(out) :: error_code + + ! variables + class(grid_t), pointer :: f_grid + type(grid_warehouse_t), pointer :: grid_warehouse + character(len=:), allocatable :: f_grid_name + character(len=:), allocatable :: f_grid_units + integer :: i + + ! result + type(c_ptr) :: grid_ptr + + allocate(character(len=c_grid_name_length) :: f_grid_name) + do i = 1, c_grid_name_length + f_grid_name(i:i) = c_grid_name(i) + end do + + allocate(character(len=c_grid_units_length) :: f_grid_units) + do i = 1, c_grid_units_length + f_grid_units(i:i) = c_grid_units(i) + end do + + call c_f_pointer(grid_map, grid_warehouse) + + f_grid => grid_warehouse%get_grid(f_grid_name, f_grid_units) + + select type(f_grid) + type is(grid_from_host_t) + error_code = 0 + grid_ptr = c_loc(f_grid) + class default + error_code = 1 + deallocate(f_grid) + grid_ptr = c_null_ptr + end select + + end function interal_get_grid !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/tuvx/interface_radiator.F90 b/src/tuvx/interface_radiator.F90 new file mode 100644 index 00000000..6588a298 --- /dev/null +++ b/src/tuvx/interface_radiator.F90 @@ -0,0 +1,279 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_interface_radiator + use tuvx_radiator, only : radiator_t + + implicit none + + private + + contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_create_radiator(radiator_name, radiator_name_length, height_grid, & + wavelength_grid, error_code) result(radiator) & + bind(C, name="InternalCreateRadiator") + use iso_c_binding, only: c_ptr, c_f_pointer, c_char, c_loc, c_size_t, c_int + use musica_string, only: string_t + + use tuvx_radiator_from_host, only: radiator_from_host_t + use tuvx_grid, only : grid_t + + ! arguments + type(c_ptr) :: radiator + character(kind=c_char, len=1), dimension(*), intent(in) :: radiator_name + integer(kind=c_size_t), intent(in), value :: radiator_name_length + type(c_ptr), intent(in), value :: height_grid + type(c_ptr), intent(in), value :: wavelength_grid + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_from_host_t), pointer :: f_radiator + type(string_t) :: f_name + type(grid_t) :: f_height_grid + type(grid_t) :: f_wavelength_grid + + allocate(character(len=radiator_name_length) :: f_name%val_) + do i = 1, radiator_name_length + f_name%val_(i:i) = radiator_name(i) + end do + + call c_f_pointer(height_grid, f_height_grid) + call c_f_pointer(wavelength_grid, f_wavelength_grid) + f_radiator => radiator_from_host_t(f_name, f_height_grid, f_wavelength_grid) + radiator = c_loc(f_radiator) + + end function internal_create_radiator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_radiator(radiator, error_code) & + bind(C, name="InternalDeleteRadiator") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + + ! arguments + type(c_ptr), value, intent(in) :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_t), pointer :: f_radiator + + call c_f_pointer(radiator, f_radiator) + if (associated(f_radiator)) then + deallocate(f_radiator) + end if + + end subroutine internal_delete_radiator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_radiator_updater(radiator, error_code) & + bind(C, name="InternalGetRadiatorUpdater") result(updater) + use iso_c_binding, only: c_ptr, c_f_pointer, c_loc, c_int + use tuvx_radiator_from_host, only: radiator_from_host_t, radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(radiator_from_host_t), pointer :: f_radiator + type(radiator_updater_t), pointer :: f_updater + + call c_f_pointer(radiator, f_radiator) + allocate(f_updater, source = radiator_updater_t(f_radiator)) + updater = c_loc(f_updater) + + end function internal_get_radiator_updater + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_radiator_updater(updater, error_code) & + bind(C, name="InternalDeleteRadiatorUpdater") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: updater + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_radiator_t), pointer :: f_updater + + call c_f_pointer(updater, f_updater) + if (associated(f_updater)) then + deallocate(f_updater) + end if + + end subroutine internal_delete_radiator_updater + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_optical_depths(radiator_updater, optical_depths, num_vertical_layers, & + num_wavelength_bins, error_code) & + bind(C, name="InternalSetOpticalDepths") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: optical_depths + integer(kind=c_size_t), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: num_wavelength_bins + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_optical_depths(:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(optical_depths, f_optical_depths, [num_vertical_layers, num_wavelength_bins]) + + if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) .or. & + (size(f_updater%radiator_%state_%layer_OD_, 2) /= num_wavelength_bins)) then + error_code = 1 + return + end if + f_updater%radiator_%state_%layer_OD_(:,:) = f_optical_depths(:,:) + + end subroutine internal_set_optical_depths + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_get_optical_depths(radiator_updater, optical_depths, num_vertical_layers, & + num_wavelength_bins, error_code) & + bind(C, name="InternalGetOpticalDepths") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: optical_depths + integer(kind=c_size_t), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: num_wavelength_bins + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_optical_depths(:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(optical_depths, f_optical_depths, [num_vertical_layers, num_wavelength_bins]) + + if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) .or. & + (size(f_updater%radiator_%state_%layer_OD_, 2) /= num_wavelength_bins)) then + error_code = 1 + return + end if + f_optical_depths(:,:) = f_updater%radiator_%state_%layer_OD_(:,:) + + end subroutine internal_get_optical_depths + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_single_scattering_albedos(radiator_updater, single_scattering_albedos, & + num_vertical_layers, num_wavelength_bins, error_code) & + bind(C, name="InternalSetSingleScatteringAlbedos") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: single_scattering_albedos + integer(kind=c_size_t), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: num_wavelength_bins + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_single_scattering_albedos(:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, [num_vertical_layers, num_wavelength_bins]) + + if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) .or. & + (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins)) then + error_code = 1 + return + end if + f_updater%radiator_%state_%layer_SSA_(:,:) = f_single_scattering_albedos(:,:) + + end subroutine internal_set_single_scattering_albedos + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_get_single_scattering_albedos(radiator_updater, single_scattering_albedos, & + num_vertical_layers, num_wavelength_bins, error_code) & + bind(C, name="InternalGetSingleScatteringAlbedos") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: single_scattering_albedos + integer(kind=c_size_t), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: num_wavelength_bins + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_single_scattering_albedos(:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, [num_vertical_layers, num_wavelength_bins]) + + if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) .or. & + (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins)) then + error_code = 1 + return + end if + f_single_scattering_albedos(:,:) = f_updater%radiator_%state_%layer_SSA_(:,:) + + end subroutine internal_get_single_scattering_albedos + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_asymmetry_factor(radiator_updater, asymmetry_factor, num_vertical_layers, & + num_wavelength_bins, num_streams, error_code) & + bind(C, name="InternalSetAsymmetryFactor") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: asymmetry_factor + integer(kind=c_size_t), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: num_wavelength_bins + integer(kind=c_size_t), intent(in), value :: num_streams + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_asymmetry_factor(:,:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(asymmetry_factor, f_asymmetry_factor, [num_vertical_layers, num_wavelength_bins, num_streams]) + + if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) .or. & + (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins) .or. & + (size(f_updater%radiator_%state_%layer_G_, 3) /= num_streams)) then + error_code = 1 + return + end if + f_updater%radiator_%state_%layer_G_(:,:,:) = f_asymmetry_factor(:,:,:) + + end subroutine internal_set_asymmetry_factor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface_radiator \ No newline at end of file diff --git a/src/tuvx/interface_radiator_map.F90 b/src/tuvx/interface_radiator_map.F90 new file mode 100644 index 00000000..1d30e33c --- /dev/null +++ b/src/tuvx/interface_radiator_map.F90 @@ -0,0 +1,168 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_interface_radiator_map + + use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char + use tuvx_radiator_warehouse, only : radiator_warehouse_t + use tuvx_radiator, only : radiator_t + use musica_tuvx_util, only : to_f_string, string_t_c + use musica_string, only : string_t + + implicit none + + private + + contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_create_radiator_map(error_code) result(radiator_map) & + bind(C, name="InternalCreateRadiatorMap") + use iso_c_binding, only: c_ptr, c_int, c_null_ptr + use tuvx_radiator_warehouse, only: radiator_warehouse_t + + ! arguments + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: radiator_map + + ! variables + class(radiator_warehouse_t), pointer :: f_radiator_warehouse + + f_radiator_warehouse => radiator_warehouse_t() + select type(f_radiator_warehouse) + type is(radiator_warehouse_t) + radiator_map = c_loc(f_radiator_warehouse) + error_code = 0 + class default + error_code = 1 + radiator_map = c_null_ptr + end select + + end function internal_create_radiator_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_radiator_map(radiator_map, error_code) & + bind(C, name="InternalDeleteRadiatorMap") + use iso_c_binding, only: c_ptr, c_int, c_f_pointer + use tuvx_radiator_warehouse, only: radiator_warehouse_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_warehouse_t), pointer :: f_radiator_warehouse + + call c_f_pointer(radiator_map, f_radiator_warehouse) + deallocate(f_radiator_warehouse) + error_code = 0 + +end subroutine internal_delete_radiator_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_add_radiator(radiator_map, radiator, error_code) & + bind(C, name="InternalAddRadiator") + use iso_c_binding, only: c_ptr, c_int, c_f_pointer + use tuvx_radiator_warehouse, only: radiator_warehouse_t + use tuvx_radiator_from_host, only: radiator_from_host_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + type(c_ptr), intent(in), value :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_warehouse_t), pointer :: f_radiator_warehouse + type(radiator_from_host_t), pointer :: f_radiator + + call c_f_pointer(radiator_map, f_radiator_warehouse) + call c_f_pointer(radiator, f_radiator) + + error_code = 0 + call f_radiator_warehouse%add(f_radiator) + + end subroutine internal_add_radiator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_radiator(radiator_map, c_radiator_name, & + c_radiator_name_length, error_code) & + result(radiator_ptr) bind(C, name="InternalGetRadiator") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_char, c_size_t, & + c_null_ptr, c_loc + use tuvx_radiator_from_host, only: radiator_from_host_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + character(len=1, kind=c_char), dimension(*), intent(in) :: c_radiator_name + integer(kind=c_size_t), value :: c_radiator_name_length + integer(kind=c_int), intent(out) :: error_code + + ! variables + class(radiator_t), pointer :: f_radiator + type(radiator_warehouse_t), pointer :: radiator_warehouse + character(len=:), allocatable :: f_radiator_name + + ! result + type(c_ptr) :: radiator_ptr + + allocate(character(len=c_radiator_name_length) :: f_radiator_name) + do i = 1, c_radiator_name_length + f_radiator_name(i:i) = c_radiator_name(i) + end do + + call c_f_pointer(radiator_map, radiator_warehouse) + + f_radiator => radiator_warehouse%get_radiator(f_radiator_name) + + select type(f_radiator) + type is(radiator_from_host_t) + error_code = 0 + radiator_ptr = c_loc(f_radiator) + class default + error_code = 1 + deallocate(f_radiator) + radiator_ptr = c_null_ptr + end select + + end function interal_get_radiator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_radiator_updater_from_map(radiator_map, radiator, error_code) & + result(updater) bind(C, name="InternalGetRadiatorUpdaterFromMap") + use iso_c_binding, only: c_ptr, c_f_pointer, c_loc + use tuvx_radiator_warehouse, only: radiator_warehouse_t + use tuvx_radiator_from_host, only: radiator_from_host_t, gradiator_updater_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + type(c_ptr), intent(in), value :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(radiator_warehouse_t), pointer :: f_radiator_warehouse + type(radiator_from_host_t), pointer :: f_radiator + type(radiator_updater_t), pointer :: f_updater + + call c_f_pointer(radiator_map, f_radiator_warehouse) + call c_f_pointer(radiator, f_radiator) + + error_code = 0 + allocate(f_updater) + f_updater = f_radiator_warehouse%get_updater(f_radiator) + updater = c_loc(f_updater) + + end function internal_get_radiator_updater_from_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface_radiator_map \ No newline at end of file From 63a3fa2532dafa6c6e6cbdf5f8080849611ebd68 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 11:59:33 -0600 Subject: [PATCH 02/31] working-on file of radiator header --- fortran/tuvx/radiator.F90 | 148 ++++++++++++++------ include/musica/tuvx/radiator.hpp | 227 +++++++++++++++++++++++++++++++ 2 files changed, 336 insertions(+), 39 deletions(-) create mode 100644 include/musica/tuvx/radiator.hpp diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index dc550290..1b4523e6 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -78,29 +78,29 @@ subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, type(error_t_c), intent(inout) :: error end subroutine get_single_scattering_albedos_c - subroutine set_asymmetry_factor_c(radiator, symmetry_factor, num_vertical_layers, & - num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactor") + subroutine set_asymmetry_factors_c(radiator, symmetry_factor, num_vertical_layers, & + num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactors") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c type(c_ptr), value, intent(in) :: radiator - type(c_ptr), value, intent(in) :: asymmetry_factor + type(c_ptr), value, intent(in) :: asymmetry_factors integer(c_size_t), value, intent(in) :: num_vertical_layers integer(c_size_t), value, intent(in) :: num_wavelength_bins integer(c_size_t), value, intent(in) :: num_streams type(error_t_c), intent(inout) :: error - end subroutine set_asymmetry_factor_c + end subroutine set_asymmetry_factors_c - subroutine get_asymmetry_factor_c(radiator, symmetry_factor, num_vertical_layers, & - num_wavelength_bins, num_streams, error) bind(C, name="GetAsymmetryFactor") + subroutine get_asymmetry_factors_c(radiator, symmetry_factor, num_vertical_layers, & + num_wavelength_bins, num_streams, error) bind(C, name="GetAsymmetryFactors") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c type(c_ptr), value, intent(in) :: radiator - type(c_ptr), value, intent(in) :: asymmetry_factor + type(c_ptr), value, intent(in) :: asymmetry_factors integer(c_size_t), value, intent(in) :: num_vertical_layers integer(c_size_t), value, intent(in) :: num_wavelength_bins integer(c_size_t), value, intent(in) :: num_streams type(error_t_c), intent(inout) :: error - end subroutine get_asymmetry_factor_c + end subroutine get_asymmetry_factors_c end interface !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -116,10 +116,10 @@ end subroutine get_asymmetry_factor_c procedure :: set_single_scattering_albedos ! Get the radiator single scattering albedos procedure :: get_single_scattering_albedos - ! Set the radiator asymmetry_factor - procedure :: set_asymmetry_factor - ! Get the radiator asymmetry factor - procedure :: get_asymmetry_factor + ! Set the radiator asymmetry_factors + procedure :: set_asymmetry_factors + ! Get the radiator asymmetry factors + procedure :: get_asymmetry_factors ! Deallocate the radiator instance final :: finalize_radiator_t end type radiator_t @@ -180,94 +180,164 @@ end function radiator_t_constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine set_edges(this, edges, error) + subroutine set_optical_depths(this, optical_depths, error) use iso_c_binding, only: c_size_t, c_loc use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:), intent(in) :: edges - type(error_t), intent(inout) :: error + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:), intent(in) :: optical_depths + type(error_t), intent(inout) :: error ! Local variables - type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_edges + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins - n_edges = size(edges) + num_vertical_layers = size(optical_depths, 1) + num_wavelength_bins = size(optical_depths, 2) - call set_radiator_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + call set_optical_depths_c(this%ptr_, c_loc(optical_depths), & + num_vertical_layers, num_wavelength_bins, error_c) error = error_t(error_c) end subroutine set_edges !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine get_edges(this, edges, error) + subroutine get_optical_depths(this, optical_depths, error) use iso_c_binding, only: c_size_t, c_loc use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:), intent(inout) :: edges + real(dk), target, dimension(:,:), intent(in) :: optical_depths type(error_t), intent(inout) :: error ! Local variables - type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_edges + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins - n_edges = size(edges) + num_vertical_layers = size(optical_depths, 1) + num_wavelength_bins = size(optical_depths, 2) - call get_radiator_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + call get_optical_depths_c(this%ptr_, c_loc(optical_depths), & + num_vertical_layers, num_wavelength_bins, error_c) error = error_t(error_c) - end subroutine get_edges + end subroutine get_optical_depths !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine set_midpoints(this, midpoints, error) + subroutine set_single_scattering_albedos(this, single_scattering_albedos, & + error) use iso_c_binding, only: c_size_t, c_loc use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:), intent(in) :: midpoints + real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_midpoints + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins - n_midpoints = size(midpoints) + num_vertical_layers = size(single_scattering_albedos, 1) + num_wavelength_bins = size(single_scattering_albedos, 2) - call set_radiator_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + call set_single_scattering_albedos_c(this%ptr_, & + c_loc(single_scattering_albedos), num_vertical_layers, & + num_wavelength_bins, error_c) error = error_t(error_c) - end subroutine set_midpoints + end subroutine set_single_scattering_albedos !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine get_midpoints(this, midpoints, error) + subroutine get_single_scattering_albedos(this, single_scattering_albedos, & + error) use iso_c_binding, only: c_size_t, c_loc use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:), intent(inout) :: midpoints + real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_midpoints + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins - n_midpoints = size(midpoints) + num_vertical_layers = size(single_scattering_albedos, 1) + num_wavelength_bins = size(single_scattering_albedos, 2) - call get_radiator_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + call get_single_scattering_albedos_c(this%ptr_, & + c_loc(single_scattering_albedos), num_vertical_layers, & + num_wavelength_bins, error_c) error = error_t(error_c) - end subroutine get_midpoints + end subroutine get_single_scattering_albedos + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_asymmetry_factors(this, symmetry_factor, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:,:), intent(in) :: asymmetry_factors + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins + integer(kind=c_size_t) :: num_streams + + num_vertical_layers = size(single_scattering_albedos, 1) + num_wavelength_bins = size(single_scattering_albedos, 2) + num_streams = size(num_streams, 3) + + call set_asymmetry_factors_c(this%ptr_, c_loc(asymmetry_factors), & + num_vertical_layers, num_wavelength_bins, num_streams, error_c) + error = error_t(error_c) + +end subroutine set_asymmetry_factors + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_asymmetry_factors(this, symmetry_factor, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:,:), intent(in) :: asymmetry_factors + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins + integer(kind=c_size_t) :: num_streams + + num_vertical_layers = size(single_scattering_albedos, 1) + num_wavelength_bins = size(single_scattering_albedos, 2) + num_streams = size(num_streams, 3) + + call get_asymmetry_factors_c(this%ptr_, c_loc(asymmetry_factors), & + num_vertical_layers, num_wavelength_bins, num_streams, error_c) + error = error_t(error_c) + + end subroutine get_single_scattering_albedos + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !> Deallocate the radiator instance subroutine finalize_radiator_t(this) use iso_c_binding, only: c_associated diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp new file mode 100644 index 00000000..e5ff2ae6 --- /dev/null +++ b/include/musica/tuvx/radiator.hpp @@ -0,0 +1,227 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include +#include + +#include +#include +#include +#include + +namespace musica +{ + class RadiatorMap; + class Profile; + + /// @brief A grid struct used to access grid information in tuvx + struct Radiator + { + /// @brief Creates a grid instance + /// @param grid_name The name of the grid + /// @param units The units of the grid + /// @param num_sections The number of sections in the grid + /// @param error The error struct to indicate success or failure + Radiator(const char *grid_name, const char *units, std::size_t num_sections, Error *error); + + ~Radiator(); + + /// @brief Set the edges of the grid + /// @param edges The edges of the grid + /// @param num_edges the number of edges + /// @param error the error struct to indicate success or failure + void SetEdges(double edges[], std::size_t num_edges, Error *error); + + /// @brief Get the edges of the grid + /// @param edges The edges of the grid + /// @param num_edges the number of edges + /// @param error the error struct to indicate success or failure + void GetEdges(double edges[], std::size_t num_edges, Error *error); + + /// @brief Set the midpoints of the grid + /// @param midpoints The midpoints of the grid + /// @param num_midpoints the number of midpoints + /// @param error the error struct to indicate success or failure + void SetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error); + + /// @brief Get the midpoints of the grid + /// @param midpoints The midpoints of the grid + /// @param num_midpoints the number of midpoints + /// @param error the error struct to indicate success or failure + void GetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error); + + private: + void *grid_; // A valid pointer to a grid instance indicates ownership by this wrapper + void *updater_; + + friend class RadiatorMap; + friend class Profile; + + /// @brief Wraps an existing grid instance. Used by RadiatorMap + /// @param updater The updater for the grid + Radiator(void *updater) + : grid_(nullptr), + updater_(updater) + { + } + }; + +#ifdef __cplusplus + extern "C" + { +#endif + + // The external C API for TUVX + // callable by wrappers in other languages + + /// @brief Creates a TUV-x radiator instance + /// @param radiator_name The name of the radiator + /// @param height_grid The height grid + /// @param wavelength_grid The wavelength grid + /// @param error The error struct to indicate success or failure + Radiator *CreateRadiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); + + /// @brief Deletes a TUV-x radiator instance + /// @param radiator The radiator to delete + /// @param error The error struct to indicate success or failure + void DeleteRadiator(Radiator *radiator, Error *error); + + /// @brief Sets the values of the optical depths of the radiator + /// @param radiator The radiator to get the optical depths + /// @param optical_depths The optical depths values to get for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct to indicate success or failure + void SetOpticalDepths( + Radiator *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Gets the values of the optical depths of the radiator + /// @param radiator The radiator to set the optical depths + /// @param optical_depths The optical depths values to set for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct to indicate success or failure + void GetOpticalDepths( + Radiator *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Sets the values of the single scattering albedos + /// @param radiator The radiator to set the single scattering albedos of + /// @param single_scattering_albedos The single scattering albedos values to set for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct to indicate success or failure + void SetSingleScatteringAlbedos( + Radiator *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Gets the values of the single scattering albedos + /// @param radiator The radiator to get the single scattering albedos of + /// @param single_scattering_albedos The single scattering albedos values to get for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct to indicate success or failure + void GetSingleScatteringAlbedos( + Radiator *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Sets the values of the asymmetry factors + /// @param radiator The radiator to set the asymmetery factors of + /// @param single_scattering_albedos The asymmetery factors values to set for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param num_streams The number of streams + /// @param error The error struct to indicate success or failure + void SetAsymmetryFactors( + Radiator *radiator, + double *asymmetry_factor, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + + /// @brief Gets the values of the asymmetry factors + /// @param radiator The radiator to get the asymmetery factors of + /// @param single_scattering_albedos The asymmetery factors values to get for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param num_streams The number of streams + /// @param error The error struct to indicate success or failure + void GetAsymmetryFactors( + Radiator *radiator, + double *asymmetry_factor, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + + // INTERNAL USE. If tuvx ever gets rewritten in C++, these functions will + // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will + // not need to change + void *InternalCreateRadiator( + const char *radiator_name, + std::size_t radiator_name_length, + Grid *hegiht_grid, + Grid *wavelength_grid, + int *error_code); + void InternalDeleteRadiator(void *radiator, int *error_code); + void *InternalGetRadiatorUpdater(void *radiator, int *error_code); + void InternalDeleteRadiatorUpdater(void *updater, int *error_code); + void InternalSetOpticalDepths( + void *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + int *error_code); + void InternalGetOpticalDepths( + void *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + int *error_code); + void InternalSetSingleScatteringAlbedos( + void *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + int *error_code); + void InternalGetsingleScatteringAlbedos( + void *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + int *error_code); + void InternalSetAsymmetryFactors( + void *radiator, + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + int *error_code); + void InternalGetAsymmetryFactors( + void *radiator, + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + int *error_code); + +#ifdef __cplusplus + } +#endif + +} // namespace musica From 42e28173a12f0791a5694c08f259307997b55a81 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 12:09:01 -0600 Subject: [PATCH 03/31] fix typos, and incomplete parts --- fortran/tuvx/radiator.F90 | 4 +- include/musica/tuvx/radiator.hpp | 66 ++++++++++++++++++++++++-------- 2 files changed, 53 insertions(+), 17 deletions(-) diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index 1b4523e6..1f7a4a9d 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -78,7 +78,7 @@ subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, type(error_t_c), intent(inout) :: error end subroutine get_single_scattering_albedos_c - subroutine set_asymmetry_factors_c(radiator, symmetry_factor, num_vertical_layers, & + subroutine set_asymmetry_factors_c(radiator, asymmetry_factor, num_vertical_layers, & num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactors") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c @@ -201,7 +201,7 @@ subroutine set_optical_depths(this, optical_depths, error) num_vertical_layers, num_wavelength_bins, error_c) error = error_t(error_c) - end subroutine set_edges + end subroutine set_optical_depths !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index e5ff2ae6..c14922a5 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -27,17 +27,21 @@ namespace musica ~Radiator(); - /// @brief Set the edges of the grid - /// @param edges The edges of the grid - /// @param num_edges the number of edges - /// @param error the error struct to indicate success or failure - void SetEdges(double edges[], std::size_t num_edges, Error *error); + /// @brief Sets the optical_depths + /// @param edges The 2 dimensional optical_depths + /// @param num_vertical_layers The number of vertical layers + /// @param um_wavelength_bins The number of vertical layers + /// @param error The error struct to indicate success or failure + void + SetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); - /// @brief Get the edges of the grid - /// @param edges The edges of the grid - /// @param num_edges the number of edges - /// @param error the error struct to indicate success or failure - void GetEdges(double edges[], std::size_t num_edges, Error *error); + /// @brief Gets the optical_depths + /// @param edges The 2 dimensional optical_depths + /// @param num_vertical_layers The number of vertical layers + /// @param um_wavelength_bins The number of vertical layers + /// @param error The error struct to indicate success or failure + void + GetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); /// @brief Set the midpoints of the grid /// @param midpoints The midpoints of the grid @@ -45,6 +49,41 @@ namespace musica /// @param error the error struct to indicate success or failure void SetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error); + /// @brief Sets the values of the single scattering albedos + /// @param single_scattering_albedos The 2 dimensional single scattering albedos values + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct to indicate success or failure + void SetSingleScatteringAlbedos( + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Gets the values of the single scattering albedos + /// @param single_scattering_albedos The 2 dimensional single scattering albedos values + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct to indicate success or failure + void SetSingleScatteringAlbedos( + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Sets the values of the asymmetry factors + /// @param asymmetry_factor The asymmetery factors values to set for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param num_streams The number of streams + /// @param error The error struct to indicate success or failure + void SetAsymmetryFactors( + double *asymmetry_factor, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + /// @brief Get the midpoints of the grid /// @param midpoints The midpoints of the grid /// @param num_midpoints the number of midpoints @@ -140,8 +179,7 @@ namespace musica Error *error); /// @brief Sets the values of the asymmetry factors - /// @param radiator The radiator to set the asymmetery factors of - /// @param single_scattering_albedos The asymmetery factors values to set for the radiator + /// @param asymmetry_factor The 3 dimensional asymmetery factors values to set for the radiator /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams @@ -155,14 +193,12 @@ namespace musica Error *error); /// @brief Gets the values of the asymmetry factors - /// @param radiator The radiator to get the asymmetery factors of - /// @param single_scattering_albedos The asymmetery factors values to get for the radiator + /// @param asymmetry_factor The 3 dimensional asymmetery factors values to get for the radiator /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams /// @param error The error struct to indicate success or failure void GetAsymmetryFactors( - Radiator *radiator, double *asymmetry_factor, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, From 0f4d39af5f078f0740c0a674538d363219be0f1b Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 14:59:43 -0600 Subject: [PATCH 04/31] code clean up --- include/musica/tuvx/radiator.hpp | 65 ++++++++++++++++---------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index c14922a5..a20dc8c0 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -15,40 +15,34 @@ namespace musica class RadiatorMap; class Profile; - /// @brief A grid struct used to access grid information in tuvx + /// @brief A radiator struct used to access radiator information in tuvx struct Radiator { - /// @brief Creates a grid instance - /// @param grid_name The name of the grid - /// @param units The units of the grid - /// @param num_sections The number of sections in the grid + /// @brief Creates a radiator instance + /// @param radiator_name The name of the radiator + /// @param height_grid The height grid + /// @param wavelength_grid The wavelength grid /// @param error The error struct to indicate success or failure - Radiator(const char *grid_name, const char *units, std::size_t num_sections, Error *error); + Radiator(const char *radiator_name, Grid* height_grid, Grid* wavelength_grid, Error *error); ~Radiator(); /// @brief Sets the optical_depths - /// @param edges The 2 dimensional optical_depths + /// @param optical_depths The 2 dimensional optical_depths /// @param num_vertical_layers The number of vertical layers - /// @param um_wavelength_bins The number of vertical layers + /// @param num_wavelength_bins The number of wavelength layers /// @param error The error struct to indicate success or failure void SetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); /// @brief Gets the optical_depths - /// @param edges The 2 dimensional optical_depths + /// @param optical_depths The 2 dimensional optical_depths /// @param num_vertical_layers The number of vertical layers - /// @param um_wavelength_bins The number of vertical layers + /// @param num_wavelength_bins The number of wavelength layers /// @param error The error struct to indicate success or failure void GetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); - /// @brief Set the midpoints of the grid - /// @param midpoints The midpoints of the grid - /// @param num_midpoints the number of midpoints - /// @param error the error struct to indicate success or failure - void SetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error); - /// @brief Sets the values of the single scattering albedos /// @param single_scattering_albedos The 2 dimensional single scattering albedos values /// @param num_vertical_layers The number of vertical layers @@ -65,7 +59,7 @@ namespace musica /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure - void SetSingleScatteringAlbedos( + void GetSingleScatteringAlbedos( double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, @@ -84,23 +78,30 @@ namespace musica std::size_t num_streams, Error *error); - /// @brief Get the midpoints of the grid - /// @param midpoints The midpoints of the grid - /// @param num_midpoints the number of midpoints - /// @param error the error struct to indicate success or failure - void GetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error); + /// @brief Gets the values of the asymmetry factors + /// @param asymmetry_factor The asymmetery factors values to set for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param num_streams The number of streams + /// @param error The error struct to indicate success or failure + void GetAsymmetryFactors( + double *asymmetry_factor, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); private: - void *grid_; // A valid pointer to a grid instance indicates ownership by this wrapper + void *radiator_; // A valid pointer to a grid instance indicates ownership by this wrapper void *updater_; - friend class RadiatorMap; - friend class Profile; + // friend class RadiatorMap; + // friend class Profile; /// @brief Wraps an existing grid instance. Used by RadiatorMap /// @param updater The updater for the grid Radiator(void *updater) - : grid_(nullptr), + : radiator_(nullptr), updater_(updater) { } @@ -132,7 +133,7 @@ namespace musica /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure - void SetOpticalDepths( + void SetRadiatorOpticalDepths( Radiator *radiator, double *optical_depths, std::size_t num_vertical_layers, @@ -145,7 +146,7 @@ namespace musica /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure - void GetOpticalDepths( + void GetRadiatorOpticalDepths( Radiator *radiator, double *optical_depths, std::size_t num_vertical_layers, @@ -158,7 +159,7 @@ namespace musica /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure - void SetSingleScatteringAlbedos( + void SetRadiatorSingleScatteringAlbedos( Radiator *radiator, double *single_scattering_albedos, std::size_t num_vertical_layers, @@ -171,7 +172,7 @@ namespace musica /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure - void GetSingleScatteringAlbedos( + void GetRadiatorSingleScatteringAlbedos( Radiator *radiator, double *single_scattering_albedos, std::size_t num_vertical_layers, @@ -184,7 +185,7 @@ namespace musica /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams /// @param error The error struct to indicate success or failure - void SetAsymmetryFactors( + void SetRadiatorAsymmetryFactors( Radiator *radiator, double *asymmetry_factor, std::size_t num_vertical_layers, @@ -198,7 +199,7 @@ namespace musica /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams /// @param error The error struct to indicate success or failure - void GetAsymmetryFactors( + void GetRadiatorAsymmetryFactors( double *asymmetry_factor, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, From 6cdef231a429dfd048abb75ae4792ac205140b3d Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 16:18:22 -0600 Subject: [PATCH 05/31] add radiator src --- include/musica/tuvx/radiator.hpp | 6 +- src/tuvx/radiator.cpp | 279 +++++++++++++++++++++++++++++++ src/tuvx/radiator_map.cpp | 186 +++++++++++++++++++++ 3 files changed, 468 insertions(+), 3 deletions(-) create mode 100644 src/tuvx/radiator.cpp create mode 100644 src/tuvx/radiator_map.cpp diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index a20dc8c0..a5595821 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -92,14 +92,14 @@ namespace musica Error *error); private: - void *radiator_; // A valid pointer to a grid instance indicates ownership by this wrapper + void *radiator_; // A valid pointer to a radiator instance indicates ownership by this wrapper void *updater_; // friend class RadiatorMap; // friend class Profile; - /// @brief Wraps an existing grid instance. Used by RadiatorMap - /// @param updater The updater for the grid + /// @brief Wraps an existing radiator instance. Used by RadiatorMap + /// @param updater The updater for the radiator Radiator(void *updater) : radiator_(nullptr), updater_(updater) diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp new file mode 100644 index 00000000..0d697318 --- /dev/null +++ b/src/tuvx/radiator.cpp @@ -0,0 +1,279 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include +#include + +#include +#include +#include + +namespace musica +{ + + // Radiator external C API functions + + Radiator *CreateRadiator(const char *radiator_name, Radiator *height_grid, Radiator *wavelength_grid, Error *error); + { + DeleteError(error); + return new Radiator(radiator_name, height_grid, wavelength_grid, error); + } + + void DeleteRadiator(Radiator *radiator, Error *error); + { + DeleteError(error); + try + { + delete radiator; + } + catch (const std::system_error &e) + { + *error = ToError(e); + return; + } + *error = NoError(); + } + + void SetRadiatorOpticalDepths( + Radiator *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + { + DeleteError(error); + radiator->SetOpticalDepths(optical_depths, num_vertical_layers, num_wavelength_bins, error); + } + + void GetRadiatorOpticalDepths( + Radiator *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + { + DeleteError(error); + radiator->GetOpticalDepths(optical_depths, num_vertical_layers, num_wavelength_bins, error); + } + + void SetRadiatorSingleScatteringAlbedos( + Radiator *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + { + DeleteError(error); + radiator->SetSingleScatteringAlbedos(single_scattering_albedos, num_vertical_layers, num_wavelength_bins, error); + } + + void GetRadiatorSingleScatteringAlbedos( + Radiator *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + { + DeleteError(error); + radiator->GetSingleScatteringAlbedos(single_scattering_albedos, num_vertical_layers, num_wavelength_bins, error); + } + + void SetRadiatorAsymmetryFactors( + Radiator *radiator, + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + { + DeleteError(error); + radiator->SetAsymmetryFactors(asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, error); + } + + void GetRadiatorAsymmetryFactors( + Radiator *radiator, + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + { + DeleteError(error); + radiator->GetAsymmetryFactors(asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, error); + } + + // + // in progress + // + // Radiation class functions + + Radiator::Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); + { + int error_code = 0; + radiator_ = + InternalCreateRadiator(radiator_name, strlen(radiator_name), units, &height_grid, &wavelength_grid, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator") }; + return; + } + updater_ = InternalGetRadiatorUpdater(radiator_, &error_code); + if (error_code != 0) + { + InternalDeleteRadiator(radiator_, &error_code); + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get radiator updater") }; + return; + } + *error = NoError(); + } + + Radiator::~Radiator() + { + int error_code = 0; + if (radiator_ != nullptr) + InternalDeleteRadiator(radiator_, &error_code); + if (updater_ != nullptr) + InternalDeleteRadiatorUpdater(updater_, &error_code); + radiator_ = nullptr; + updater_ = nullptr; + } + + InternalSetOpticalDepths( + void *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + int *error_code); + + void Radiator::SetOpticalDepths( + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalSetOpticalDepths(updater_, optical_depths, num_vertical_layers, num_wavelength_bins, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set optical depths") }; + return; + } + *error = NoError(); + } + + void Radiator::GetOpticalDepths( + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalGetOpticalDepths(updater_, optical_depths, num_vertical_layers, num_wavelength_bins, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get optical depths") }; + return; + } + *error = NoError(); + } + + void Radiator::SetSingleScatteringAlbedos( + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalSetSingleScatteringAlbedos( + updater_, single_scattering_albedos, num_vertical_layers, num_wavelength_bins, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set single scattering albedos") }; + return; + } + *error = NoError(); + } + + void Radiator::GetSingleScatteringAlbedos( + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalGetSingleScatteringAlbedos( + updater_, single_scattering_albedos, num_vertical_layers, num_wavelength_bins, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get single scattering albedos") }; + return; + } + *error = NoError(); + } + + void SetAsymmetryFactors( + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalSetAsymmetryFactors( + updater_, asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set asymmetry factors") }; + return; + } + *error = NoError(); + } + + void GetAsymmetryFactors( + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalGetAsymmetryFactors( + updater_, asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get asymmetry factors") }; + return; + } + *error = NoError(); + } + +} // namespace musica \ No newline at end of file diff --git a/src/tuvx/radiator_map.cpp b/src/tuvx/radiator_map.cpp new file mode 100644 index 00000000..bde22904 --- /dev/null +++ b/src/tuvx/radiator_map.cpp @@ -0,0 +1,186 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include + +#include +#include +#include + +namespace musica +{ + + // RadiatordMap external C API functions + + RadiatorMap *CreateRadiatorMap(Error *error); + { + DeleteError(error); + return new RadiatorMap(error); + } + + void DeleteRadiatorMap(RadiatorMap *radiator_map, Error *error) + { + DeleteError(error); + try + { + delete radiator_map; + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + *error = NoError(); + } + + void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error); + { + DeleteError(error); + radiator_map->AddGrid(radiator, error); + } + + Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error); + { + DeleteError(error); + return radiator_map->GetRadiator(radiator_name, error); + } + + // RadiatordMap class functions + + RadiatorMap::RadiatorMap(Error *error); + { + int error_code = 0; + radiator_map_ = InternalCreateRadiatorMap(&error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator map") }; + } + owns_radiator_map_ = true; + *error = NoError(); + } + + RadiatorMap::~RadiatorMap(); + { + int error_code = 0; + if (radiator_map_ != nullptr && owns_radiator_map_) + { + InternalDeleteRadiatorMap(radiator_map_, &error_code); + } + radiator_map_ = nullptr; + owns_radiator_map_ = false; + } + + void RadiatorMap::AddRadiator(Radiator *radiator, Error *error); + { + if (radiator_map_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator map is null") }; + return; + } + if (radiator->radiator_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Cannot add unowned radiator to radiator map") }; + return; + } + if (radiator->updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Cannot add radiator in invalid state") }; + return; + } + + int error_code = 0; + + try + { + InternalAddGRadiator(radiator_map_, radiator->radiator_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to add radiator to radiator map") }; + } + InternalDeleteRadiatorUpdater(radiator->updater_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to delete updater after transfer of ownership to radiator map") }; + } + radiator->updater_ = InternalGetRadiatorUpdaterFromMap(radiator_map_, radiator->radiator_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to get updater after transfer of ownership to radiator map") }; + } + InternalDeleteRadiator(radiator->radiator_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to delete radiator during transfer of ownership to radiator map") }; + } + radiator->radiator_ = nullptr; + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + catch (...) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Internal error adding radiator") }; + } + *error = NoError(); + } + + + /// @brief Returns a radiator. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on to + /// be transparent to downstream projects + /// @param radiator_name The name of the radiator + /// @param error The error struct to indicate success or failure + /// @return a radiator pointer + Radiator *RadiatorMap::GetRadiator(const char *radiator_name, Error *error) + { + if (radiator_map_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator map is null") }; + return nullptr; + } + + Radiator *radiator = nullptr; + + try + { + int error_code = 0; + void *radiator_ptr = InternalGetRadiator(radiator_map_, radiator_name, strlen(radiator_name), &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get radiator from radiator map") }; + return nullptr; + } + void *updater_ptr = InternalGetRadiatorUpdaterFromMap(radiator_map_, radiator_ptr, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get radiator updater") }; + InternalDeleteRadiator(radiator_ptr, &error_code); + return nullptr; + } + InternalDeleteRadiator(radiator_ptr, &error_code); + if (error_code != 0) + { + *error = + Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to delete radiator after getting updater") }; + InternalDeleteRadiatorUpdater(updater_ptr, &error_code); + return nullptr; + } + radiator = new Radiator(updater_ptr); + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + catch (...) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Internal error getting radiator") }; + } + *error = NoError(); + return radiator; + } + +} // namespace musica \ No newline at end of file From 2267552e2e9bab668dfd159570ee69d1377d3137 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 16:57:22 -0600 Subject: [PATCH 06/31] fix bugs --- include/musica/tuvx/radiator.hpp | 2 +- include/musica/tuvx/radiator_map.hpp | 11 +-- src/tuvx/CMakeLists.txt | 4 + src/tuvx/interface_radiator.F90 | 133 ++++++++++++++++++--------- src/tuvx/radiator.cpp | 31 +++---- src/tuvx/radiator_map.cpp | 19 ++-- 6 files changed, 118 insertions(+), 82 deletions(-) diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index a5595821..32729ad0 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -23,7 +23,7 @@ namespace musica /// @param height_grid The height grid /// @param wavelength_grid The wavelength grid /// @param error The error struct to indicate success or failure - Radiator(const char *radiator_name, Grid* height_grid, Grid* wavelength_grid, Error *error); + Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); ~Radiator(); diff --git a/include/musica/tuvx/radiator_map.hpp b/include/musica/tuvx/radiator_map.hpp index 980b65a7..ccaa9540 100644 --- a/include/musica/tuvx/radiator_map.hpp +++ b/include/musica/tuvx/radiator_map.hpp @@ -32,8 +32,8 @@ namespace musica /// @param error The error struct to indicate success or failure void AddRadiator(Radiator *radiator, Error *error); - /// @brief Returns a radiator. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on to - /// be transparent to downstream projects + /// @brief Returns a radiator. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later + /// on to be transparent to downstream projects /// @param radiator_name The name of the radiator /// @param error The error struct to indicate success or failure /// @return a radiator pointer @@ -81,11 +81,8 @@ namespace musica void *InternalCreateRadiatorMap(int *error_code); void InternalDeleteRadiatordMap(void *radiator_map, int *error_code); void InternalAddRadiator(void *radiator_map, void *radiator, int *error_code); - void *InternalGetRadiator( - void *radiator_map, - const char *radiator_name, - std::size_t radiator_name_length, - int *error_code); + void * + InternalGetRadiator(void *radiator_map, const char *radiator_name, std::size_t radiator_name_length, int *error_code); void *InternalGetRadiatorUpdaterFromMap(void *radiator_map, void *radiator, int *error_code); #ifdef __cplusplus diff --git a/src/tuvx/CMakeLists.txt b/src/tuvx/CMakeLists.txt index 4d9acdb4..46fa14bc 100644 --- a/src/tuvx/CMakeLists.txt +++ b/src/tuvx/CMakeLists.txt @@ -5,10 +5,14 @@ target_sources(musica interface_grid_map.F90 interface_profile.F90 interface_profile_map.F90 + interface_radiator.F90 + interface_radiator_map.F90 grid.cpp grid_map.cpp profile.cpp profile_map.cpp + radiator.cpp + radiator_map.cpp tuvx.cpp tuvx_util.F90 ) \ No newline at end of file diff --git a/src/tuvx/interface_radiator.F90 b/src/tuvx/interface_radiator.F90 index 6588a298..a0d6d1d0 100644 --- a/src/tuvx/interface_radiator.F90 +++ b/src/tuvx/interface_radiator.F90 @@ -12,9 +12,9 @@ module tuvx_interface_radiator !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_create_radiator(radiator_name, radiator_name_length, height_grid, & - wavelength_grid, error_code) result(radiator) & - bind(C, name="InternalCreateRadiator") + function internal_create_radiator(radiator_name, radiator_name_length, & + height_grid, wavelength_grid, error_code) result(radiator) & + bind(C, name="InternalCreateRadiator") use iso_c_binding, only: c_ptr, c_f_pointer, c_char, c_loc, c_size_t, c_int use musica_string, only: string_t @@ -22,12 +22,12 @@ function internal_create_radiator(radiator_name, radiator_name_length, height_gr use tuvx_grid, only : grid_t ! arguments - type(c_ptr) :: radiator + type(c_ptr) :: radiator character(kind=c_char, len=1), dimension(*), intent(in) :: radiator_name - integer(kind=c_size_t), intent(in), value :: radiator_name_length - type(c_ptr), intent(in), value :: height_grid - type(c_ptr), intent(in), value :: wavelength_grid - integer(kind=c_int), intent(out) :: error_code + integer(kind=c_size_t), intent(in), value :: radiator_name_length + type(c_ptr), intent(in), value :: height_grid + type(c_ptr), intent(in), value :: wavelength_grid + integer(kind=c_int), intent(out) :: error_code ! variables type(radiator_from_host_t), pointer :: f_radiator @@ -50,7 +50,7 @@ end function internal_create_radiator !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine internal_delete_radiator(radiator, error_code) & - bind(C, name="InternalDeleteRadiator") + bind(C, name="InternalDeleteRadiator") use iso_c_binding, only: c_ptr, c_f_pointer, c_int ! arguments @@ -70,7 +70,7 @@ end subroutine internal_delete_radiator !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function internal_get_radiator_updater(radiator, error_code) & - bind(C, name="InternalGetRadiatorUpdater") result(updater) + bind(C, name="InternalGetRadiatorUpdater") result(updater) use iso_c_binding, only: c_ptr, c_f_pointer, c_loc, c_int use tuvx_radiator_from_host, only: radiator_from_host_t, radiator_updater_t @@ -94,7 +94,7 @@ end function internal_get_radiator_updater !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine internal_delete_radiator_updater(updater, error_code) & - bind(C, name="InternalDeleteRadiatorUpdater") + bind(C, name="InternalDeleteRadiatorUpdater") use iso_c_binding, only: c_ptr, c_f_pointer, c_int use tuvx_radiator_from_host, only: radiator_updater_t @@ -103,7 +103,7 @@ subroutine internal_delete_radiator_updater(updater, error_code) & integer(kind=c_int), intent(out) :: error_code ! variables - type(grid_radiator_t), pointer :: f_updater + type(radiator_t), pointer :: f_updater call c_f_pointer(updater, f_updater) if (associated(f_updater)) then @@ -114,8 +114,8 @@ end subroutine internal_delete_radiator_updater !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_set_optical_depths(radiator_updater, optical_depths, num_vertical_layers, & - num_wavelength_bins, error_code) & + subroutine internal_set_optical_depths(radiator_updater, optical_depths, & + num_vertical_layers, num_wavelength_bins, error_code) & bind(C, name="InternalSetOpticalDepths") use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t use musica_constants, only: dk => musica_dk @@ -133,10 +133,12 @@ subroutine internal_set_optical_depths(radiator_updater, optical_depths, num_ver real(kind=dk), pointer :: f_optical_depths(:,:) call c_f_pointer(radiator_updater, f_updater) - call c_f_pointer(optical_depths, f_optical_depths, [num_vertical_layers, num_wavelength_bins]) + call c_f_pointer(optical_depths, f_optical_depths, + [num_vertical_layers, num_wavelength_bins]) - if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) .or. & - (size(f_updater%radiator_%state_%layer_OD_, 2) /= num_wavelength_bins)) then + if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_OD_, 2) /= num_wavelength_bins)) & + then error_code = 1 return end if @@ -146,8 +148,8 @@ end subroutine internal_set_optical_depths !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_get_optical_depths(radiator_updater, optical_depths, num_vertical_layers, & - num_wavelength_bins, error_code) & + subroutine internal_get_optical_depths(radiator_updater, optical_depths, & + num_vertical_layers, num_wavelength_bins, error_code) & bind(C, name="InternalGetOpticalDepths") use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t use musica_constants, only: dk => musica_dk @@ -165,10 +167,12 @@ subroutine internal_get_optical_depths(radiator_updater, optical_depths, num_ver real(kind=dk), pointer :: f_optical_depths(:,:) call c_f_pointer(radiator_updater, f_updater) - call c_f_pointer(optical_depths, f_optical_depths, [num_vertical_layers, num_wavelength_bins]) + call c_f_pointer(optical_depths, f_optical_depths, + [num_vertical_layers, num_wavelength_bins]) - if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) .or. & - (size(f_updater%radiator_%state_%layer_OD_, 2) /= num_wavelength_bins)) then + if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_OD_, 2) /= num_wavelength_bins)) & + then error_code = 1 return end if @@ -178,9 +182,9 @@ end subroutine internal_get_optical_depths !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_set_single_scattering_albedos(radiator_updater, single_scattering_albedos, & - num_vertical_layers, num_wavelength_bins, error_code) & - bind(C, name="InternalSetSingleScatteringAlbedos") + subroutine internal_set_single_scattering_albedos(radiator_updater, & + single_scattering_albedos, num_vertical_layers, num_wavelength_bins, & + error_code) bind(C, name="InternalSetSingleScatteringAlbedos") use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t use musica_constants, only: dk => musica_dk use tuvx_radiator_from_host, only: radiator_updater_t @@ -197,10 +201,12 @@ subroutine internal_set_single_scattering_albedos(radiator_updater, single_scatt real(kind=dk), pointer :: f_single_scattering_albedos(:,:) call c_f_pointer(radiator_updater, f_updater) - call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, [num_vertical_layers, num_wavelength_bins]) + call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, & + [num_vertical_layers, num_wavelength_bins]) - if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) .or. & - (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins)) then + if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins)) & + then error_code = 1 return end if @@ -210,9 +216,9 @@ end subroutine internal_set_single_scattering_albedos !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_get_single_scattering_albedos(radiator_updater, single_scattering_albedos, & - num_vertical_layers, num_wavelength_bins, error_code) & - bind(C, name="InternalGetSingleScatteringAlbedos") + subroutine internal_get_single_scattering_albedos(radiator_updater, & + single_scattering_albedos, num_vertical_layers, num_wavelength_bins, & + error_code) bind(C, name="InternalGetSingleScatteringAlbedos") use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t use musica_constants, only: dk => musica_dk use tuvx_radiator_from_host, only: radiator_updater_t @@ -229,10 +235,12 @@ subroutine internal_get_single_scattering_albedos(radiator_updater, single_scatt real(kind=dk), pointer :: f_single_scattering_albedos(:,:) call c_f_pointer(radiator_updater, f_updater) - call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, [num_vertical_layers, num_wavelength_bins]) + call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, & + [num_vertical_layers, num_wavelength_bins]) - if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) .or. & - (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins)) then + if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins)) & + then error_code = 1 return end if @@ -242,16 +250,16 @@ end subroutine internal_get_single_scattering_albedos !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_set_asymmetry_factor(radiator_updater, asymmetry_factor, num_vertical_layers, & - num_wavelength_bins, num_streams, error_code) & - bind(C, name="InternalSetAsymmetryFactor") + subroutine internal_set_asymmetry_factors(radiator_updater, & + asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, & + error_code) bind(C, name="InternalSetAsymmetryFactors") use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t use musica_constants, only: dk => musica_dk use tuvx_radiator_from_host, only: radiator_updater_t ! arguments type(c_ptr), value, intent(in) :: radiator_updater - type(c_ptr), value, intent(in) :: asymmetry_factor + type(c_ptr), value, intent(in) :: asymmetry_factors integer(kind=c_size_t), intent(in), value :: num_vertical_layers integer(kind=c_size_t), intent(in), value :: num_wavelength_bins integer(kind=c_size_t), intent(in), value :: num_streams @@ -259,21 +267,56 @@ subroutine internal_set_asymmetry_factor(radiator_updater, asymmetry_factor, num ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_asymmetry_factor(:,:,:) + real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) call c_f_pointer(radiator_updater, f_updater) - call c_f_pointer(asymmetry_factor, f_asymmetry_factor, [num_vertical_layers, num_wavelength_bins, num_streams]) + call c_f_pointer(asymmetry_factors, f_asymmetry_factors, & + [num_vertical_layers, num_wavelength_bins, num_streams]) - if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) .or. & - (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins) .or. & - (size(f_updater%radiator_%state_%layer_G_, 3) /= num_streams)) then + if ((size(f_updater%radiator_%state_%layer_G_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_G_, 2) /= num_wavelength_bins) & + .or. (size(f_updater%radiator_%state_%layer_G_, 3) /= num_streams)) then error_code = 1 return end if - f_updater%radiator_%state_%layer_G_(:,:,:) = f_asymmetry_factor(:,:,:) + f_updater%radiator_%state_%layer_G_(:,:,:) = f_asymmetry_factors(:,:,:) - end subroutine internal_set_asymmetry_factor + end subroutine internal_set_asymmetry_factors !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine internal_get_asymmetry_factors(radiator_updater, & + asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, & + error_code) bind(C, name="InternalGetAsymmetryFactors") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: asymmetry_factors + integer(kind=c_size_t), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: num_wavelength_bins + integer(kind=c_size_t), intent(in), value :: num_streams + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(asymmetry_factors, f_asymmetry_factors, & + [num_vertical_layers, num_wavelength_bins, num_streams]) + + if ((size(f_updater%radiator_%state_%layer_G_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_G_, 2) /= num_wavelength_bins) & + .or. (size(f_updater%radiator_%state_%layer_G_, 3) /= num_streams)) then + error_code = 1 + return + end if + f_asymmetry_factors(:,:,:) = f_updater%radiator_%state_%layer_G_(:,:,:) + +end subroutine internal_set_asymmetry_factors + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module tuvx_interface_radiator \ No newline at end of file diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp index 0d697318..e1ea9620 100644 --- a/src/tuvx/radiator.cpp +++ b/src/tuvx/radiator.cpp @@ -12,13 +12,13 @@ namespace musica // Radiator external C API functions - Radiator *CreateRadiator(const char *radiator_name, Radiator *height_grid, Radiator *wavelength_grid, Error *error); + Radiator *CreateRadiator(const char *radiator_name, Radiator *height_grid, Radiator *wavelength_grid, Error *error) { DeleteError(error); return new Radiator(radiator_name, height_grid, wavelength_grid, error); } - void DeleteRadiator(Radiator *radiator, Error *error); + void DeleteRadiator(Radiator *radiator, Error *error) { DeleteError(error); try @@ -38,7 +38,7 @@ namespace musica double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { DeleteError(error); radiator->SetOpticalDepths(optical_depths, num_vertical_layers, num_wavelength_bins, error); @@ -60,7 +60,7 @@ namespace musica double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { DeleteError(error); radiator->SetSingleScatteringAlbedos(single_scattering_albedos, num_vertical_layers, num_wavelength_bins, error); @@ -71,7 +71,7 @@ namespace musica double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { DeleteError(error); radiator->GetSingleScatteringAlbedos(single_scattering_albedos, num_vertical_layers, num_wavelength_bins, error); @@ -83,7 +83,7 @@ namespace musica std::size_t num_vertical_layers, std::size_t num_wavelength_bins, std::size_t num_streams, - Error *error); + Error *error) { DeleteError(error); radiator->SetAsymmetryFactors(asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, error); @@ -106,7 +106,7 @@ namespace musica // // Radiation class functions - Radiator::Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); + Radiator::Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error) { int error_code = 0; radiator_ = @@ -137,18 +137,11 @@ namespace musica updater_ = nullptr; } - InternalSetOpticalDepths( - void *radiator, - double *optical_depths, - std::size_t num_vertical_layers, - std::size_t num_wavelength_bins, - int *error_code); - void Radiator::SetOpticalDepths( double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) @@ -169,7 +162,7 @@ namespace musica double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) @@ -190,7 +183,7 @@ namespace musica double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) @@ -212,7 +205,7 @@ namespace musica double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) @@ -235,7 +228,7 @@ namespace musica std::size_t num_vertical_layers, std::size_t num_wavelength_bins, std::size_t num_streams, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) diff --git a/src/tuvx/radiator_map.cpp b/src/tuvx/radiator_map.cpp index bde22904..42a4958d 100644 --- a/src/tuvx/radiator_map.cpp +++ b/src/tuvx/radiator_map.cpp @@ -11,12 +11,12 @@ namespace musica // RadiatordMap external C API functions - RadiatorMap *CreateRadiatorMap(Error *error); + RadiatorMap *CreateRadiatorMap(Error *error) { DeleteError(error); return new RadiatorMap(error); } - + void DeleteRadiatorMap(RadiatorMap *radiator_map, Error *error) { DeleteError(error); @@ -31,13 +31,13 @@ namespace musica *error = NoError(); } - void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error); + void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error) { DeleteError(error); radiator_map->AddGrid(radiator, error); } - Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error); + Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error) { DeleteError(error); return radiator_map->GetRadiator(radiator_name, error); @@ -45,7 +45,7 @@ namespace musica // RadiatordMap class functions - RadiatorMap::RadiatorMap(Error *error); + RadiatorMap::RadiatorMap(Error *error) { int error_code = 0; radiator_map_ = InternalCreateRadiatorMap(&error_code); @@ -57,7 +57,7 @@ namespace musica *error = NoError(); } - RadiatorMap::~RadiatorMap(); + RadiatorMap::~RadiatorMap() { int error_code = 0; if (radiator_map_ != nullptr && owns_radiator_map_) @@ -68,7 +68,7 @@ namespace musica owns_radiator_map_ = false; } - void RadiatorMap::AddRadiator(Radiator *radiator, Error *error); + void RadiatorMap::AddRadiator(Radiator *radiator, Error *error) { if (radiator_map_ == nullptr) { @@ -129,9 +129,8 @@ namespace musica *error = NoError(); } - - /// @brief Returns a radiator. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on to - /// be transparent to downstream projects + /// @brief Returns a radiator. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on + /// to be transparent to downstream projects /// @param radiator_name The name of the radiator /// @param error The error struct to indicate success or failure /// @return a radiator pointer From b85b1b0e9cbf99f2d74297dfd299a1adc5abbbf8 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 17:38:26 -0600 Subject: [PATCH 07/31] fix bugs --- include/musica/tuvx/radiator.hpp | 2 +- src/tuvx/interface_radiator.F90 | 4 ++-- src/tuvx/radiator.cpp | 11 ++++------- 3 files changed, 7 insertions(+), 10 deletions(-) diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index 32729ad0..840a0887 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -236,7 +236,7 @@ namespace musica std::size_t num_vertical_layers, std::size_t num_wavelength_bins, int *error_code); - void InternalGetsingleScatteringAlbedos( + void InternalGetSingleScatteringAlbedos( void *radiator, double *single_scattering_albedos, std::size_t num_vertical_layers, diff --git a/src/tuvx/interface_radiator.F90 b/src/tuvx/interface_radiator.F90 index a0d6d1d0..3cb5bb89 100644 --- a/src/tuvx/interface_radiator.F90 +++ b/src/tuvx/interface_radiator.F90 @@ -133,7 +133,7 @@ subroutine internal_set_optical_depths(radiator_updater, optical_depths, & real(kind=dk), pointer :: f_optical_depths(:,:) call c_f_pointer(radiator_updater, f_updater) - call c_f_pointer(optical_depths, f_optical_depths, + call c_f_pointer(optical_depths, f_optical_depths, & [num_vertical_layers, num_wavelength_bins]) if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) & @@ -167,7 +167,7 @@ subroutine internal_get_optical_depths(radiator_updater, optical_depths, & real(kind=dk), pointer :: f_optical_depths(:,:) call c_f_pointer(radiator_updater, f_updater) - call c_f_pointer(optical_depths, f_optical_depths, + call c_f_pointer(optical_depths, f_optical_depths, & [num_vertical_layers, num_wavelength_bins]) if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) & diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp index e1ea9620..10b363cc 100644 --- a/src/tuvx/radiator.cpp +++ b/src/tuvx/radiator.cpp @@ -12,7 +12,7 @@ namespace musica // Radiator external C API functions - Radiator *CreateRadiator(const char *radiator_name, Radiator *height_grid, Radiator *wavelength_grid, Error *error) + Radiator *CreateRadiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error) { DeleteError(error); return new Radiator(radiator_name, height_grid, wavelength_grid, error); @@ -49,7 +49,7 @@ namespace musica double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { DeleteError(error); radiator->GetOpticalDepths(optical_depths, num_vertical_layers, num_wavelength_bins, error); @@ -95,22 +95,19 @@ namespace musica std::size_t num_vertical_layers, std::size_t num_wavelength_bins, std::size_t num_streams, - Error *error); + Error *error) { DeleteError(error); radiator->GetAsymmetryFactors(asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, error); } - // - // in progress - // // Radiation class functions Radiator::Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error) { int error_code = 0; radiator_ = - InternalCreateRadiator(radiator_name, strlen(radiator_name), units, &height_grid, &wavelength_grid, &error_code); + InternalCreateRadiator(radiator_name, strlen(radiator_name), height_grid, wavelength_grid, &error_code); if (error_code != 0) { *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator") }; From c248e1e8c0ff502027f9a5c7b611a1bb25187db4 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 22 Jul 2024 12:55:57 -0600 Subject: [PATCH 08/31] fix bugs in c sources --- include/musica/tuvx/radiator.hpp | 60 ++++++++++++++-------------- include/musica/tuvx/radiator_map.hpp | 45 +++++++++++---------- src/tuvx/radiator.cpp | 10 ++--- src/tuvx/radiator_map.cpp | 9 +---- 4 files changed, 58 insertions(+), 66 deletions(-) diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index 840a0887..9e490a1d 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -6,18 +6,15 @@ #include #include -#include -#include -#include namespace musica { class RadiatorMap; - class Profile; - /// @brief A radiator struct used to access radiator information in tuvx - struct Radiator + /// @brief A radiator class used to access radiator information in tuvx + class Radiator { + public: /// @brief Creates a radiator instance /// @param radiator_name The name of the radiator /// @param height_grid The height grid @@ -27,16 +24,16 @@ namespace musica ~Radiator(); - /// @brief Sets the optical_depths - /// @param optical_depths The 2 dimensional optical_depths + /// @brief Sets the optical depth values + /// @param optical_depths The 2 dimensional array of optical depth values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength layers /// @param error The error struct to indicate success or failure void SetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the optical_depths - /// @param optical_depths The 2 dimensional optical_depths + /// @brief Gets the optical depth values + /// @param optical_depths The 2 dimensional array of optical depth values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength layers /// @param error The error struct to indicate success or failure @@ -44,7 +41,7 @@ namespace musica GetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); /// @brief Sets the values of the single scattering albedos - /// @param single_scattering_albedos The 2 dimensional single scattering albedos values + /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -54,8 +51,8 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the values of the single scattering albedos - /// @param single_scattering_albedos The 2 dimensional single scattering albedos values + /// @brief Gets the values of the single scattering albedo + /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -66,7 +63,7 @@ namespace musica Error *error); /// @brief Sets the values of the asymmetry factors - /// @param asymmetry_factor The asymmetery factors values to set for the radiator + /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams @@ -79,7 +76,7 @@ namespace musica Error *error); /// @brief Gets the values of the asymmetry factors - /// @param asymmetry_factor The asymmetery factors values to set for the radiator + /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams @@ -95,8 +92,7 @@ namespace musica void *radiator_; // A valid pointer to a radiator instance indicates ownership by this wrapper void *updater_; - // friend class RadiatorMap; - // friend class Profile; + friend class RadiatorMap; /// @brief Wraps an existing radiator instance. Used by RadiatorMap /// @param updater The updater for the radiator @@ -123,13 +119,13 @@ namespace musica Radiator *CreateRadiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); /// @brief Deletes a TUV-x radiator instance - /// @param radiator The radiator to delete + /// @param radiator The pointer to radiator instance /// @param error The error struct to indicate success or failure void DeleteRadiator(Radiator *radiator, Error *error); - /// @brief Sets the values of the optical depths of the radiator - /// @param radiator The radiator to get the optical depths - /// @param optical_depths The optical depths values to get for the radiator + /// @brief Sets the optical depth values + /// @param radiator The pointer to radiator instance + /// @param optical_depths The 2 dimensional array of optical depth values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -140,9 +136,9 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the values of the optical depths of the radiator - /// @param radiator The radiator to set the optical depths - /// @param optical_depths The optical depths values to set for the radiator + /// @brief Gets the optical depth values + /// @param radiator The pointer to radiator instance + /// @param optical_depths The 2 dimensional array of optical depth values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -154,8 +150,8 @@ namespace musica Error *error); /// @brief Sets the values of the single scattering albedos - /// @param radiator The radiator to set the single scattering albedos of - /// @param single_scattering_albedos The single scattering albedos values to set for the radiator + /// @param radiator The pointer to radiator instance + /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -167,8 +163,8 @@ namespace musica Error *error); /// @brief Gets the values of the single scattering albedos - /// @param radiator The radiator to get the single scattering albedos of - /// @param single_scattering_albedos The single scattering albedos values to get for the radiator + /// @param radiator The pointer to radiator instance + /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -180,7 +176,8 @@ namespace musica Error *error); /// @brief Sets the values of the asymmetry factors - /// @param asymmetry_factor The 3 dimensional asymmetery factors values to set for the radiator + /// @param radiator The pointer to radiator instance + /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams @@ -194,7 +191,8 @@ namespace musica Error *error); /// @brief Gets the values of the asymmetry factors - /// @param asymmetry_factor The 3 dimensional asymmetery factors values to get for the radiator + /// @param radiator The pointer to radiator instance + /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams @@ -261,4 +259,4 @@ namespace musica } #endif -} // namespace musica +} // namespace musica \ No newline at end of file diff --git a/include/musica/tuvx/radiator_map.hpp b/include/musica/tuvx/radiator_map.hpp index ccaa9540..c998c9ac 100644 --- a/include/musica/tuvx/radiator_map.hpp +++ b/include/musica/tuvx/radiator_map.hpp @@ -12,31 +12,32 @@ namespace musica { - /// @brief A radiator map struct used to access radiator information in tuvx - struct RadiatorMap + /// @brief Radiator map used to access radiator information in tuvx + class RadiatorMap { + public: RadiatorMap(void *radiator_map) : radiator_map_(radiator_map), owns_radiator_map_(false) { } - /// @brief @brief Creates a radiator map instance - /// @param error The error struct to indicate success or failure + /// @brief Creates radiator map + /// @param error Error to indicate success or failure RadiatorMap(Error *error); ~RadiatorMap(); /// @brief Adds a radiator to the radiator map - /// @param radiator The radiator to add - /// @param error The error struct to indicate success or failure + /// @param radiator Radiator to add + /// @param error Error to indicate success or failure void AddRadiator(Radiator *radiator, Error *error); /// @brief Returns a radiator. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later /// on to be transparent to downstream projects - /// @param radiator_name The name of the radiator - /// @param error The error struct to indicate success or failure - /// @return a radiator pointer + /// @param radiator_name Radiator name + /// @param error Error to indicate success or failure + /// @return Radiator Radiator *GetRadiator(const char *radiator_name, Error *error); private: @@ -52,26 +53,26 @@ namespace musica // The external C API for TUVX // callable by wrappers in other languages - /// @brief Creates a radiator map instance - /// @param error The error struct to indicate success or failure - /// @return a pointer to the radiator map + /// @brief Creates radiator map + /// @param error Error to indicate success or failure + /// @return Radiator map RadiatorMap *CreateRadiatorMap(Error *error); - /// @brief Deletes a radiator map instance - /// @param radiator_map The radiator map to delete - /// @param error The error struct to indicate success or failure + /// @brief Deletes radiator map + /// @param radiator_map Radiator map to delete + /// @param error Error to indicate success or failure void DeleteRadiatorMap(RadiatorMap *radiator_map, Error *error); /// @brief Adds a radiator to the radiator map - /// @param radiator_map The radiator map to add the radiator to - /// @param radiator The radiator to add - /// @param error The error struct to indicate success or failure + /// @param radiator_map Radiator map to add the radiator to + /// @param radiator Radiator to add + /// @param error Error to indicate success or failure void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error); /// @brief Returns a radiator from the radiator map - /// @param radiator_map The radiator map to get the radiator from - /// @param radiator_name The name of the radiator - /// @param error The error struct to indicate success or failure + /// @param radiator_map Radiator map to get the radiator from + /// @param radiator_name Radiator name + /// @param error Error to indicate success or failure /// @return The radiator pointer, or nullptr if the radiator is not found Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error); @@ -79,7 +80,7 @@ namespace musica // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will // not need to change void *InternalCreateRadiatorMap(int *error_code); - void InternalDeleteRadiatordMap(void *radiator_map, int *error_code); + void InternalDeleteRadiatorMap(void *radiator_map, int *error_code); void InternalAddRadiator(void *radiator_map, void *radiator, int *error_code); void * InternalGetRadiator(void *radiator_map, const char *radiator_name, std::size_t radiator_name_length, int *error_code); diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp index 10b363cc..e67962f6 100644 --- a/src/tuvx/radiator.cpp +++ b/src/tuvx/radiator.cpp @@ -1,6 +1,5 @@ // Copyright (C) 2023-2024 National Center for Atmospheric Research // SPDX-License-Identifier: Apache-2.0 -#include #include #include @@ -106,8 +105,7 @@ namespace musica Radiator::Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error) { int error_code = 0; - radiator_ = - InternalCreateRadiator(radiator_name, strlen(radiator_name), height_grid, wavelength_grid, &error_code); + radiator_ = InternalCreateRadiator(radiator_name, strlen(radiator_name), height_grid, wavelength_grid, &error_code); if (error_code != 0) { *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator") }; @@ -220,7 +218,7 @@ namespace musica *error = NoError(); } - void SetAsymmetryFactors( + void Radiator::SetAsymmetryFactors( double *asymmetry_factors, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, @@ -243,12 +241,12 @@ namespace musica *error = NoError(); } - void GetAsymmetryFactors( + void Radiator::GetAsymmetryFactors( double *asymmetry_factors, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, std::size_t num_streams, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) diff --git a/src/tuvx/radiator_map.cpp b/src/tuvx/radiator_map.cpp index 42a4958d..92263dda 100644 --- a/src/tuvx/radiator_map.cpp +++ b/src/tuvx/radiator_map.cpp @@ -34,7 +34,7 @@ namespace musica void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error) { DeleteError(error); - radiator_map->AddGrid(radiator, error); + radiator_map->AddRadiator(radiator, error); } Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error) @@ -90,7 +90,7 @@ namespace musica try { - InternalAddGRadiator(radiator_map_, radiator->radiator_, &error_code); + InternalAddRadiator(radiator_map_, radiator->radiator_, &error_code); if (error_code != 0) { *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to add radiator to radiator map") }; @@ -129,11 +129,6 @@ namespace musica *error = NoError(); } - /// @brief Returns a radiator. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on - /// to be transparent to downstream projects - /// @param radiator_name The name of the radiator - /// @param error The error struct to indicate success or failure - /// @return a radiator pointer Radiator *RadiatorMap::GetRadiator(const char *radiator_name, Error *error) { if (radiator_map_ == nullptr) From 90bd69aaba5701250e4d0186015412eb46ef6203 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 22 Jul 2024 15:45:12 -0600 Subject: [PATCH 09/31] fix bugs in f90 sources --- include/musica/tuvx/radiator.hpp | 168 ++++++++++++++-------------- src/tuvx/interface_radiator.F90 | 25 +++-- src/tuvx/interface_radiator_map.F90 | 12 +- 3 files changed, 103 insertions(+), 102 deletions(-) diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index 9e490a1d..08970fb5 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -11,63 +11,63 @@ namespace musica { class RadiatorMap; - /// @brief A radiator class used to access radiator information in tuvx + /// @brief Radiator class used to access radiator information in tuvx class Radiator { public: - /// @brief Creates a radiator instance - /// @param radiator_name The name of the radiator - /// @param height_grid The height grid - /// @param wavelength_grid The wavelength grid - /// @param error The error struct to indicate success or failure + /// @brief Creates radiator + /// @param radiator_name Radiator name + /// @param height_grid Height grid + /// @param wavelength_grid Wavelength grid + /// @param error Error to indicate success or failure Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); ~Radiator(); - /// @brief Sets the optical depth values - /// @param optical_depths The 2 dimensional array of optical depth values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength layers - /// @param error The error struct to indicate success or failure + /// @brief Sets optical depth values + /// @param optical_depths 2D array of optical depth values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure void SetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the optical depth values - /// @param optical_depths The 2 dimensional array of optical depth values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength layers - /// @param error The error struct to indicate success or failure + /// @brief Gets optical depth values + /// @param optical_depths 2D array of optical depth values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure void GetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); - /// @brief Sets the values of the single scattering albedos - /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @brief Sets single scattering albedos values + /// @param single_scattering_albedos 2D array of single scattering albedos values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure void SetSingleScatteringAlbedos( double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the values of the single scattering albedo - /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @brief Gets single scattering albedos values + /// @param single_scattering_albedos 2D array of single scattering albedos values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure void GetSingleScatteringAlbedos( double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); - /// @brief Sets the values of the asymmetry factors - /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param num_streams The number of streams - /// @param error The error struct to indicate success or failure + /// @brief Sets asymmetry factor values + /// @param asymmetry_factor 3D array of asymmetery factor values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param num_streams Number of streams + /// @param error Error to indicate success or failure void SetAsymmetryFactors( double *asymmetry_factor, std::size_t num_vertical_layers, @@ -75,12 +75,12 @@ namespace musica std::size_t num_streams, Error *error); - /// @brief Gets the values of the asymmetry factors - /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param num_streams The number of streams - /// @param error The error struct to indicate success or failure + /// @brief Gets asymmetry factor values + /// @param asymmetry_factor 3D array of asymmetery factor values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param num_streams Number of streams + /// @param error Error to indicate success or failure void GetAsymmetryFactors( double *asymmetry_factor, std::size_t num_vertical_layers, @@ -111,24 +111,24 @@ namespace musica // The external C API for TUVX // callable by wrappers in other languages - /// @brief Creates a TUV-x radiator instance - /// @param radiator_name The name of the radiator - /// @param height_grid The height grid - /// @param wavelength_grid The wavelength grid - /// @param error The error struct to indicate success or failure + /// @brief Creates radiator + /// @param radiator_name Radiator name + /// @param height_grid Height grid + /// @param wavelength_grid Wavelength grid + /// @param error Error to indicate success or failure Radiator *CreateRadiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); - /// @brief Deletes a TUV-x radiator instance - /// @param radiator The pointer to radiator instance - /// @param error The error struct to indicate success or failure + /// @brief Deletes radiator + /// @param radiator Radiator + /// @param error Error to indicate success or failure void DeleteRadiator(Radiator *radiator, Error *error); - /// @brief Sets the optical depth values - /// @param radiator The pointer to radiator instance - /// @param optical_depths The 2 dimensional array of optical depth values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @brief Sets optical depth values + /// @param radiator Radiator + /// @param optical_depths 2D array of optical depth values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure void SetRadiatorOpticalDepths( Radiator *radiator, double *optical_depths, @@ -136,12 +136,12 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the optical depth values - /// @param radiator The pointer to radiator instance - /// @param optical_depths The 2 dimensional array of optical depth values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @brief Gets optical depth values + /// @param radiator Radiator + /// @param optical_depths 2D array of optical depth values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure void GetRadiatorOpticalDepths( Radiator *radiator, double *optical_depths, @@ -149,12 +149,12 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Sets the values of the single scattering albedos - /// @param radiator The pointer to radiator instance - /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @brief Sets single scattering albedos values + /// @param radiator Radiator + /// @param single_scattering_albedos 2D array of single scattering albedos values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure void SetRadiatorSingleScatteringAlbedos( Radiator *radiator, double *single_scattering_albedos, @@ -162,12 +162,12 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the values of the single scattering albedos - /// @param radiator The pointer to radiator instance - /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @brief Gets single scattering albedos values + /// @param radiator Radiator + /// @param single_scattering_albedos 2D array of single scattering albedos values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure void GetRadiatorSingleScatteringAlbedos( Radiator *radiator, double *single_scattering_albedos, @@ -175,13 +175,13 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Sets the values of the asymmetry factors - /// @param radiator The pointer to radiator instance - /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param num_streams The number of streams - /// @param error The error struct to indicate success or failure + /// @brief Sets asymmetry factor values + /// @param radiator Radiator + /// @param asymmetry_factor 3D array of asymmetery factor values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param num_streams Number of streams + /// @param error Error to indicate success or failure void SetRadiatorAsymmetryFactors( Radiator *radiator, double *asymmetry_factor, @@ -190,13 +190,13 @@ namespace musica std::size_t num_streams, Error *error); - /// @brief Gets the values of the asymmetry factors - /// @param radiator The pointer to radiator instance - /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param num_streams The number of streams - /// @param error The error struct to indicate success or failure + /// @brief Gets asymmetry factor values + /// @param radiator Radiator + /// @param asymmetry_factor 3D array of asymmetery factor values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param num_streams Number of streams + /// @param error Error to indicate success or failure void GetRadiatorAsymmetryFactors( double *asymmetry_factor, std::size_t num_vertical_layers, diff --git a/src/tuvx/interface_radiator.F90 b/src/tuvx/interface_radiator.F90 index 3cb5bb89..cbdc176b 100644 --- a/src/tuvx/interface_radiator.F90 +++ b/src/tuvx/interface_radiator.F90 @@ -17,9 +17,8 @@ function internal_create_radiator(radiator_name, radiator_name_length, & bind(C, name="InternalCreateRadiator") use iso_c_binding, only: c_ptr, c_f_pointer, c_char, c_loc, c_size_t, c_int use musica_string, only: string_t - use tuvx_radiator_from_host, only: radiator_from_host_t - use tuvx_grid, only : grid_t + use tuvx_grid, only: grid_t ! arguments type(c_ptr) :: radiator @@ -32,8 +31,9 @@ function internal_create_radiator(radiator_name, radiator_name_length, & ! variables type(radiator_from_host_t), pointer :: f_radiator type(string_t) :: f_name - type(grid_t) :: f_height_grid - type(grid_t) :: f_wavelength_grid + type(grid_t), pointer :: f_height_grid + type(grid_t), pointer :: f_wavelength_grid + integer :: i allocate(character(len=radiator_name_length) :: f_name%val_) do i = 1, radiator_name_length @@ -103,7 +103,7 @@ subroutine internal_delete_radiator_updater(updater, error_code) & integer(kind=c_int), intent(out) :: error_code ! variables - type(radiator_t), pointer :: f_updater + type(radiator_updater_t), pointer :: f_updater call c_f_pointer(updater, f_updater) if (associated(f_updater)) then @@ -130,7 +130,7 @@ subroutine internal_set_optical_depths(radiator_updater, optical_depths, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_optical_depths(:,:) + real(kind=dk), pointer :: f_optical_depths(:,:) call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(optical_depths, f_optical_depths, & @@ -164,7 +164,7 @@ subroutine internal_get_optical_depths(radiator_updater, optical_depths, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_optical_depths(:,:) + real(kind=dk), pointer :: f_optical_depths(:,:) call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(optical_depths, f_optical_depths, & @@ -198,7 +198,7 @@ subroutine internal_set_single_scattering_albedos(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_single_scattering_albedos(:,:) + real(kind=dk), pointer :: f_single_scattering_albedos(:,:) call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, & @@ -232,7 +232,7 @@ subroutine internal_get_single_scattering_albedos(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_single_scattering_albedos(:,:) + real(kind=dk), pointer :: f_single_scattering_albedos(:,:) call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, & @@ -267,7 +267,7 @@ subroutine internal_set_asymmetry_factors(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) + real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(asymmetry_factors, f_asymmetry_factors, & @@ -302,7 +302,7 @@ subroutine internal_get_asymmetry_factors(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) + real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(asymmetry_factors, f_asymmetry_factors, & @@ -316,7 +316,8 @@ subroutine internal_get_asymmetry_factors(radiator_updater, & end if f_asymmetry_factors(:,:,:) = f_updater%radiator_%state_%layer_G_(:,:,:) -end subroutine internal_set_asymmetry_factors +end subroutine internal_get_asymmetry_factors !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end module tuvx_interface_radiator \ No newline at end of file diff --git a/src/tuvx/interface_radiator_map.F90 b/src/tuvx/interface_radiator_map.F90 index 1d30e33c..7a0cfadd 100644 --- a/src/tuvx/interface_radiator_map.F90 +++ b/src/tuvx/interface_radiator_map.F90 @@ -3,11 +3,11 @@ ! module tuvx_interface_radiator_map - use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char + use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char use tuvx_radiator_warehouse, only : radiator_warehouse_t use tuvx_radiator, only : radiator_t - use musica_tuvx_util, only : to_f_string, string_t_c - use musica_string, only : string_t + use musica_tuvx_util, only : to_f_string, string_t_c + use musica_string, only : string_t implicit none @@ -107,7 +107,7 @@ function internal_get_radiator(radiator_map, c_radiator_name, & class(radiator_t), pointer :: f_radiator type(radiator_warehouse_t), pointer :: radiator_warehouse character(len=:), allocatable :: f_radiator_name - + integer :: i ! result type(c_ptr) :: radiator_ptr @@ -130,7 +130,7 @@ function internal_get_radiator(radiator_map, c_radiator_name, & radiator_ptr = c_null_ptr end select - end function interal_get_radiator + end function internal_get_radiator !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -138,7 +138,7 @@ function internal_get_radiator_updater_from_map(radiator_map, radiator, error_co result(updater) bind(C, name="InternalGetRadiatorUpdaterFromMap") use iso_c_binding, only: c_ptr, c_f_pointer, c_loc use tuvx_radiator_warehouse, only: radiator_warehouse_t - use tuvx_radiator_from_host, only: radiator_from_host_t, gradiator_updater_t + use tuvx_radiator_from_host, only: radiator_from_host_t, radiator_updater_t ! arguments type(c_ptr), intent(in), value :: radiator_map From 21ac00eb68eb5e939d6d1d9ee2c5933f18452356 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 24 Jul 2024 12:34:42 -0600 Subject: [PATCH 10/31] fix bugs --- fortran/tuvx/tuvx.F90 | 48 +++++++-- include/musica/tuvx/tuvx.hpp | 9 ++ src/packaging/CMakeLists.txt | 2 + src/tuvx/interface.F90 | 161 ++++++++++++++++------------ src/tuvx/interface_radiator_map.F90 | 2 +- src/tuvx/tuvx.cpp | 19 ++++ 6 files changed, 167 insertions(+), 74 deletions(-) diff --git a/fortran/tuvx/tuvx.F90 b/fortran/tuvx/tuvx.F90 index 94e4edd0..082712d8 100644 --- a/fortran/tuvx/tuvx.F90 +++ b/fortran/tuvx/tuvx.F90 @@ -2,11 +2,13 @@ ! SPDX-License-Identifier: Apache-2.0 ! module musica_tuvx - use iso_c_binding, only: c_ptr, c_null_ptr - use musica_tuvx_grid, only : grid_t - use musica_tuvx_grid_map, only : grid_map_t - use musica_tuvx_profile, only : profile_t - use musica_tuvx_profile_map, only : profile_map_t + use iso_c_binding, only: c_ptr, c_null_ptr + use musica_tuvx_grid, only : grid_t + use musica_tuvx_grid_map, only : grid_map_t + use musica_tuvx_profile, only : profile_t + use musica_tuvx_profile_map, only : profile_map_t + use musica_tuvx_radiator, only : radiator_t + use musica_tuvx_radiator_map, only : radiator_map_t implicit none @@ -45,9 +47,17 @@ function get_profile_map_c(tuvx, error) bind(C, name="GetProfileMap") use musica_util, only: error_t_c use iso_c_binding, only: c_ptr type(c_ptr), value, intent(in) :: tuvx - type(error_t_c), intent(inout) :: error - type(c_ptr) :: get_profile_map_c + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_profile_map_c end function get_profile_map_c + + function get_radiator_map_c(tuvx, error) bind(C, name="GetRadiatorMap") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr + type(c_ptr), value, intent(in) :: tuvx + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_radiator_map_c + end function get_radiator_map_c end interface !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -59,6 +69,8 @@ end function get_profile_map_c procedure :: get_grids ! Create a profile map procedure :: get_profiles + ! Create a radiator map + procedure :: get_radiators ! Deallocate the tuvx instance final :: finalize end type tuvx_t @@ -154,6 +166,28 @@ end function get_profiles !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !> Get the radiator map + function get_radiators(this, error) result(radiator_map) + use musica_util, only: error_t, error_t_c + + ! Arguments + class(tuvx_t), intent(inout) :: this + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + ! Return value + type(radiator_map_t), pointer :: radiator_map + + radiator_map => radiator_map_t(get_radiator_map_c(this%ptr_, error_c)) + + error = error_t(error_c) + + end function get_radiators + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !> Deallocate the tuvx instance subroutine finalize(this) use musica_util, only: error_t, error_t_c, assert diff --git a/include/musica/tuvx/tuvx.hpp b/include/musica/tuvx/tuvx.hpp index e89d7685..47516256 100644 --- a/include/musica/tuvx/tuvx.hpp +++ b/include/musica/tuvx/tuvx.hpp @@ -7,6 +7,7 @@ #include #include +#include #include #include @@ -38,6 +39,12 @@ namespace musica /// @return a profile map pointer ProfileMap *CreateProfileMap(Error *error); + /// @brief Create a radiator map. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later + /// on to be transparent to downstream projects + /// @param error The error struct to indicate success or failure + /// @return a radiator map pointer + RadiatorMap *CreateRadiatorMap(Error *error); + ~TUVX(); private: @@ -55,6 +62,7 @@ namespace musica void DeleteTuvx(const TUVX *tuvx, Error *error); GridMap *GetGridMap(TUVX *tuvx, Error *error); ProfileMap *GetProfileMap(TUVX *tuvx, Error *error); + RadiatorMap *GetRadiatorMap(TUVX *tuvx, Error *error); // for use by musica interanlly. If tuvx ever gets rewritten in C++, these functions will // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will @@ -63,6 +71,7 @@ namespace musica void InternalDeleteTuvx(void *tuvx, int *error_code); void *InternalGetGridMap(void *tuvx, int *error_code); void *InternalGetProfileMap(void *tuvx, int *error_code); + void *InternalGetRadiatorMap(void *tuvx, int *error_code); #ifdef __cplusplus } diff --git a/src/packaging/CMakeLists.txt b/src/packaging/CMakeLists.txt index 17c27bb3..9d04933f 100644 --- a/src/packaging/CMakeLists.txt +++ b/src/packaging/CMakeLists.txt @@ -76,6 +76,8 @@ if (MUSICA_ENABLE_TUVX) ${MUSICA_FORTRAN_SRC_DIR}/tuvx/grid_map.F90 ${MUSICA_FORTRAN_SRC_DIR}/tuvx/profile.F90 ${MUSICA_FORTRAN_SRC_DIR}/tuvx/profile_map.F90 + ${MUSICA_FORTRAN_SRC_DIR}/tuvx/radiator.F90 + ${MUSICA_FORTRAN_SRC_DIR}/tuvx/radiator_map.F90 ${MUSICA_FORTRAN_SRC_DIR}/tuvx/tuvx.F90 DESTINATION ${MUSICA_INSTALL_INCLUDE_DIR}/musica/fortran diff --git a/src/tuvx/interface.F90 b/src/tuvx/interface.F90 index 8c756bf5..624a6583 100644 --- a/src/tuvx/interface.F90 +++ b/src/tuvx/interface.F90 @@ -3,96 +3,101 @@ ! module tuvx_interface - use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char - use tuvx_core, only : core_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - use musica_tuvx_util, only : to_f_string, string_t_c - use musica_string, only : string_t - - implicit none +use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char +use tuvx_core, only : core_t +use tuvx_grid_warehouse, only : grid_warehouse_t +use tuvx_profile_warehouse, only : profile_warehouse_t +use tuvx_radiator_warehouse, only : radiator_warehouse_t +use musica_tuvx_util, only : to_f_string, string_t_c +use musica_string, only : string_t + +implicit none - private +private - contains +contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_create_tuvx(c_config_path, config_path_length, error_code) bind(C, name="InternalCreateTuvx") - use iso_c_binding, only: c_ptr, c_f_pointer + function internal_create_tuvx(c_config_path, config_path_length, error_code) + bind(C, name="InternalCreateTuvx") + use iso_c_binding, only: c_ptr, c_f_pointer - ! arguments - character(kind=c_char), dimension(*), intent(in) :: c_config_path - integer(kind=c_size_t), value :: config_path_length - integer(kind=c_int), intent(out) :: error_code + ! arguments + character(kind=c_char), dimension(*), intent(in) :: c_config_path + integer(kind=c_size_t), value :: config_path_length + integer(kind=c_int), intent(out) :: error_code - ! local variables - character(len=:), allocatable :: f_config_path - type(c_ptr) :: internal_create_tuvx - type(core_t), pointer :: core - type(string_t) :: musica_config_path - integer :: i + ! local variables + character(len=:), allocatable :: f_config_path + type(c_ptr) :: internal_create_tuvx + type(core_t), pointer :: core + type(string_t) :: musica_config_path + integer :: i - allocate(character(len=config_path_length) :: f_config_path) - do i = 1, config_path_length - f_config_path(i:i) = c_config_path(i) - end do + allocate(character(len=config_path_length) :: f_config_path) + do i = 1, config_path_length + f_config_path(i:i) = c_config_path(i) + end do - musica_config_path = string_t(f_config_path) + musica_config_path = string_t(f_config_path) - core => core_t(musica_config_path) + core => core_t(musica_config_path) - deallocate(f_config_path) - error_code = 0 + deallocate(f_config_path) + error_code = 0 - internal_create_tuvx = c_loc(core) + internal_create_tuvx = c_loc(core) - end function internal_create_tuvx + end function internal_create_tuvx !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_delete_tuvx(tuvx, error_code) bind(C, name="InternalDeleteTuvx") - use iso_c_binding, only: c_ptr, c_f_pointer + subroutine internal_delete_tuvx(tuvx, error_code) + bind(C, name="InternalDeleteTuvx") + use iso_c_binding, only: c_ptr, c_f_pointer - ! arguments - type(c_ptr), value, intent(in) :: tuvx - integer(kind=c_int), intent(out) :: error_code + ! arguments + type(c_ptr), value, intent(in) :: tuvx + integer(kind=c_int), intent(out) :: error_code - ! local variables - type(core_t), pointer :: core - - call c_f_pointer(tuvx, core) - if (associated(core)) then - deallocate(core) - end if - end subroutine internal_delete_tuvx + ! local variables + type(core_t), pointer :: core + + call c_f_pointer(tuvx, core) + if (associated(core)) then + deallocate(core) + end if + end subroutine internal_delete_tuvx !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_get_grid_map(tuvx, error_code) result(grid_map_ptr) bind(C, name="InternalGetGridMap") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int - - ! arguments - type(c_ptr), intent(in), value :: tuvx - integer(kind=c_int), intent(out) :: error_code - - ! result - type(c_ptr) :: grid_map_ptr - - ! variables - type(core_t), pointer :: core - type(grid_warehouse_t), pointer :: grid_warehouse - - call c_f_pointer(tuvx, core) - grid_warehouse => core%get_grid_warehouse() - - grid_map_ptr = c_loc(grid_warehouse) + function internal_get_grid_map(tuvx, error_code) result(grid_map_ptr) + bind(C, name="InternalGetGridMap") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + + ! arguments + type(c_ptr), intent(in), value :: tuvx + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: grid_map_ptr + + ! variables + type(core_t), pointer :: core + type(grid_warehouse_t), pointer :: grid_warehouse + + call c_f_pointer(tuvx, core) + grid_warehouse => core%get_grid_warehouse() + + grid_map_ptr = c_loc(grid_warehouse) - end function internal_get_grid_map + end function internal_get_grid_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_get_profile_map(tuvx, error_code) result(profile_map_ptr) bind(C, name="InternalGetProfileMap") + function internal_get_profile_map(tuvx, error_code) result(profile_map_ptr) + bind(C, name="InternalGetProfileMap") use iso_c_binding, only: c_ptr, c_f_pointer, c_int ! arguments @@ -115,4 +120,28 @@ end function internal_get_profile_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -end module tuvx_interface + function internal_get_radiator_map(tuvx, error_code) result(radiator_map_ptr) + bind(C, name="InternalGetRadiatorMap") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + + ! arguments + type(c_ptr), intent(in), value :: tuvx + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: radiator_map_ptr + + ! variables + type(core_t), pointer :: core + type(radiator_warehouse_t), pointer :: radiator_warehouse + + call c_f_pointer(tuvx, core) + radiator_warehouse => core%get_radiator_warehouse() + + radiator_map_ptr = c_loc(radiator_warehouse) + + end function internal_get_radiator_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface \ No newline at end of file diff --git a/src/tuvx/interface_radiator_map.F90 b/src/tuvx/interface_radiator_map.F90 index 7a0cfadd..81c26c52 100644 --- a/src/tuvx/interface_radiator_map.F90 +++ b/src/tuvx/interface_radiator_map.F90 @@ -107,7 +107,7 @@ function internal_get_radiator(radiator_map, c_radiator_name, & class(radiator_t), pointer :: f_radiator type(radiator_warehouse_t), pointer :: radiator_warehouse character(len=:), allocatable :: f_radiator_name - integer :: i + integer :: i ! result type(c_ptr) :: radiator_ptr diff --git a/src/tuvx/tuvx.cpp b/src/tuvx/tuvx.cpp index 7c17cf02..9abd977d 100644 --- a/src/tuvx/tuvx.cpp +++ b/src/tuvx/tuvx.cpp @@ -58,6 +58,12 @@ namespace musica return tuvx->CreateProfileMap(error); } + RadiatorMap *GetRadiatorMap(TUVX *tuvx, Error *error) + { + DeleteError(error); + return tuvx->CreateRadiatorMap(error); + } + // TUVX class functions TUVX::TUVX() @@ -131,4 +137,17 @@ namespace musica return profile_map; } + RadiatorMap *TUVX::CreateRadiatorMap(Error *error) + { + *error = NoError(); + int error_code = 0; + RadiatorMap *radiator_map = new RadiatorMap(InternalGetRadiatorMap(tuvx_, &error_code)); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator map") }; + return nullptr; + } + return radiator_map; + } + } // namespace musica From f5256ad9c2880867364d810cb8fce5859d9e9706 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 24 Jul 2024 13:40:56 -0600 Subject: [PATCH 11/31] temp add radiator test --- cmake/dependencies.cmake | 3 +- src/test/unit/tuvx/CMakeLists.txt | 1 + src/test/unit/tuvx/radiatortest.cpp | 113 ++++++++++++++++++++++++++++ 3 files changed, 116 insertions(+), 1 deletion(-) create mode 100644 src/test/unit/tuvx/radiatortest.cpp diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index df84a956..d819d737 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -75,7 +75,8 @@ if (MUSICA_ENABLE_TUVX AND MUSICA_BUILD_C_CXX_INTERFACE) set(TUVX_INSTALL_INCLUDE_DIR ${MUSICA_INSTALL_INCLUDE_DIR} CACHE STRING "" FORCE) set_git_default(TUVX_GIT_REPOSITORY https://github.com/NCAR/tuv-x.git) - set_git_default(TUVX_GIT_TAG 80f896a0fb591987c2a79209377bd6f599b4fb6f) + # set_git_default(TUVX_GIT_TAG 80f896a0fb591987c2a79209377bd6f599b4fb6f) + set_git_default(TUVX_GIT_TAG make-radiator-updatable) FetchContent_Declare(tuvx GIT_REPOSITORY ${TUVX_GIT_REPOSITORY} diff --git a/src/test/unit/tuvx/CMakeLists.txt b/src/test/unit/tuvx/CMakeLists.txt index 28b926c0..05dcc0f8 100644 --- a/src/test/unit/tuvx/CMakeLists.txt +++ b/src/test/unit/tuvx/CMakeLists.txt @@ -1,6 +1,7 @@ include(test_util) create_standard_test_cxx(NAME tuvx_c_api SOURCES tuvx_c_api.cpp) +create_standard_test_cxx(NAME tuvx_radiator_test SOURCES radiatortest.cpp) ################################################################################ # Copy tuvx test data diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp new file mode 100644 index 00000000..e978e423 --- /dev/null +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -0,0 +1,113 @@ +#include +#include + +#include +#include + +using namespace musica; + +// Test fixture for the TUVX C API +class TuvxCApiTest : public ::testing::Test +{ + protected: + TUVX* tuvx; + + // the function that google test actually calls before each test + void SetUp() override + { + tuvx = nullptr; + } + + void SetUp(const char* config_path) + { + Error error; + tuvx = CreateTuvx(config_path, &error); + if (!IsSuccess(error)) + { + std::cerr << "Error creating TUVX instance: " << error.message_.value_ << std::endl; + } + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); + } + + void TearDown() override + { + if (tuvx == nullptr) + { + return; + } + Error error; + DeleteTuvx(tuvx, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); + tuvx = nullptr; + } +}; + +TEST_F(TuvxCApiTest, CannotGetConfiguredRadiator) +{ + const char* yaml_config_path = "examples/ts1_tsmlt.yml"; + SetUp(yaml_config_path); + Error error; + RadiatorMap* radiator_map = GetRadiatorMap(tuvx, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(radiator_map, nullptr); + Radiator* radiator = GetRadiator(radiator_map, "Aerosol radiator", &error); + ASSERT_FALSE(IsSuccess(error)); // non-host grid + ASSERT_EQ(radiator, nullptr); + DeleteRadiatorMap(radiator_map, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); +} + +TEST_F(TuvxCApiTest, CanCreateRadiator) +{ + Error error; + Grid* height = CreateGrid("height", "km", 3, &error); + Grid* wavelength = CreateGrid("wavelength", "nm", 2, &error); + Radiator* radiator = CreateRadiator("foo", height, wavelength, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(radiator, nullptr); + + // TODO(jiwon) - Is 1d array of input okay? + // ! specify optical depths only + // od(:,1) = (/ 12.5_dk, 42.3_dk, 0.4_dk /) + // od(:,2) = (/ 49.2_dk, 12.5_dk, 92.1_dk /) + + std::vector optical_depths_flattened = {10.0, 20.0, 30.0, 40.0, 50.0, 60.0}; + std::size_t num_vertical_layers = 3; + std::size_t num_wavelength_bins = 2; + SetRadiatorOpticalDepths(radiator, optical_depths_flattened.data(), num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + + for(auto& depth : optical_depths_flattened) + { + depth =- 10.0; + } + GetRadiatorOpticalDepths(radiator, optical_depths_flattened.data(), num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(optical_depths_flattened[0], 0.0); + ASSERT_EQ(optical_depths_flattened[1], 10.0); + ASSERT_EQ(optical_depths_flattened[2], 20.0); + ASSERT_EQ(optical_depths_flattened[0], 30.0); + ASSERT_EQ(optical_depths_flattened[1], 40.0); + ASSERT_EQ(optical_depths_flattened[2], 50.0); + + num_vertical_layers = 2; + num_wavelength_bins = 2; + std::vector single_scattering_albedos_flattened = { 100.0, 100.0, 200, 200 }; + SetRadiatorSingleScatteringAlbedos(radiator, single_scattering_albedos_flattened.data(), num_vertical_layers, num_wavelength_bins, &error) + ASSERT_TRUE(IsSuccess(error)); + for (auto& albedos : single_scattering_albedos_flattened) + { + albedos =+ 100.0; + } + // GetGridMidpoints(grid, midpoints.data(), midpoints.size(), &error); + // GetRadiatorSingleScatteringAlbedos(radiator, single_scattering_albedos_flattened.data(), num_vertical_layers, num_wavelength_bins, &error) + // ASSERT_TRUE(IsSuccess(error)); + // ASSERT_EQ(midpoints[0], 50.0); + // ASSERT_EQ(midpoints[1], 150.0); + // DeleteGrid(grid, &error); + // ASSERT_TRUE(IsSuccess(error)); + // DeleteError(&error); +} \ No newline at end of file From 5ac631d4facb9d32d918d97592bfbdc230a82fa7 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 24 Jul 2024 14:43:00 -0600 Subject: [PATCH 12/31] fix bugs --- src/test/unit/tuvx/radiatortest.cpp | 2 +- src/tuvx/interface.F90 | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp index e978e423..43b52c3b 100644 --- a/src/test/unit/tuvx/radiatortest.cpp +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -96,7 +96,7 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) num_vertical_layers = 2; num_wavelength_bins = 2; std::vector single_scattering_albedos_flattened = { 100.0, 100.0, 200, 200 }; - SetRadiatorSingleScatteringAlbedos(radiator, single_scattering_albedos_flattened.data(), num_vertical_layers, num_wavelength_bins, &error) + SetRadiatorSingleScatteringAlbedos(radiator, single_scattering_albedos_flattened.data(), num_vertical_layers, num_wavelength_bins, &error); ASSERT_TRUE(IsSuccess(error)); for (auto& albedos : single_scattering_albedos_flattened) { diff --git a/src/tuvx/interface.F90 b/src/tuvx/interface.F90 index 624a6583..bc87c977 100644 --- a/src/tuvx/interface.F90 +++ b/src/tuvx/interface.F90 @@ -19,7 +19,7 @@ module tuvx_interface !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_create_tuvx(c_config_path, config_path_length, error_code) + function internal_create_tuvx(c_config_path, config_path_length, error_code) & bind(C, name="InternalCreateTuvx") use iso_c_binding, only: c_ptr, c_f_pointer @@ -53,7 +53,7 @@ end function internal_create_tuvx !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_delete_tuvx(tuvx, error_code) + subroutine internal_delete_tuvx(tuvx, error_code) & bind(C, name="InternalDeleteTuvx") use iso_c_binding, only: c_ptr, c_f_pointer @@ -72,7 +72,7 @@ end subroutine internal_delete_tuvx !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_get_grid_map(tuvx, error_code) result(grid_map_ptr) + function internal_get_grid_map(tuvx, error_code) result(grid_map_ptr) & bind(C, name="InternalGetGridMap") use iso_c_binding, only: c_ptr, c_f_pointer, c_int @@ -96,7 +96,7 @@ end function internal_get_grid_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_get_profile_map(tuvx, error_code) result(profile_map_ptr) + function internal_get_profile_map(tuvx, error_code) result(profile_map_ptr) & bind(C, name="InternalGetProfileMap") use iso_c_binding, only: c_ptr, c_f_pointer, c_int @@ -120,7 +120,7 @@ end function internal_get_profile_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_get_radiator_map(tuvx, error_code) result(radiator_map_ptr) + function internal_get_radiator_map(tuvx, error_code) result(radiator_map_ptr) & bind(C, name="InternalGetRadiatorMap") use iso_c_binding, only: c_ptr, c_f_pointer, c_int From 0ae60e1c291a0812c5a2af15f08fe02896868481 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 26 Jul 2024 17:47:09 -0600 Subject: [PATCH 13/31] passed test --- include/musica/tuvx/grid.hpp | 2 + include/musica/tuvx/radiator.hpp | 5 +- src/test/unit/tuvx/radiatortest.cpp | 149 ++++++++++++++++++++++------ src/tuvx/interface_radiator.F90 | 57 +++++++---- src/tuvx/radiator.cpp | 2 +- 5 files changed, 162 insertions(+), 53 deletions(-) diff --git a/include/musica/tuvx/grid.hpp b/include/musica/tuvx/grid.hpp index c8bb4a60..86c7f46f 100644 --- a/include/musica/tuvx/grid.hpp +++ b/include/musica/tuvx/grid.hpp @@ -12,6 +12,7 @@ namespace musica { class GridMap; class Profile; + class Radiator; /// @brief A grid struct used to access grid information in tuvx struct Grid @@ -55,6 +56,7 @@ namespace musica friend class GridMap; friend class Profile; + friend class Radiator; /// @brief Wraps an existing grid instance. Used by GridMap /// @param updater The updater for the grid diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index 08970fb5..f08b9b33 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -198,6 +198,7 @@ namespace musica /// @param num_streams Number of streams /// @param error Error to indicate success or failure void GetRadiatorAsymmetryFactors( + Radiator *radiator, double *asymmetry_factor, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, @@ -210,8 +211,8 @@ namespace musica void *InternalCreateRadiator( const char *radiator_name, std::size_t radiator_name_length, - Grid *hegiht_grid, - Grid *wavelength_grid, + void *height_grid, + void *wavelength_grid, int *error_code); void InternalDeleteRadiator(void *radiator, int *error_code); void *InternalGetRadiatorUpdater(void *radiator, int *error_code); diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp index 43b52c3b..3419d0e5 100644 --- a/src/test/unit/tuvx/radiatortest.cpp +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -3,6 +3,7 @@ #include #include +#include using namespace musica; @@ -68,46 +69,130 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) Radiator* radiator = CreateRadiator("foo", height, wavelength, &error); ASSERT_TRUE(IsSuccess(error)); ASSERT_NE(radiator, nullptr); - - // TODO(jiwon) - Is 1d array of input okay? - // ! specify optical depths only - // od(:,1) = (/ 12.5_dk, 42.3_dk, 0.4_dk /) - // od(:,2) = (/ 49.2_dk, 12.5_dk, 92.1_dk /) - - std::vector optical_depths_flattened = {10.0, 20.0, 30.0, 40.0, 50.0, 60.0}; + std::size_t num_vertical_layers = 3; std::size_t num_wavelength_bins = 2; - SetRadiatorOpticalDepths(radiator, optical_depths_flattened.data(), num_vertical_layers, num_wavelength_bins, &error); + + // Allocate array as 1D + double* optical_depths_1D = new double[num_wavelength_bins * num_vertical_layers]; + // Allocate an array of pointers to each row + double** optical_depths = new double* [num_vertical_layers]; + // Fill in the pointers to the rows + for(int row =0; row single_scattering_albedos_flattened = { 100.0, 100.0, 200, 200 }; - SetRadiatorSingleScatteringAlbedos(radiator, single_scattering_albedos_flattened.data(), num_vertical_layers, num_wavelength_bins, &error); + ASSERT_EQ(optical_depths[0][0], 10.0); + ASSERT_EQ(optical_depths[0][1], 20.0); + ASSERT_EQ(optical_depths[1][0], 30.0); + ASSERT_EQ(optical_depths[1][1], 40.0); + ASSERT_EQ(optical_depths[2][0], 50.0); + ASSERT_EQ(optical_depths[2][1], 60.0); + + // Test for single scattering albedos + double* albedos_1D = new double[num_wavelength_bins * num_vertical_layers]; + double** albedos = new double* [num_vertical_layers]; + for(int row =0; row radiator_from_host_t(f_name, f_height_grid, f_wavelength_grid) + call c_f_pointer(height_grid_updater_c, f_height_grid_updater) + call c_f_pointer(wavelength_grid_updater_c, f_wavelength_grid_updater) + f_radiator => radiator_from_host_t(f_name, f_height_grid_updater%grid_, & + f_wavelength_grid_updater%grid_) radiator = c_loc(f_radiator) end function internal_create_radiator @@ -131,10 +132,17 @@ subroutine internal_set_optical_depths(radiator_updater, optical_depths, & ! variables type(radiator_updater_t), pointer :: f_updater real(kind=dk), pointer :: f_optical_depths(:,:) - + integer(kind=c_int) :: i, iRow, iCol !TODO(test)jiwon + call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(optical_depths, f_optical_depths, & - [num_vertical_layers, num_wavelength_bins]) + [num_vertical_layers, num_wavelength_bins]) + + do iRow = 1, num_wavelength_bins + do iCol = 1, num_vertical_layers + print *, "Value of f_i(" , iCol, ",", iRow, ") = ", f_optical_depths(iCol, iRow) + end do + end do if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) & .or. (size(f_updater%radiator_%state_%layer_OD_, 2) /= num_wavelength_bins)) & @@ -165,7 +173,8 @@ subroutine internal_get_optical_depths(radiator_updater, optical_depths, & ! variables type(radiator_updater_t), pointer :: f_updater real(kind=dk), pointer :: f_optical_depths(:,:) - + integer(kind=c_int) :: iRow, iCol + call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(optical_depths, f_optical_depths, & [num_vertical_layers, num_wavelength_bins]) @@ -199,11 +208,17 @@ subroutine internal_set_single_scattering_albedos(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater real(kind=dk), pointer :: f_single_scattering_albedos(:,:) - + integer(kind=c_int) :: i, iRow, iCol call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, & [num_vertical_layers, num_wavelength_bins]) + do iRow = 1, num_wavelength_bins + do iCol = 1, num_vertical_layers + print *, "Value of f_i(" , iCol, ",", iRow, ") = ", f_single_scattering_albedos(iCol, iRow) + end do + end do + if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) & .or. (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins)) & then @@ -268,11 +283,17 @@ subroutine internal_set_asymmetry_factors(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) - + integer(kind=c_int) :: i, iRow, iCol call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(asymmetry_factors, f_asymmetry_factors, & [num_vertical_layers, num_wavelength_bins, num_streams]) + do iRow = 1, num_wavelength_bins + do iCol = 1, num_vertical_layers + print *, "Value of f_i(" , iCol, ",", iRow, ") = ", f_asymmetry_factors(iCol, iRow, num_streams) + end do + end do + if ((size(f_updater%radiator_%state_%layer_G_, 1) /= num_vertical_layers) & .or. (size(f_updater%radiator_%state_%layer_G_, 2) /= num_wavelength_bins) & .or. (size(f_updater%radiator_%state_%layer_G_, 3) /= num_streams)) then diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp index e67962f6..d0d76878 100644 --- a/src/tuvx/radiator.cpp +++ b/src/tuvx/radiator.cpp @@ -105,7 +105,7 @@ namespace musica Radiator::Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error) { int error_code = 0; - radiator_ = InternalCreateRadiator(radiator_name, strlen(radiator_name), height_grid, wavelength_grid, &error_code); + radiator_ = InternalCreateRadiator(radiator_name, strlen(radiator_name), height_grid->updater_, wavelength_grid->updater_, &error_code); if (error_code != 0) { *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator") }; From 80349d4615587f7e2f6b6e6119217d9a926f156f Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 31 Jul 2024 09:46:41 -0600 Subject: [PATCH 14/31] incomplete test --- src/test/unit/tuvx/radiatortest.cpp | 236 ++++++++++++++++++++++++---- 1 file changed, 207 insertions(+), 29 deletions(-) diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp index 3419d0e5..4313a14e 100644 --- a/src/test/unit/tuvx/radiatortest.cpp +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -45,21 +45,21 @@ class TuvxCApiTest : public ::testing::Test } }; -TEST_F(TuvxCApiTest, CannotGetConfiguredRadiator) -{ - const char* yaml_config_path = "examples/ts1_tsmlt.yml"; - SetUp(yaml_config_path); - Error error; - RadiatorMap* radiator_map = GetRadiatorMap(tuvx, &error); - ASSERT_TRUE(IsSuccess(error)); - ASSERT_NE(radiator_map, nullptr); - Radiator* radiator = GetRadiator(radiator_map, "Aerosol radiator", &error); - ASSERT_FALSE(IsSuccess(error)); // non-host grid - ASSERT_EQ(radiator, nullptr); - DeleteRadiatorMap(radiator_map, &error); - ASSERT_TRUE(IsSuccess(error)); - DeleteError(&error); -} +// TEST_F(TuvxCApiTest, CannotGetConfiguredRadiator) +// { +// const char* yaml_config_path = "examples/ts1_tsmlt.yml"; +// SetUp(yaml_config_path); +// Error error; +// RadiatorMap* radiator_map = GetRadiatorMap(tuvx, &error); +// ASSERT_TRUE(IsSuccess(error)); +// ASSERT_NE(radiator_map, nullptr); +// Radiator* radiator = GetRadiator(radiator_map, "foo", &error); +// ASSERT_FALSE(IsSuccess(error)); // non-host grid +// ASSERT_EQ(radiator, nullptr); +// DeleteRadiatorMap(radiator_map, &error); +// ASSERT_TRUE(IsSuccess(error)); +// DeleteError(&error); +// } TEST_F(TuvxCApiTest, CanCreateRadiator) { @@ -70,6 +70,7 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) ASSERT_TRUE(IsSuccess(error)); ASSERT_NE(radiator, nullptr); + // Test for optical depths std::size_t num_vertical_layers = 3; std::size_t num_wavelength_bins = 2; @@ -82,7 +83,7 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) { optical_depths[row] = &optical_depths_1D[row * num_wavelength_bins]; } - + // int i = 1; for(int row = 0; row < num_vertical_layers; row++) { @@ -94,10 +95,9 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) } SetRadiatorOpticalDepths(radiator, optical_depths[0], num_vertical_layers, num_wavelength_bins, &error); ASSERT_TRUE(IsSuccess(error)); - for(int row = 0; row < num_vertical_layers; row++) { - for(int col = 0; col < num_vertical_layers; col++) + for(int col = 0; col < num_wavelength_bins; col++) { optical_depths[row][col] =- 999.0; } @@ -129,10 +129,9 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) } SetRadiatorSingleScatteringAlbedos(radiator, albedos[0], num_vertical_layers, num_wavelength_bins, &error); ASSERT_TRUE(IsSuccess(error)); - for(int row = 0; row < num_vertical_layers; row++) { - for(int col = 0; col < num_vertical_layers; col++) + for(int col = 0; col < num_wavelength_bins; col++) { albedos[row][col] =- 999.0; } @@ -165,10 +164,9 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) std::size_t num_streams = 1; SetRadiatorAsymmetryFactors(radiator, factors[0], num_vertical_layers, num_wavelength_bins, num_streams, &error); ASSERT_TRUE(IsSuccess(error)); - for(int row = 0; row < num_vertical_layers; row++) { - for(int col = 0; col < num_vertical_layers; col++) + for(int col = 0; col < num_wavelength_bins; col++) { factors[row][col] =- 999.0; } @@ -182,12 +180,10 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) ASSERT_EQ(factors[2][0], 5); ASSERT_EQ(factors[2][1], 6); - DeleteRadiator(radiator, &error); - ASSERT_TRUE(IsSuccess(error)); - DeleteGrid(height, &error); - ASSERT_TRUE(IsSuccess(error)); - DeleteGrid(wavelength, &error); - ASSERT_TRUE(IsSuccess(error)); + // clean up + DeleteRadiator(radiator, &error); ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(height, &error); ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(wavelength, &error); ASSERT_TRUE(IsSuccess(error)); DeleteError(&error); delete[] optical_depths; delete[] optical_depths_1D; @@ -195,4 +191,186 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) delete[] albedos_1D; delete[] factors; delete[] factors_1D; -} \ No newline at end of file +} + +TEST_F(TuvxCApiTest, CanCreateRadiatorMap) +{ + Error error; + RadiatorMap* radiator_map = CreateRadiatorMap(&error); + ASSERT_TRUE(IsSuccess(error)); + + Grid* height = CreateGrid("height", "km", 3, &error); + Grid* wavelength = CreateGrid("wavelength", "nm", 2, &error); + Radiator* foo_radiator = CreateRadiator("foo", height, wavelength, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(foo_radiator, nullptr); + // + // TODO(test) + // + AddRadiator(radiator_map, foo_radiator, &error); + ASSERT_TRUE(IsSuccess(error)); + + Grid* bar_height = CreateGrid("bar_height", "km", 3, &error); + Grid* bar_wavelength = CreateGrid("bar_wavelength", "nm", 2, &error); + Radiator* bar_radiator = CreateRadiator("bar", bar_height, bar_wavelength, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(bar_radiator, nullptr); + AddRadiator(radiator_map, bar_radiator, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(radiator_map, nullptr); + + std::size_t num_vertical_layers = 3; + std::size_t num_wavelength_bins = 2; + + // Test for optical depths + double* optical_depths_1D = new double[num_wavelength_bins * num_vertical_layers]; + double** optical_depths = new double* [num_vertical_layers]; + for(int row =0; row Date: Wed, 31 Jul 2024 11:52:54 -0600 Subject: [PATCH 15/31] temp file for transfer --- src/tuvx/interface_radiator_map_v2.F90 | 178 +++++++++++++++++++++++++ 1 file changed, 178 insertions(+) create mode 100644 src/tuvx/interface_radiator_map_v2.F90 diff --git a/src/tuvx/interface_radiator_map_v2.F90 b/src/tuvx/interface_radiator_map_v2.F90 new file mode 100644 index 00000000..7b14f6b5 --- /dev/null +++ b/src/tuvx/interface_radiator_map_v2.F90 @@ -0,0 +1,178 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_interface_radiator_map + + use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char + use tuvx_radiative_transfer, only : radiative_transfer_t + use tuvx_radiator_warehouse, only : radiator_warehouse_t + use tuvx_radiator, only : radiator_t + use musica_tuvx_util, only : to_f_string, string_t_c + use musica_string, only : string_t + + implicit none + + private + + contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_create_radiator_map(error_code) result(radiator_map) & + bind(C, name="InternalCreateRadiatorMap") + use iso_c_binding, only: c_ptr, c_int, c_null_ptr + use tuvx_radiator_warehouse, only: radiator_warehouse_t + use tuvx_radiative_transfer, only : radiative_transfer_t + + ! arguments + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: radiator_map + + ! variables + class(radiative_transfer_t), pointer :: f_radiative_transfer + class(radiator_warehouse_t), pointer :: f_radiator_warehouse + + f_radiative_transfer => radiative_transfer_t() + select type(f_radiative_transfer) + type is(radiative_transfer_t) + radiator_map = c_loc(f_radiative_transfer%radiator_warehouse_ ) + error_code = 0 + class default + error_code = 1 + radiator_map = c_null_ptr + end select + + end function internal_create_radiator_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_radiator_map(radiator_map, error_code) & + bind(C, name="InternalDeleteRadiatorMap") + use iso_c_binding, only: c_ptr, c_int, c_f_pointer + use tuvx_radiator_warehouse, only: radiator_warehouse_t + use tuvx_radiative_transfer, only : radiative_transfer_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + integer(kind=c_int), intent(out) :: error_code + + ! variables + ! type(radiator_warehouse_t), pointer :: f_radiator_warehouse + type(radiative_transfer_t), pointer :: f_radiative_transfer + call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse_) + deallocate(f_radiative_transfer%radiator_warehouse_) + error_code = 0 + +end subroutine internal_delete_radiator_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_add_radiator(radiator_map, radiator, error_code) & + bind(C, name="InternalAddRadiator") + use iso_c_binding, only: c_ptr, c_int, c_f_pointer + ! use tuvx_radiator_warehouse, only: radiator_warehouse_t + use tuvx_radiative_transfer, only : radiative_transfer_t + use tuvx_radiator_from_host, only: radiator_from_host_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + type(c_ptr), intent(in), value :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiative_transfer_t), pointer :: f_radiative_transfer + type(radiator_from_host_t), pointer :: f_radiator + + call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse_) + call c_f_pointer(radiator, f_radiator) + + error_code = 0 + call f_radiative_transfer%radiator_warehouse_%add(f_radiator) + + end subroutine internal_add_radiator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_radiator(radiator_map, c_radiator_name, & + c_radiator_name_length, error_code) & + result(radiator_ptr) bind(C, name="InternalGetRadiator") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_char, c_size_t, & + c_null_ptr, c_loc + use tuvx_radiator_from_host, only: radiator_from_host_t + use tuvx_radiative_transfer, only : radiative_transfer_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + character(len=1, kind=c_char), dimension(*), intent(in) :: c_radiator_name + integer(kind=c_size_t), value :: c_radiator_name_length + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiative_transfer_t), pointer :: f_radiative_transfer + class(radiator_t), pointer :: f_radiator + type(radiator_warehouse_t), pointer :: radiator_warehouse + character(len=:), allocatable :: f_radiator_name + integer :: i + + ! result + type(c_ptr) :: radiator_ptr + + allocate(character(len=c_radiator_name_length) :: f_radiator_name) + do i = 1, c_radiator_name_length + f_radiator_name(i:i) = c_radiator_name(i) + end do + + call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse_) + write(*,*) " [jiwon] internal_get_radiator" + ! This doesn't work + f_radiator => f_radiative_transfer%radiator_warehouse_%get_radiator(f_radiator_name) + + select type(f_radiator) + type is(radiator_from_host_t) + error_code = 0 + radiator_ptr = c_loc(f_radiator) + class default + error_code = 1 + deallocate(f_radiator) + radiator_ptr = c_null_ptr + end select + + end function internal_get_radiator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_radiator_updater_from_map(radiator_map, radiator, error_code) & + result(updater) bind(C, name="InternalGetRadiatorUpdaterFromMap") + use iso_c_binding, only: c_ptr, c_f_pointer, c_loc + use tuvx_radiator_warehouse, only: radiator_warehouse_t + use tuvx_radiator_from_host, only: radiator_from_host_t, radiator_updater_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + type(c_ptr), intent(in), value :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(radiative_transfer_t), pointer :: f_radiative_transfer + type(radiator_warehouse_t), pointer :: f_radiator_warehouse + type(radiator_from_host_t), pointer :: f_radiator + type(radiator_updater_t), pointer :: f_updater + + call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse) + call c_f_pointer(radiator, f_radiator) + + error_code = 0 + allocate(f_updater) + f_updater = f_radiative_transfer%radiator_warehouse_%get_updater(f_radiator) + updater = c_loc(f_updater) + + end function internal_get_radiator_updater_from_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface_radiator_map \ No newline at end of file From 7b8714b5cb143ed36e5ce7a9471eccb5999a6393 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 31 Jul 2024 18:29:07 -0600 Subject: [PATCH 16/31] working version --- src/test/unit/tuvx/radiatortest.cpp | 101 ++++++-------- src/tuvx/interface_radiator.F90 | 1 - src/tuvx/interface_radiator_map.F90 | 12 +- src/tuvx/interface_radiator_map_v2.F90 | 178 ------------------------- 4 files changed, 51 insertions(+), 241 deletions(-) delete mode 100644 src/tuvx/interface_radiator_map_v2.F90 diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp index 4313a14e..14bdb52d 100644 --- a/src/test/unit/tuvx/radiatortest.cpp +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -73,7 +73,6 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) // Test for optical depths std::size_t num_vertical_layers = 3; std::size_t num_wavelength_bins = 2; - // Allocate array as 1D double* optical_depths_1D = new double[num_wavelength_bins * num_vertical_layers]; // Allocate an array of pointers to each row @@ -83,7 +82,6 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) { optical_depths[row] = &optical_depths_1D[row * num_wavelength_bins]; } - // int i = 1; for(int row = 0; row < num_vertical_layers; row++) { @@ -110,7 +108,6 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) ASSERT_EQ(optical_depths[1][1], 40.0); ASSERT_EQ(optical_depths[2][0], 50.0); ASSERT_EQ(optical_depths[2][1], 60.0); - // Test for single scattering albedos double* albedos_1D = new double[num_wavelength_bins * num_vertical_layers]; double** albedos = new double* [num_vertical_layers]; @@ -144,7 +141,6 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) ASSERT_EQ(albedos[1][1], 400.0); ASSERT_EQ(albedos[2][0], 500.0); ASSERT_EQ(albedos[2][1], 600.0); - // Test for asymmetery factors double* factors_1D = new double[num_wavelength_bins * num_vertical_layers]; double** factors = new double* [num_vertical_layers]; @@ -179,8 +175,7 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) ASSERT_EQ(factors[1][1], 4); ASSERT_EQ(factors[2][0], 5); ASSERT_EQ(factors[2][1], 6); - - // clean up + // Clean up DeleteRadiator(radiator, &error); ASSERT_TRUE(IsSuccess(error)); DeleteGrid(height, &error); ASSERT_TRUE(IsSuccess(error)); DeleteGrid(wavelength, &error); ASSERT_TRUE(IsSuccess(error)); @@ -198,18 +193,14 @@ TEST_F(TuvxCApiTest, CanCreateRadiatorMap) Error error; RadiatorMap* radiator_map = CreateRadiatorMap(&error); ASSERT_TRUE(IsSuccess(error)); - Grid* height = CreateGrid("height", "km", 3, &error); Grid* wavelength = CreateGrid("wavelength", "nm", 2, &error); Radiator* foo_radiator = CreateRadiator("foo", height, wavelength, &error); ASSERT_TRUE(IsSuccess(error)); ASSERT_NE(foo_radiator, nullptr); - // - // TODO(test) - // AddRadiator(radiator_map, foo_radiator, &error); ASSERT_TRUE(IsSuccess(error)); - + ASSERT_NE(radiator_map, nullptr); Grid* bar_height = CreateGrid("bar_height", "km", 3, &error); Grid* bar_wavelength = CreateGrid("bar_wavelength", "nm", 2, &error); Radiator* bar_radiator = CreateRadiator("bar", bar_height, bar_wavelength, &error); @@ -218,11 +209,9 @@ TEST_F(TuvxCApiTest, CanCreateRadiatorMap) AddRadiator(radiator_map, bar_radiator, &error); ASSERT_TRUE(IsSuccess(error)); ASSERT_NE(radiator_map, nullptr); - + // Test for optical depths std::size_t num_vertical_layers = 3; std::size_t num_wavelength_bins = 2; - - // Test for optical depths double* optical_depths_1D = new double[num_wavelength_bins * num_vertical_layers]; double** optical_depths = new double* [num_vertical_layers]; for(int row =0; row radiator_warehouse_t() select type(f_radiator_warehouse) type is(radiator_warehouse_t) - radiator_map = c_loc(f_radiator_warehouse) + radiator_map = c_loc(f_radiator_warehouse) error_code = 0 class default error_code = 1 radiator_map = c_null_ptr end select - + end function internal_create_radiator_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -105,9 +105,11 @@ function internal_get_radiator(radiator_map, c_radiator_name, & ! variables class(radiator_t), pointer :: f_radiator + class(radiator_t), pointer :: f_radiator_ptr type(radiator_warehouse_t), pointer :: radiator_warehouse character(len=:), allocatable :: f_radiator_name integer :: i + ! result type(c_ptr) :: radiator_ptr @@ -117,8 +119,10 @@ function internal_get_radiator(radiator_map, c_radiator_name, & end do call c_f_pointer(radiator_map, radiator_warehouse) - - f_radiator => radiator_warehouse%get_radiator(f_radiator_name) + + f_radiator_ptr => radiator_warehouse%get_radiator(f_radiator_name) + allocate(f_radiator, source = f_radiator_ptr) + nullify(f_radiator_ptr) select type(f_radiator) type is(radiator_from_host_t) diff --git a/src/tuvx/interface_radiator_map_v2.F90 b/src/tuvx/interface_radiator_map_v2.F90 deleted file mode 100644 index 7b14f6b5..00000000 --- a/src/tuvx/interface_radiator_map_v2.F90 +++ /dev/null @@ -1,178 +0,0 @@ -! Copyright (C) 2023-2024 National Center for Atmospheric Research -! SPDX-License-Identifier: Apache-2.0 -! -module tuvx_interface_radiator_map - - use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char - use tuvx_radiative_transfer, only : radiative_transfer_t - use tuvx_radiator_warehouse, only : radiator_warehouse_t - use tuvx_radiator, only : radiator_t - use musica_tuvx_util, only : to_f_string, string_t_c - use musica_string, only : string_t - - implicit none - - private - - contains - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - function internal_create_radiator_map(error_code) result(radiator_map) & - bind(C, name="InternalCreateRadiatorMap") - use iso_c_binding, only: c_ptr, c_int, c_null_ptr - use tuvx_radiator_warehouse, only: radiator_warehouse_t - use tuvx_radiative_transfer, only : radiative_transfer_t - - ! arguments - integer(kind=c_int), intent(out) :: error_code - - ! result - type(c_ptr) :: radiator_map - - ! variables - class(radiative_transfer_t), pointer :: f_radiative_transfer - class(radiator_warehouse_t), pointer :: f_radiator_warehouse - - f_radiative_transfer => radiative_transfer_t() - select type(f_radiative_transfer) - type is(radiative_transfer_t) - radiator_map = c_loc(f_radiative_transfer%radiator_warehouse_ ) - error_code = 0 - class default - error_code = 1 - radiator_map = c_null_ptr - end select - - end function internal_create_radiator_map - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine internal_delete_radiator_map(radiator_map, error_code) & - bind(C, name="InternalDeleteRadiatorMap") - use iso_c_binding, only: c_ptr, c_int, c_f_pointer - use tuvx_radiator_warehouse, only: radiator_warehouse_t - use tuvx_radiative_transfer, only : radiative_transfer_t - - ! arguments - type(c_ptr), intent(in), value :: radiator_map - integer(kind=c_int), intent(out) :: error_code - - ! variables - ! type(radiator_warehouse_t), pointer :: f_radiator_warehouse - type(radiative_transfer_t), pointer :: f_radiative_transfer - call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse_) - deallocate(f_radiative_transfer%radiator_warehouse_) - error_code = 0 - -end subroutine internal_delete_radiator_map - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine internal_add_radiator(radiator_map, radiator, error_code) & - bind(C, name="InternalAddRadiator") - use iso_c_binding, only: c_ptr, c_int, c_f_pointer - ! use tuvx_radiator_warehouse, only: radiator_warehouse_t - use tuvx_radiative_transfer, only : radiative_transfer_t - use tuvx_radiator_from_host, only: radiator_from_host_t - - ! arguments - type(c_ptr), intent(in), value :: radiator_map - type(c_ptr), intent(in), value :: radiator - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(radiative_transfer_t), pointer :: f_radiative_transfer - type(radiator_from_host_t), pointer :: f_radiator - - call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse_) - call c_f_pointer(radiator, f_radiator) - - error_code = 0 - call f_radiative_transfer%radiator_warehouse_%add(f_radiator) - - end subroutine internal_add_radiator - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - function internal_get_radiator(radiator_map, c_radiator_name, & - c_radiator_name_length, error_code) & - result(radiator_ptr) bind(C, name="InternalGetRadiator") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_char, c_size_t, & - c_null_ptr, c_loc - use tuvx_radiator_from_host, only: radiator_from_host_t - use tuvx_radiative_transfer, only : radiative_transfer_t - - ! arguments - type(c_ptr), intent(in), value :: radiator_map - character(len=1, kind=c_char), dimension(*), intent(in) :: c_radiator_name - integer(kind=c_size_t), value :: c_radiator_name_length - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(radiative_transfer_t), pointer :: f_radiative_transfer - class(radiator_t), pointer :: f_radiator - type(radiator_warehouse_t), pointer :: radiator_warehouse - character(len=:), allocatable :: f_radiator_name - integer :: i - - ! result - type(c_ptr) :: radiator_ptr - - allocate(character(len=c_radiator_name_length) :: f_radiator_name) - do i = 1, c_radiator_name_length - f_radiator_name(i:i) = c_radiator_name(i) - end do - - call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse_) - write(*,*) " [jiwon] internal_get_radiator" - ! This doesn't work - f_radiator => f_radiative_transfer%radiator_warehouse_%get_radiator(f_radiator_name) - - select type(f_radiator) - type is(radiator_from_host_t) - error_code = 0 - radiator_ptr = c_loc(f_radiator) - class default - error_code = 1 - deallocate(f_radiator) - radiator_ptr = c_null_ptr - end select - - end function internal_get_radiator - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - function internal_get_radiator_updater_from_map(radiator_map, radiator, error_code) & - result(updater) bind(C, name="InternalGetRadiatorUpdaterFromMap") - use iso_c_binding, only: c_ptr, c_f_pointer, c_loc - use tuvx_radiator_warehouse, only: radiator_warehouse_t - use tuvx_radiator_from_host, only: radiator_from_host_t, radiator_updater_t - - ! arguments - type(c_ptr), intent(in), value :: radiator_map - type(c_ptr), intent(in), value :: radiator - integer(kind=c_int), intent(out) :: error_code - - ! output - type(c_ptr) :: updater - - ! variables - type(radiative_transfer_t), pointer :: f_radiative_transfer - type(radiator_warehouse_t), pointer :: f_radiator_warehouse - type(radiator_from_host_t), pointer :: f_radiator - type(radiator_updater_t), pointer :: f_updater - - call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse) - call c_f_pointer(radiator, f_radiator) - - error_code = 0 - allocate(f_updater) - f_updater = f_radiative_transfer%radiator_warehouse_%get_updater(f_radiator) - updater = c_loc(f_updater) - - end function internal_get_radiator_updater_from_map - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -end module tuvx_interface_radiator_map \ No newline at end of file From cab7fb0e1cdad4d7645661fa8623c2860a88f797 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 31 Jul 2024 18:54:40 -0600 Subject: [PATCH 17/31] fix test --- src/test/unit/tuvx/radiatortest.cpp | 30 ++++++++++++++--------------- src/tuvx/interface_radiator_map.F90 | 27 +++++++++++++++----------- 2 files changed, 31 insertions(+), 26 deletions(-) diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp index 14bdb52d..33e3e354 100644 --- a/src/test/unit/tuvx/radiatortest.cpp +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -45,21 +45,21 @@ class TuvxCApiTest : public ::testing::Test } }; -// TEST_F(TuvxCApiTest, CannotGetConfiguredRadiator) -// { -// const char* yaml_config_path = "examples/ts1_tsmlt.yml"; -// SetUp(yaml_config_path); -// Error error; -// RadiatorMap* radiator_map = GetRadiatorMap(tuvx, &error); -// ASSERT_TRUE(IsSuccess(error)); -// ASSERT_NE(radiator_map, nullptr); -// Radiator* radiator = GetRadiator(radiator_map, "foo", &error); -// ASSERT_FALSE(IsSuccess(error)); // non-host grid -// ASSERT_EQ(radiator, nullptr); -// DeleteRadiatorMap(radiator_map, &error); -// ASSERT_TRUE(IsSuccess(error)); -// DeleteError(&error); -// } +TEST_F(TuvxCApiTest, CannotGetConfiguredRadiator) +{ + const char* yaml_config_path = "examples/ts1_tsmlt.yml"; + SetUp(yaml_config_path); + Error error; + RadiatorMap* radiator_map = GetRadiatorMap(tuvx, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(radiator_map, nullptr); + Radiator* radiator = GetRadiator(radiator_map, "foo", &error); + ASSERT_FALSE(IsSuccess(error)); // non-host grid + ASSERT_EQ(radiator, nullptr); + DeleteRadiatorMap(radiator_map, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); +} TEST_F(TuvxCApiTest, CanCreateRadiator) { diff --git a/src/tuvx/interface_radiator_map.F90 b/src/tuvx/interface_radiator_map.F90 index bb4cab88..3e5b1369 100644 --- a/src/tuvx/interface_radiator_map.F90 +++ b/src/tuvx/interface_radiator_map.F90 @@ -119,20 +119,25 @@ function internal_get_radiator(radiator_map, c_radiator_name, & end do call c_f_pointer(radiator_map, radiator_warehouse) - - f_radiator_ptr => radiator_warehouse%get_radiator(f_radiator_name) - allocate(f_radiator, source = f_radiator_ptr) - nullify(f_radiator_ptr) - select type(f_radiator) - type is(radiator_from_host_t) - error_code = 0 - radiator_ptr = c_loc(f_radiator) - class default + if (.not. radiator_warehouse%exists(f_radiator_name)) then error_code = 1 - deallocate(f_radiator) radiator_ptr = c_null_ptr - end select + else + f_radiator_ptr => radiator_warehouse%get_radiator(f_radiator_name) + allocate(f_radiator, source = f_radiator_ptr) + nullify(f_radiator_ptr) + + select type(f_radiator) + type is(radiator_from_host_t) + error_code = 0 + radiator_ptr = c_loc(f_radiator) + class default + error_code = 1 + deallocate(f_radiator) + radiator_ptr = c_null_ptr + end select + end if end function internal_get_radiator From 29e42f631ce77e54506fabbabd69dfc45eaf20b2 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 2 Aug 2024 13:37:52 -0600 Subject: [PATCH 18/31] fix bugs --- CMakeLists.txt | 2 +- .../fetch_content_integration/CMakeLists.txt | 3 ++- .../test_tuvx_api.F90 | 25 ++++++++++-------- fortran/tuvx/CMakeLists.txt | 2 ++ fortran/tuvx/radiator.F90 | 26 +++++++++---------- fortran/tuvx/tuvx.F90 | 8 +++--- 6 files changed, 36 insertions(+), 30 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 175f4b8b..27b92e20 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -27,7 +27,7 @@ option(MUSICA_ENABLE_MPI "Enable MPI parallel support" OFF) option(MUSICA_ENABLE_OPENMP "Enable OpemMP support" OFF) option(MUSICA_ENABLE_MEMCHECK "Enable memory checking" OFF) option(MUSICA_BUILD_DOCS "Build the documentation" OFF) -option(MUSICA_ENABLE_MICM "Enable MICM" ON) +option(MUSICA_ENABLE_MICM "Enable MICM" OFF) option(MUSICA_ENABLE_TUVX "Enable TUV-x" ON) set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE "1" CACHE STRING "Set MICM vector-ordered matrix dimension") diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 3b978644..7dadb353 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -9,7 +9,8 @@ set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}) include(FetchContent) -set(MUSICA_GIT_TAG "main" CACHE STRING "Git tag for the musica_fortran repository") +# set(MUSICA_GIT_TAG "main" CACHE STRING "Git tag for the musica_fortran repository") +set(MUSICA_GIT_TAG "122-make-radiator-updatable" CACHE STRING "Git tag for the musica_fortran repository") message(STATUS "Using MUSICA_GIT_TAG: ${MUSICA_GIT_TAG}") diff --git a/fortran/test/fetch_content_integration/test_tuvx_api.F90 b/fortran/test/fetch_content_integration/test_tuvx_api.F90 index 54b6e349..19f05faf 100644 --- a/fortran/test/fetch_content_integration/test_tuvx_api.F90 +++ b/fortran/test/fetch_content_integration/test_tuvx_api.F90 @@ -3,7 +3,8 @@ ! program combined_tuvx_tests use iso_c_binding - use musica_tuvx, only: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t + use musica_tuvx, only: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t, & + radiator_map_t, radiator_t use musica_util, only: assert, error_t implicit none @@ -55,16 +56,18 @@ end subroutine test_tuvx_api_invalid_config subroutine test_tuvx_solve() - type(tuvx_t), pointer :: tuvx - type(error_t) :: error - type(grid_map_t), pointer :: grids - character(len=256) :: config_path - type(grid_t), pointer :: grid - type(profile_map_t), pointer :: profiles - type(profile_t), pointer :: profile, profile_copy - real*8, dimension(5), target :: edges, edge_values, temp_edge - real*8, dimension(4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint - real*8 :: temp_real + type(tuvx_t), pointer :: tuvx + type(error_t) :: error + type(grid_map_t), pointer :: grids + character(len=256) :: config_path + type(grid_t), pointer :: grid + type(profile_map_t), pointer :: profiles + type(profile_t), pointer :: profile, profile_copy + type(radiator_map_t), pointer :: radiators + type(radiator_t), pointer :: radiator, radiator_copy + real*8, dimension(5), target :: edges, edge_values, temp_edge + real*8, dimension(4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint + real*8 :: temp_real edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) diff --git a/fortran/tuvx/CMakeLists.txt b/fortran/tuvx/CMakeLists.txt index cb3eeb6c..68e400c9 100644 --- a/fortran/tuvx/CMakeLists.txt +++ b/fortran/tuvx/CMakeLists.txt @@ -4,5 +4,7 @@ target_sources(musica-fortran grid_map.F90 profile.F90 profile_map.F90 + radiator.F90 + radiator_map.F90 tuvx.F90 ) \ No newline at end of file diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index 1f7a4a9d..1b84c67b 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -78,7 +78,7 @@ subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, type(error_t_c), intent(inout) :: error end subroutine get_single_scattering_albedos_c - subroutine set_asymmetry_factors_c(radiator, asymmetry_factor, num_vertical_layers, & + subroutine set_asymmetry_factors_c(radiator, asymmetry_factors, num_vertical_layers, & num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactors") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c @@ -90,7 +90,7 @@ subroutine set_asymmetry_factors_c(radiator, asymmetry_factor, num_vertical_laye type(error_t_c), intent(inout) :: error end subroutine set_asymmetry_factors_c - subroutine get_asymmetry_factors_c(radiator, symmetry_factor, num_vertical_layers, & + subroutine get_asymmetry_factors_c(radiator, asymmetry_factors, num_vertical_layers, & num_wavelength_bins, num_streams, error) bind(C, name="GetAsymmetryFactors") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c @@ -154,7 +154,7 @@ end function radiator_t_ptr_constructor function radiator_t_constructor(radiator_name, height_grid, wavelength_grid, error) & result(this) use iso_c_binding, only: c_size_t, c_loc - use musica_util, only: error_t, error_t_c, to_c_string + use musica_util, only: error_t, error_t_c, to_c_string, dk => musica_dk ! Arguments character(len=*), intent(in) :: radiator_name @@ -173,7 +173,7 @@ function radiator_t_constructor(radiator_name, height_grid, wavelength_grid, err !! that does memory layout conversion !! this%ptr_ = create_radiator_c(to_c_string(radiator_name), c_loc(height_grid), & - c_loc(avelength_grid), error_c) + c_loc(wavelength_grid), error_c) error = error_t(error_c) end function radiator_t_constructor @@ -284,7 +284,7 @@ end subroutine get_single_scattering_albedos !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine set_asymmetry_factors(this, symmetry_factor, error) + subroutine set_asymmetry_factors(this, asymmetry_factors, error) use iso_c_binding, only: c_size_t, c_loc use musica_util, only: error_t, error_t_c, dk => musica_dk @@ -299,9 +299,9 @@ subroutine set_asymmetry_factors(this, symmetry_factor, error) integer(kind=c_size_t) :: num_wavelength_bins integer(kind=c_size_t) :: num_streams - num_vertical_layers = size(single_scattering_albedos, 1) - num_wavelength_bins = size(single_scattering_albedos, 2) - num_streams = size(num_streams, 3) + num_vertical_layers = size(asymmetry_factors, 1) + num_wavelength_bins = size(asymmetry_factors, 2) + num_streams = size(asymmetry_factors, 3) call set_asymmetry_factors_c(this%ptr_, c_loc(asymmetry_factors), & num_vertical_layers, num_wavelength_bins, num_streams, error_c) @@ -311,7 +311,7 @@ end subroutine set_asymmetry_factors !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine get_asymmetry_factors(this, symmetry_factor, error) + subroutine get_asymmetry_factors(this, asymmetry_factors, error) use iso_c_binding, only: c_size_t, c_loc use musica_util, only: error_t, error_t_c, dk => musica_dk @@ -326,15 +326,15 @@ subroutine get_asymmetry_factors(this, symmetry_factor, error) integer(kind=c_size_t) :: num_wavelength_bins integer(kind=c_size_t) :: num_streams - num_vertical_layers = size(single_scattering_albedos, 1) - num_wavelength_bins = size(single_scattering_albedos, 2) - num_streams = size(num_streams, 3) + num_vertical_layers = size(asymmetry_factors, 1) + num_wavelength_bins = size(asymmetry_factors, 2) + num_streams = size(asymmetry_factors, 3) call get_asymmetry_factors_c(this%ptr_, c_loc(asymmetry_factors), & num_vertical_layers, num_wavelength_bins, num_streams, error_c) error = error_t(error_c) - end subroutine get_single_scattering_albedos + end subroutine get_asymmetry_factors !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/fortran/tuvx/tuvx.F90 b/fortran/tuvx/tuvx.F90 index 082712d8..daa228cf 100644 --- a/fortran/tuvx/tuvx.F90 +++ b/fortran/tuvx/tuvx.F90 @@ -171,14 +171,14 @@ function get_radiators(this, error) result(radiator_map) use musica_util, only: error_t, error_t_c ! Arguments - class(tuvx_t), intent(inout) :: this - type(error_t), intent(inout) :: error + class(tuvx_t), intent(inout) :: this + type(error_t), intent(inout) :: error ! Local variables - type(error_t_c) :: error_c + type(error_t_c) :: error_c ! Return value - type(radiator_map_t), pointer :: radiator_map + type(radiator_map_t), pointer :: radiator_map radiator_map => radiator_map_t(get_radiator_map_c(this%ptr_, error_c)) From a6f302d3c8f0dd102e57d957242a7bc7a6c4f1a8 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 2 Aug 2024 17:46:36 -0600 Subject: [PATCH 19/31] fix fortran bugs --- docker/Dockerfile | 4 ++-- docker/Dockerfile.fortran-gcc | 2 +- docker/Dockerfile.fortran-gcc.integration | 2 +- docker/Dockerfile.memcheck | 2 +- docker/Dockerfile.mpi | 2 +- docker/Dockerfile.mpi_openmp | 2 +- docker/Dockerfile.openmp | 2 +- docker/Dockerfile.python | 2 +- fortran/tuvx/radiator.F90 | 12 ++++++------ fortran/tuvx/tuvx.F90 | 3 ++- 10 files changed, 17 insertions(+), 16 deletions(-) diff --git a/docker/Dockerfile b/docker/Dockerfile index 6fa6c930..377af261 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -1,6 +1,6 @@ FROM fedora:35 -ARG BUILD_TYPE=Release +ARG BUILD_TYPE=Debug RUN dnf -y update \ && dnf -y install \ @@ -9,7 +9,7 @@ RUN dnf -y update \ gfortran \ gdb \ git \ - lapack-devel \ + # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.fortran-gcc b/docker/Dockerfile.fortran-gcc index d21acb7e..93a9bcb1 100644 --- a/docker/Dockerfile.fortran-gcc +++ b/docker/Dockerfile.fortran-gcc @@ -13,7 +13,7 @@ RUN dnf -y update \ git \ hdf5-devel \ json-devel \ - lapack-devel \ + # lapack-devel \ lcov \ libcurl-devel \ m4 \ diff --git a/docker/Dockerfile.fortran-gcc.integration b/docker/Dockerfile.fortran-gcc.integration index 5e7204ca..8fdae414 100644 --- a/docker/Dockerfile.fortran-gcc.integration +++ b/docker/Dockerfile.fortran-gcc.integration @@ -14,7 +14,7 @@ RUN dnf -y update \ git \ hdf5-devel \ json-devel \ - lapack-devel \ + # lapack-devel \ lcov \ libcurl-devel \ m4 \ diff --git a/docker/Dockerfile.memcheck b/docker/Dockerfile.memcheck index cd943615..d31397d6 100644 --- a/docker/Dockerfile.memcheck +++ b/docker/Dockerfile.memcheck @@ -9,7 +9,7 @@ RUN dnf -y update \ gfortran \ gdb \ git \ - lapack-devel \ + # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.mpi b/docker/Dockerfile.mpi index fa85b48f..3a16b622 100644 --- a/docker/Dockerfile.mpi +++ b/docker/Dockerfile.mpi @@ -16,7 +16,7 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - lapack-devel \ + # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.mpi_openmp b/docker/Dockerfile.mpi_openmp index f48a4605..d6dfade1 100644 --- a/docker/Dockerfile.mpi_openmp +++ b/docker/Dockerfile.mpi_openmp @@ -16,7 +16,7 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - lapack-devel \ + # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.openmp b/docker/Dockerfile.openmp index efc433b8..0ab97773 100644 --- a/docker/Dockerfile.openmp +++ b/docker/Dockerfile.openmp @@ -16,7 +16,7 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - lapack-devel \ + # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.python b/docker/Dockerfile.python index 02788a0f..5765515b 100644 --- a/docker/Dockerfile.python +++ b/docker/Dockerfile.python @@ -9,7 +9,7 @@ RUN dnf -y update \ gcc-fortran \ gdb \ git \ - lapack-devel \ + # lapack-devel \ make \ netcdf-fortran-devel \ pip \ diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index 1b84c67b..d4abab92 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -33,7 +33,7 @@ subroutine delete_radiator_c(radiator, error) bind(C, name="DeleteRadiator") end subroutine delete_radiator_c subroutine set_optical_depths_c(radiator, optical_depths, num_vertical_layers, & - num_wavelength_bins, error) bind(C, name="SetOpticalDepths") + num_wavelength_bins, error) bind(C, name="SetRadiatorOpticalDepths") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c type(c_ptr), value, intent(in) :: radiator @@ -44,7 +44,7 @@ subroutine set_optical_depths_c(radiator, optical_depths, num_vertical_layers, & end subroutine set_optical_depths_c subroutine get_optical_depths_c(radiator, optical_depths, num_vertical_layers, & - num_wavelength_bins, error) bind(C, name="GetOpticalDepths") + num_wavelength_bins, error) bind(C, name="GetRadiatorOpticalDepths") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c type(c_ptr), value, intent(in) :: radiator @@ -56,7 +56,7 @@ end subroutine get_optical_depths_c subroutine set_single_scattering_albedos_c(radiator, single_scattering_albedos, & num_vertical_layers, num_wavelength_bins, error) & - bind(C, name="SetSingleScatteringAlbedos") + bind(C, name="SetRadiatorSingleScatteringAlbedos") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c type(c_ptr), value, intent(in) :: radiator @@ -68,7 +68,7 @@ end subroutine set_single_scattering_albedos_c subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, & num_vertical_layers, num_wavelength_bins, error) & - bind(C, name="GetSingleScatteringAlbedos") + bind(C, name="GetRadiatorSingleScatteringAlbedos") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c type(c_ptr), value, intent(in) :: radiator @@ -79,7 +79,7 @@ subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, end subroutine get_single_scattering_albedos_c subroutine set_asymmetry_factors_c(radiator, asymmetry_factors, num_vertical_layers, & - num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactors") + num_wavelength_bins, num_streams, error) bind(C, name="SetRadiatorAsymmetryFactors") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c type(c_ptr), value, intent(in) :: radiator @@ -91,7 +91,7 @@ subroutine set_asymmetry_factors_c(radiator, asymmetry_factors, num_vertical_lay end subroutine set_asymmetry_factors_c subroutine get_asymmetry_factors_c(radiator, asymmetry_factors, num_vertical_layers, & - num_wavelength_bins, num_streams, error) bind(C, name="GetAsymmetryFactors") + num_wavelength_bins, num_streams, error) bind(C, name="GetRadiatorAsymmetryFactors") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c type(c_ptr), value, intent(in) :: radiator diff --git a/fortran/tuvx/tuvx.F90 b/fortran/tuvx/tuvx.F90 index daa228cf..36a58d79 100644 --- a/fortran/tuvx/tuvx.F90 +++ b/fortran/tuvx/tuvx.F90 @@ -15,7 +15,8 @@ module musica_tuvx #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) private - public :: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t + public :: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t, & + radiator_map_t, radiator_t !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 18d47cae768c71ea2d80c43f4079a8c18ea5c44f Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 2 Aug 2024 18:12:57 -0600 Subject: [PATCH 20/31] add radiator fortran test --- .../fetch_content_integration/CMakeLists.txt | 48 ++++++++++----- .../temp_radiator.F90 | 61 +++++++++++++++++++ 2 files changed, 95 insertions(+), 14 deletions(-) create mode 100644 fortran/test/fetch_content_integration/temp_radiator.F90 diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 7dadb353..8c10fb5d 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -90,23 +90,23 @@ endif() # API Test if (MUSICA_ENABLE_TUVX) - add_executable(test_tuvx_fortran_api test_tuvx_api.F90) + # add_executable(test_tuvx_fortran_api test_tuvx_api.F90) - target_link_libraries(test_tuvx_fortran_api - PRIVATE - musica::musica-fortran - ) + # target_link_libraries(test_tuvx_fortran_api + # PRIVATE + # musica::musica-fortran + # ) - set_target_properties(test_tuvx_fortran_api - PROPERTIES - LINKER_LANGUAGE Fortran - ) + # set_target_properties(test_tuvx_fortran_api + # PROPERTIES + # LINKER_LANGUAGE Fortran + # ) - add_test( - NAME test_tuvx_fortran_api - COMMAND $ - WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} - ) + # add_test( + # NAME test_tuvx_fortran_api + # COMMAND $ + # WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} + # ) add_custom_target( copy_tuvx_examples_dir ALL ${CMAKE_COMMAND} -E copy_directory @@ -118,3 +118,23 @@ if (MUSICA_ENABLE_TUVX) ${CMAKE_CURRENT_SOURCE_DIR}/../../../build/_deps/tuvx-src/data ${CMAKE_BINARY_DIR}/data ) endif() + + +# TODO(jiwon) - just a temp test +add_executable(test_jiwon temp_radiator.F90) + +target_link_libraries(test_jiwon + PRIVATE + musica::musica-fortran +) + +set_target_properties(test_jiwon + PROPERTIES + LINKER_LANGUAGE Fortran +) + +add_test( + NAME test_jiwon + COMMAND $ + WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} +) \ No newline at end of file diff --git a/fortran/test/fetch_content_integration/temp_radiator.F90 b/fortran/test/fetch_content_integration/temp_radiator.F90 new file mode 100644 index 00000000..04ed273f --- /dev/null +++ b/fortran/test/fetch_content_integration/temp_radiator.F90 @@ -0,0 +1,61 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +program combined_tuvx_tests + use iso_c_binding + use musica_tuvx, only: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t, & + radiator_map_t, radiator_t + use musica_util, only: assert, error_t + + implicit none + + #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + #define ASSERT_EQ( a, b ) call assert( a == b, __FILE__, __LINE__ ) + + ! Call the valid test subroutine + call test_tuvx_api() + + ! Call the invalid test subroutine + ! disabling until tuv no longer calls stop internally + ! call test_tuvx_api_invalid_config() + + ! Call the solve test subroutine + call test_tuvx_solve() + + contains + subroutine test_jiwon_solve() + + type(tuvx_t), pointer :: tuvx + type(error_t) :: error + type(grid_map_t), pointer :: grids + character(len=256) :: config_path + type(grid_t), pointer :: grid + type(profile_map_t), pointer :: profiles + type(profile_t), pointer :: profile, profile_copy + type(radiator_map_t), pointer :: radiators + type(radiator_t), pointer :: radiator, radiator_copy + real*8, dimension(5), target :: edges, edge_values, temp_edge + real*8, dimension(4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint + real*8 :: temp_real + + edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) + midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) + edge_values = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) + midpoint_values = (/ 15.0, 25.0, 35.0, 45.0 /) + layer_densities = (/ 2.0, 4.0, 1.0, 7.0 /) + + config_path = "examples/ts1_tsmlt.json" + + tuvx => tuvx_t( config_path, error ) + ASSERT( error%is_success() ) + radiators => tuvx%get_radiators( error ) + ASSERT( error%is_success() ) + + ! grid => grids%get( "height", "km", error ) + ! ASSERT( .not. error%is_success() ) ! non-accessible grid + ! deallocate( grid ) + ! deallocate( grids ) + + end subroutine test_tuvx_solve + +end program combined_tuvx_tests \ No newline at end of file From 0101fe36237883e56efb579fece2175efada6f63 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 2 Aug 2024 18:36:08 -0600 Subject: [PATCH 21/31] test tag --- docker/Dockerfile.fortran-gcc | 3 +++ 1 file changed, 3 insertions(+) diff --git a/docker/Dockerfile.fortran-gcc b/docker/Dockerfile.fortran-gcc index 93a9bcb1..f4b1833b 100644 --- a/docker/Dockerfile.fortran-gcc +++ b/docker/Dockerfile.fortran-gcc @@ -33,10 +33,13 @@ ENV FFLAGS="-I/usr/include/" # Copy the musica code COPY . musica +ARG MUSICA_GIT_TAG=122-make-radiator-updatable + # Build and install MUSICA RUN cd musica \ && cmake -S . \ -B build \ + -D MUSICA_GIT_TAG=${MUSICA_GIT_TAG} \ -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ -D MUSICA_BUILD_FORTRAN_INTERFACE=ON \ -D MUSICA_ENABLE_MEMCHECK=ON \ From f82d417cdf4c4ba6a41e8a7ca0ad1b863ad52618 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 07:37:55 -0600 Subject: [PATCH 22/31] add fortran test --- .../temp_radiator.F90 | 182 ++++++++++++++++-- .../test_tuvx_api.F90 | 2 +- fortran/test/unit/CMakeLists.txt | 29 +-- fortran/tuvx/profile.F90 | 2 +- fortran/tuvx/radiator.F90 | 45 ++--- 5 files changed, 199 insertions(+), 61 deletions(-) diff --git a/fortran/test/fetch_content_integration/temp_radiator.F90 b/fortran/test/fetch_content_integration/temp_radiator.F90 index 04ed273f..5673ddd8 100644 --- a/fortran/test/fetch_content_integration/temp_radiator.F90 +++ b/fortran/test/fetch_content_integration/temp_radiator.F90 @@ -1,26 +1,19 @@ ! Copyright (C) 2023-2024 National Center for Atmospheric Research ! SPDX-License-Identifier: Apache-2.0 ! -program combined_tuvx_tests +program combined_tuvx_tests2 use iso_c_binding use musica_tuvx, only: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t, & radiator_map_t, radiator_t - use musica_util, only: assert, error_t - + use musica_util, only: assert, error_t, dk => musica_dk + implicit none - #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - #define ASSERT_EQ( a, b ) call assert( a == b, __FILE__, __LINE__ ) - - ! Call the valid test subroutine - call test_tuvx_api() +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) +#define ASSERT_EQ( a, b ) call assert( a == b, __FILE__, __LINE__ ) - ! Call the invalid test subroutine - ! disabling until tuv no longer calls stop internally - ! call test_tuvx_api_invalid_config() - - ! Call the solve test subroutine - call test_tuvx_solve() + ! Call the valid test subroutine + call test_jiwon_solve() contains subroutine test_jiwon_solve() @@ -29,7 +22,7 @@ subroutine test_jiwon_solve() type(error_t) :: error type(grid_map_t), pointer :: grids character(len=256) :: config_path - type(grid_t), pointer :: grid + type(grid_t), pointer :: grid, height_grid, wavelength_grid type(profile_map_t), pointer :: profiles type(profile_t), pointer :: profile, profile_copy type(radiator_map_t), pointer :: radiators @@ -37,6 +30,10 @@ subroutine test_jiwon_solve() real*8, dimension(5), target :: edges, edge_values, temp_edge real*8, dimension(4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint real*8 :: temp_real + integer :: num_vertical_layers, num_wavelength_bins + real*8, dimension(3,2), target :: optical_depths, temp_od + real*8, dimension(3,2), target :: single_scattering_albedos, temp_ssa + real*8, dimension(3,2,1), target :: asymmetry_factors, temp_asym edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) @@ -44,18 +41,161 @@ subroutine test_jiwon_solve() midpoint_values = (/ 15.0, 25.0, 35.0, 45.0 /) layer_densities = (/ 2.0, 4.0, 1.0, 7.0 /) + num_vertical_layers = 3 + num_wavelength_bins = 2 + + optical_depths(:,1) = (/ 30.0, 20.0, 10.0 /) + optical_depths(:,2) = (/ 70.0, 80.0, 90.0 /) + single_scattering_albedos(:,1) = (/ 300.0, 200.0, 100.0 /) + single_scattering_albedos(:,2) = (/ 700.0, 800.0, 900.0 /) + asymmetry_factors(:,1,1) = (/ 3.0, 2.0, 1.0 /) + asymmetry_factors(:,2,1) = (/ 7.0, 8.0, 9.0 /) + config_path = "examples/ts1_tsmlt.json" tuvx => tuvx_t( config_path, error ) ASSERT( error%is_success() ) + +! ! +! ! TODO - Radiator starts here? +! ! radiators => tuvx%get_radiators( error ) ASSERT( error%is_success() ) - ! grid => grids%get( "height", "km", error ) - ! ASSERT( .not. error%is_success() ) ! non-accessible grid - ! deallocate( grid ) - ! deallocate( grids ) + radiator => radiators%get( "foo_radiator", error ) + ASSERT( .not. error%is_success() ) ! non-accessible grid + deallocate( radiator ) + deallocate( radiators ) - end subroutine test_tuvx_solve + radiators =>radiator_map_t( error ) + ASSERT( error%is_success() ) + + height_grid => grid_t( "height", "km", num_vertical_layers, error ) + wavelength_grid => grid_t( "wavelength", "nm", num_wavelength_bins, error ) + radiator => radiator_t( "foo_radiator", height_grid, wavelength_grid, error ) + ASSERT( error%is_success() ) + + call radiator%set_optical_depths( optical_depths, error ) + ASSERT( error%is_success() ) + + call radiator%get_optical_depths( temp_od, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_od(1,1), 30.0 ) + ASSERT_EQ( temp_od(2,1), 20.0 ) + ASSERT_EQ( temp_od(3,1), 10.0 ) + ASSERT_EQ( temp_od(1,2), 70.0 ) + ASSERT_EQ( temp_od(2,2), 80.0 ) + ASSERT_EQ( temp_od(3,2), 90.0 ) + + call radiator%set_single_scattering_albedos( single_scattering_albedos, error ) + ASSERT( error%is_success() ) + + call radiator%get_single_scattering_albedos( temp_ssa, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_ssa(1,1), 300.0 ) + ASSERT_EQ( temp_ssa(2,1), 200.0 ) + ASSERT_EQ( temp_ssa(3,1), 100.0 ) + ASSERT_EQ( temp_ssa(1,2), 700.0 ) + ASSERT_EQ( temp_ssa(2,2), 800.0 ) + ASSERT_EQ( temp_ssa(3,2), 900.0 ) + + call radiator%set_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + + call radiator%get_asymmetry_factors( temp_asym, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_asym(1,1,1), 3.0 ) + ASSERT_EQ( temp_asym(2,1,1), 2.0 ) + ASSERT_EQ( temp_asym(3,1,1), 1.0 ) + ASSERT_EQ( temp_asym(1,2,1), 7.0 ) + ASSERT_EQ( temp_asym(2,2,1), 8.0 ) + ASSERT_EQ( temp_asym(3,2,1), 9.0 ) +! + call radiators%add( radiator, error ) + radiator_copy => radiators%get( "foo_radiator", error ) + + ! call radiator_copy + + optical_depths(:,:) = 0.0 + single_scattering_albedos(:,:) = 0.0 + asymmetry_factors(:,:,:) = 0.0 + + call radiator_copy%get_optical_depths( optical_depths, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( optical_depths(1,1), 30.0 ) + ASSERT_EQ( optical_depths(2,1), 20.0 ) + ASSERT_EQ( optical_depths(3,1), 10.0 ) + ASSERT_EQ( optical_depths(1,2), 70.0 ) + ASSERT_EQ( optical_depths(2,2), 80.0 ) + ASSERT_EQ( optical_depths(3,2), 90.0 ) + + call radiator_copy%get_single_scattering_albedos( single_scattering_albedos, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( single_scattering_albedos(1,1), 300.0 ) + ASSERT_EQ( single_scattering_albedos(2,1), 200.0 ) + ASSERT_EQ( single_scattering_albedos(3,1), 100.0 ) + ASSERT_EQ( single_scattering_albedos(1,2), 700.0 ) + ASSERT_EQ( single_scattering_albedos(2,2), 800.0 ) + ASSERT_EQ( single_scattering_albedos(3,2), 900.0 ) + + call radiator_copy%get_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( asymmetry_factors(1,1,1), 3.0 ) + ASSERT_EQ( asymmetry_factors(2,1,1), 2.0 ) + ASSERT_EQ( asymmetry_factors(3,1,1), 1.0 ) + ASSERT_EQ( asymmetry_factors(1,2,1), 7.0 ) + ASSERT_EQ( asymmetry_factors(2,2,1), 8.0 ) + ASSERT_EQ( asymmetry_factors(3,2,1), 9.0 ) + + optical_depths(:,1) = (/ 90.0, 80.0, 70.0 /) + optical_depths(:,2) = (/ 75.0, 85.0, 95.0 /) + single_scattering_albedos(:,1) = (/ 900.0, 800.0, 700.0 /) + single_scattering_albedos(:,2) = (/ 750.0, 850.0, 950.0 /) + asymmetry_factors(:,1,1) = (/ 9.0, 8.0, 7.0 /) + asymmetry_factors(:,2,1) = (/ 5.0, 4.0, 3.0 /) + + call radiator_copy%set_optical_depths( optical_depths, error ) + call radiator_copy%set_single_scattering_albedos( single_scattering_albedos, error ) + call radiator_copy%set_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + + optical_depths(:,:) = 0.0 + single_scattering_albedos(:,:) = 0.0 + asymmetry_factors(:,:,:) = 0.0 + + call radiator%get_optical_depths( optical_depths, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( optical_depths(1,1), 90.0 ) + ASSERT_EQ( optical_depths(2,1), 80.0 ) + ASSERT_EQ( optical_depths(3,1), 70.0 ) + ASSERT_EQ( optical_depths(1,2), 75.0 ) + ASSERT_EQ( optical_depths(2,2), 85.0 ) + ASSERT_EQ( optical_depths(3,2), 95.0 ) + + call radiator%get_single_scattering_albedos( single_scattering_albedos, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( single_scattering_albedos(1,1), 900.0 ) + ASSERT_EQ( single_scattering_albedos(2,1), 800.0 ) + ASSERT_EQ( single_scattering_albedos(3,1), 700.0 ) + ASSERT_EQ( single_scattering_albedos(1,2), 750.0 ) + ASSERT_EQ( single_scattering_albedos(2,2), 850.0 ) + ASSERT_EQ( single_scattering_albedos(3,2), 950.0 ) + + call radiator%get_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( asymmetry_factors(1,1,1), 9.0 ) + ASSERT_EQ( asymmetry_factors(2,1,1), 8.0 ) + ASSERT_EQ( asymmetry_factors(3,1,1), 7.0 ) + ASSERT_EQ( asymmetry_factors(1,2,1), 5.0 ) + ASSERT_EQ( asymmetry_factors(2,2,1), 4.0 ) + ASSERT_EQ( asymmetry_factors(3,2,1), 3.0 ) + + deallocate( radiator_copy ) + deallocate( radiator ) + deallocate( radiators ) + deallocate( height_grid ) + deallocate( wavelength_grid ) + deallocate( tuvx ) + end subroutine test_jiwon_solve -end program combined_tuvx_tests \ No newline at end of file +end program combined_tuvx_tests2 \ No newline at end of file diff --git a/fortran/test/fetch_content_integration/test_tuvx_api.F90 b/fortran/test/fetch_content_integration/test_tuvx_api.F90 index 19f05faf..123e296c 100644 --- a/fortran/test/fetch_content_integration/test_tuvx_api.F90 +++ b/fortran/test/fetch_content_integration/test_tuvx_api.F90 @@ -59,7 +59,6 @@ subroutine test_tuvx_solve() type(tuvx_t), pointer :: tuvx type(error_t) :: error type(grid_map_t), pointer :: grids - character(len=256) :: config_path type(grid_t), pointer :: grid type(profile_map_t), pointer :: profiles type(profile_t), pointer :: profile, profile_copy @@ -68,6 +67,7 @@ subroutine test_tuvx_solve() real*8, dimension(5), target :: edges, edge_values, temp_edge real*8, dimension(4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint real*8 :: temp_real + character(len=256) :: config_path edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index 27b0de76..db21bb45 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -1,21 +1,22 @@ include(test_util) -create_standard_test_fortran(NAME fortran_util SOURCES util.F90) +# create_standard_test_fortran(NAME fortran_util SOURCES util.F90) -if (MUSICA_ENABLE_MICM) - create_standard_test_fortran(NAME micm_fortran_api SOURCES ../fetch_content_integration/test_micm_api.F90) - create_standard_test_fortran(NAME get_micm_version SOURCES ../fetch_content_integration/test_get_micm_version.F90) - create_standard_test_fortran(NAME micm_box_model SOURCES ../fetch_content_integration/test_micm_box_model.F90) -endif() +# if (MUSICA_ENABLE_MICM) +# create_standard_test_fortran(NAME micm_fortran_api SOURCES ../fetch_content_integration/test_micm_api.F90) +# create_standard_test_fortran(NAME get_micm_version SOURCES ../fetch_content_integration/test_get_micm_version.F90) +# create_standard_test_fortran(NAME micm_box_model SOURCES ../fetch_content_integration/test_micm_box_model.F90) +# endif() if (MUSICA_ENABLE_TUVX) - create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) - create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) + # create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) + # create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) + create_standard_test_fortran(NAME temp_jiwon SOURCES ../fetch_content_integration/temp_radiator.F90) - if (MUSICA_ENABLE_OPENMP) - create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) - endif() - if (MUSICA_ENABLE_MPI) - create_standard_test_fortran(NAME connect_to_tuvx_mpi SOURCES tuvx_mpi.F90) - endif() + # if (MUSICA_ENABLE_OPENMP) + # create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) + # endif() + # if (MUSICA_ENABLE_MPI) + # create_standard_test_fortran(NAME connect_to_tuvx_mpi SOURCES tuvx_mpi.F90) + # endif() endif() diff --git a/fortran/tuvx/profile.F90 b/fortran/tuvx/profile.F90 index 68c8bd6a..757a08fc 100644 --- a/fortran/tuvx/profile.F90 +++ b/fortran/tuvx/profile.F90 @@ -16,7 +16,7 @@ module musica_tuvx_profile interface function create_profile_c(profile_name, profile_units, grid, error) & bind(C, name="CreateProfile") - use iso_c_binding, only: c_ptr, c_char, c_size_t + use iso_c_binding, only: c_ptr, c_char use musica_util, only: error_t_c character(len=1, kind=c_char), intent(in) :: profile_name(*) character(len=1, kind=c_char), intent(in) :: profile_units(*) diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index d4abab92..2b2f730a 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -19,8 +19,8 @@ function create_radiator_c(radiator_name, height_grid, wavelength_grid, error) & use iso_c_binding, only : c_ptr, c_char use musica_util, only: error_t_c character(len=1, kind=c_char), intent(in) :: radiator_name(*) - type(c_ptr), intent(in) :: height_grid - type(c_ptr), intent(in) :: wavelength_grid + type(c_ptr), value, intent(in) :: height_grid + type(c_ptr), value, intent(in) :: wavelength_grid type(error_t_c), intent(inout) :: error type(c_ptr) :: create_radiator_c end function create_radiator_c @@ -151,29 +151,26 @@ end function radiator_t_ptr_constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> Constructs a radiator instance that allocates a new TUV-x radiator - function radiator_t_constructor(radiator_name, height_grid, wavelength_grid, error) & - result(this) - use iso_c_binding, only: c_size_t, c_loc - use musica_util, only: error_t, error_t_c, to_c_string, dk => musica_dk + function radiator_t_constructor(radiator_name, height_grid, wavelength_grid, & + error) result(this) + use musica_tuvx_grid, only: grid_t + use musica_util, only: error_t, error_t_c, to_c_string ! Arguments - character(len=*), intent(in) :: radiator_name - real(dk), target, dimension(:,:), intent(in) :: height_grid - real(dk), target, dimension(:,:), intent(in) :: wavelength_grid - type(error_t), intent(inout) :: error + character(len=*), intent(in) :: radiator_name + type(grid_t), intent(in) :: height_grid + type(grid_t), intent(in) :: wavelength_grid + type(error_t), intent(inout) :: error ! Return value type(radiator_t), pointer :: this + ! Local variables type(error_t_c) :: error_c allocate( this ) - !! - !! TODO(jiwon) - is it okay to c_loc() 2d array or should i create a new function - !! that does memory layout conversion - !! - this%ptr_ = create_radiator_c(to_c_string(radiator_name), c_loc(height_grid), & - c_loc(wavelength_grid), error_c) + this%ptr_ = create_radiator_c(to_c_string(radiator_name), height_grid%ptr_, & + wavelength_grid%ptr_, error_c) error = error_t(error_c) end function radiator_t_constructor @@ -196,7 +193,7 @@ subroutine set_optical_depths(this, optical_depths, error) num_vertical_layers = size(optical_depths, 1) num_wavelength_bins = size(optical_depths, 2) - + call set_optical_depths_c(this%ptr_, c_loc(optical_depths), & num_vertical_layers, num_wavelength_bins, error_c) error = error_t(error_c) @@ -210,9 +207,9 @@ subroutine get_optical_depths(this, optical_depths, error) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this + class(radiator_t), intent(inout) :: this real(dk), target, dimension(:,:), intent(in) :: optical_depths - type(error_t), intent(inout) :: error + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -236,9 +233,9 @@ subroutine set_single_scattering_albedos(this, single_scattering_albedos, & use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this + class(radiator_t), intent(inout) :: this real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos - type(error_t), intent(inout) :: error + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -263,12 +260,12 @@ subroutine get_single_scattering_albedos(this, single_scattering_albedos, & use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this + class(radiator_t), intent(inout) :: this real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos - type(error_t), intent(inout) :: error + type(error_t), intent(inout) :: error ! Local variables - type(error_t_c) :: error_c + type(error_t_c) :: error_c integer(kind=c_size_t) :: num_vertical_layers integer(kind=c_size_t) :: num_wavelength_bins From 07cde7dbe4cb160143b05b5fc5bcb58a73151060 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 07:45:59 -0600 Subject: [PATCH 23/31] add tests back: --- fortran/test/unit/CMakeLists.txt | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index db21bb45..de18d125 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -1,22 +1,22 @@ include(test_util) -# create_standard_test_fortran(NAME fortran_util SOURCES util.F90) +create_standard_test_fortran(NAME fortran_util SOURCES util.F90) -# if (MUSICA_ENABLE_MICM) -# create_standard_test_fortran(NAME micm_fortran_api SOURCES ../fetch_content_integration/test_micm_api.F90) -# create_standard_test_fortran(NAME get_micm_version SOURCES ../fetch_content_integration/test_get_micm_version.F90) -# create_standard_test_fortran(NAME micm_box_model SOURCES ../fetch_content_integration/test_micm_box_model.F90) -# endif() +if (MUSICA_ENABLE_MICM) + create_standard_test_fortran(NAME micm_fortran_api SOURCES ../fetch_content_integration/test_micm_api.F90) + create_standard_test_fortran(NAME get_micm_version SOURCES ../fetch_content_integration/test_get_micm_version.F90) + create_standard_test_fortran(NAME micm_box_model SOURCES ../fetch_content_integration/test_micm_box_model.F90) +endif() if (MUSICA_ENABLE_TUVX) - # create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) - # create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) + create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) + create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) create_standard_test_fortran(NAME temp_jiwon SOURCES ../fetch_content_integration/temp_radiator.F90) - # if (MUSICA_ENABLE_OPENMP) - # create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) - # endif() - # if (MUSICA_ENABLE_MPI) - # create_standard_test_fortran(NAME connect_to_tuvx_mpi SOURCES tuvx_mpi.F90) - # endif() + if (MUSICA_ENABLE_OPENMP) + create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) + endif() + if (MUSICA_ENABLE_MPI) + create_standard_test_fortran(NAME connect_to_tuvx_mpi SOURCES tuvx_mpi.F90) + endif() endif() From 72362cc7d5ec293321f05c4dedd66777568a1010 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 08:37:35 -0600 Subject: [PATCH 24/31] fix docker integration --- .../fetch_content_integration/CMakeLists.txt | 58 +++--- .../test_tuvx_api.F90 | 172 ++++++++++++++++-- fortran/tuvx/radiator.F90 | 22 +-- 3 files changed, 199 insertions(+), 53 deletions(-) diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 8c10fb5d..7ec611b1 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -90,23 +90,23 @@ endif() # API Test if (MUSICA_ENABLE_TUVX) - # add_executable(test_tuvx_fortran_api test_tuvx_api.F90) + add_executable(test_tuvx_fortran_api test_tuvx_api.F90) - # target_link_libraries(test_tuvx_fortran_api - # PRIVATE - # musica::musica-fortran - # ) + target_link_libraries(test_tuvx_fortran_api + PRIVATE + musica::musica-fortran + ) - # set_target_properties(test_tuvx_fortran_api - # PROPERTIES - # LINKER_LANGUAGE Fortran - # ) + set_target_properties(test_tuvx_fortran_api + PROPERTIES + LINKER_LANGUAGE Fortran + ) - # add_test( - # NAME test_tuvx_fortran_api - # COMMAND $ - # WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} - # ) + add_test( + NAME test_tuvx_fortran_api + COMMAND $ + WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} + ) add_custom_target( copy_tuvx_examples_dir ALL ${CMAKE_COMMAND} -E copy_directory @@ -120,21 +120,21 @@ if (MUSICA_ENABLE_TUVX) endif() -# TODO(jiwon) - just a temp test -add_executable(test_jiwon temp_radiator.F90) +# # TODO(jiwon) - just a temp test +# add_executable(test_jiwon temp_radiator.F90) -target_link_libraries(test_jiwon - PRIVATE - musica::musica-fortran -) +# target_link_libraries(test_jiwon +# PRIVATE +# musica::musica-fortran +# ) -set_target_properties(test_jiwon - PROPERTIES - LINKER_LANGUAGE Fortran -) +# set_target_properties(test_jiwon +# PROPERTIES +# LINKER_LANGUAGE Fortran +# ) -add_test( - NAME test_jiwon - COMMAND $ - WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} -) \ No newline at end of file +# add_test( +# NAME test_jiwon +# COMMAND $ +# WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} +# ) \ No newline at end of file diff --git a/fortran/test/fetch_content_integration/test_tuvx_api.F90 b/fortran/test/fetch_content_integration/test_tuvx_api.F90 index 123e296c..7dfdddff 100644 --- a/fortran/test/fetch_content_integration/test_tuvx_api.F90 +++ b/fortran/test/fetch_content_integration/test_tuvx_api.F90 @@ -56,24 +56,36 @@ end subroutine test_tuvx_api_invalid_config subroutine test_tuvx_solve() - type(tuvx_t), pointer :: tuvx - type(error_t) :: error - type(grid_map_t), pointer :: grids - type(grid_t), pointer :: grid - type(profile_map_t), pointer :: profiles - type(profile_t), pointer :: profile, profile_copy - type(radiator_map_t), pointer :: radiators - type(radiator_t), pointer :: radiator, radiator_copy - real*8, dimension(5), target :: edges, edge_values, temp_edge - real*8, dimension(4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint - real*8 :: temp_real - character(len=256) :: config_path + type(tuvx_t), pointer :: tuvx + type(error_t) :: error + character(len=256) :: config_path + type(grid_map_t), pointer :: grids + type(grid_t), pointer :: grid, height_grid, wavelength_grid + type(profile_map_t), pointer :: profiles + type(profile_t), pointer :: profile, profile_copy + type(radiator_map_t), pointer :: radiators + type(radiator_t), pointer :: radiator, radiator_copy + real*8, dimension(5), target :: edges, edge_values, temp_edge + real*8, dimension(4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint + real*8 :: temp_real + integer :: num_vertical_layers, num_wavelength_bins + real*8, dimension(3,2), target :: optical_depths, temp_od + real*8, dimension(3,2), target :: single_scattering_albedos, temp_ssa + real*8, dimension(3,2,1), target :: asymmetry_factors, temp_asym edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) edge_values = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) midpoint_values = (/ 15.0, 25.0, 35.0, 45.0 /) layer_densities = (/ 2.0, 4.0, 1.0, 7.0 /) + num_vertical_layers = 3 + num_wavelength_bins = 2 + optical_depths(:,1) = (/ 30.0, 20.0, 10.0 /) + optical_depths(:,2) = (/ 70.0, 80.0, 90.0 /) + single_scattering_albedos(:,1) = (/ 300.0, 200.0, 100.0 /) + single_scattering_albedos(:,2) = (/ 700.0, 800.0, 900.0 /) + asymmetry_factors(:,1,1) = (/ 3.0, 2.0, 1.0 /) + asymmetry_factors(:,2,1) = (/ 7.0, 8.0, 9.0 /) config_path = "examples/ts1_tsmlt.json" @@ -315,12 +327,146 @@ subroutine test_tuvx_solve() ASSERT_EQ( temp_edge(3), 36.0 ) ASSERT_EQ( temp_edge(4), 38.0 ) ASSERT_EQ( temp_edge(5), 40.0 ) - + + radiators => tuvx%get_radiators( error ) + ASSERT( error%is_success() ) + + radiator => radiators%get( "foo_radiator", error ) + ASSERT( .not. error%is_success() ) + deallocate( radiator ) + deallocate( radiators ) + + radiators =>radiator_map_t( error ) + ASSERT( error%is_success() ) + + height_grid => grid_t( "height", "km", num_vertical_layers, error ) + wavelength_grid => grid_t( "wavelength", "nm", num_wavelength_bins, error ) + radiator => radiator_t( "foo_radiator", height_grid, wavelength_grid, error ) + ASSERT( error%is_success() ) + + call radiator%set_optical_depths( optical_depths, error ) + ASSERT( error%is_success() ) + + call radiator%get_optical_depths( temp_od, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_od(1,1), 30.0 ) + ASSERT_EQ( temp_od(2,1), 20.0 ) + ASSERT_EQ( temp_od(3,1), 10.0 ) + ASSERT_EQ( temp_od(1,2), 70.0 ) + ASSERT_EQ( temp_od(2,2), 80.0 ) + ASSERT_EQ( temp_od(3,2), 90.0 ) + + call radiator%set_single_scattering_albedos( single_scattering_albedos, error ) + ASSERT( error%is_success() ) + + call radiator%get_single_scattering_albedos( temp_ssa, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_ssa(1,1), 300.0 ) + ASSERT_EQ( temp_ssa(2,1), 200.0 ) + ASSERT_EQ( temp_ssa(3,1), 100.0 ) + ASSERT_EQ( temp_ssa(1,2), 700.0 ) + ASSERT_EQ( temp_ssa(2,2), 800.0 ) + ASSERT_EQ( temp_ssa(3,2), 900.0 ) + + call radiator%set_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + + call radiator%get_asymmetry_factors( temp_asym, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_asym(1,1,1), 3.0 ) + ASSERT_EQ( temp_asym(2,1,1), 2.0 ) + ASSERT_EQ( temp_asym(3,1,1), 1.0 ) + ASSERT_EQ( temp_asym(1,2,1), 7.0 ) + ASSERT_EQ( temp_asym(2,2,1), 8.0 ) + ASSERT_EQ( temp_asym(3,2,1), 9.0 ) +! + call radiators%add( radiator, error ) + radiator_copy => radiators%get( "foo_radiator", error ) + + optical_depths(:,:) = 0.0 + single_scattering_albedos(:,:) = 0.0 + asymmetry_factors(:,:,:) = 0.0 + + call radiator_copy%get_optical_depths( optical_depths, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( optical_depths(1,1), 30.0 ) + ASSERT_EQ( optical_depths(2,1), 20.0 ) + ASSERT_EQ( optical_depths(3,1), 10.0 ) + ASSERT_EQ( optical_depths(1,2), 70.0 ) + ASSERT_EQ( optical_depths(2,2), 80.0 ) + ASSERT_EQ( optical_depths(3,2), 90.0 ) + + call radiator_copy%get_single_scattering_albedos( single_scattering_albedos, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( single_scattering_albedos(1,1), 300.0 ) + ASSERT_EQ( single_scattering_albedos(2,1), 200.0 ) + ASSERT_EQ( single_scattering_albedos(3,1), 100.0 ) + ASSERT_EQ( single_scattering_albedos(1,2), 700.0 ) + ASSERT_EQ( single_scattering_albedos(2,2), 800.0 ) + ASSERT_EQ( single_scattering_albedos(3,2), 900.0 ) + + call radiator_copy%get_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( asymmetry_factors(1,1,1), 3.0 ) + ASSERT_EQ( asymmetry_factors(2,1,1), 2.0 ) + ASSERT_EQ( asymmetry_factors(3,1,1), 1.0 ) + ASSERT_EQ( asymmetry_factors(1,2,1), 7.0 ) + ASSERT_EQ( asymmetry_factors(2,2,1), 8.0 ) + ASSERT_EQ( asymmetry_factors(3,2,1), 9.0 ) + + optical_depths(:,1) = (/ 90.0, 80.0, 70.0 /) + optical_depths(:,2) = (/ 75.0, 85.0, 95.0 /) + single_scattering_albedos(:,1) = (/ 900.0, 800.0, 700.0 /) + single_scattering_albedos(:,2) = (/ 750.0, 850.0, 950.0 /) + asymmetry_factors(:,1,1) = (/ 9.0, 8.0, 7.0 /) + asymmetry_factors(:,2,1) = (/ 5.0, 4.0, 3.0 /) + + call radiator_copy%set_optical_depths( optical_depths, error ) + call radiator_copy%set_single_scattering_albedos( single_scattering_albedos, error ) + call radiator_copy%set_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + + optical_depths(:,:) = 0.0 + single_scattering_albedos(:,:) = 0.0 + asymmetry_factors(:,:,:) = 0.0 + + call radiator%get_optical_depths( optical_depths, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( optical_depths(1,1), 90.0 ) + ASSERT_EQ( optical_depths(2,1), 80.0 ) + ASSERT_EQ( optical_depths(3,1), 70.0 ) + ASSERT_EQ( optical_depths(1,2), 75.0 ) + ASSERT_EQ( optical_depths(2,2), 85.0 ) + ASSERT_EQ( optical_depths(3,2), 95.0 ) + + call radiator%get_single_scattering_albedos( single_scattering_albedos, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( single_scattering_albedos(1,1), 900.0 ) + ASSERT_EQ( single_scattering_albedos(2,1), 800.0 ) + ASSERT_EQ( single_scattering_albedos(3,1), 700.0 ) + ASSERT_EQ( single_scattering_albedos(1,2), 750.0 ) + ASSERT_EQ( single_scattering_albedos(2,2), 850.0 ) + ASSERT_EQ( single_scattering_albedos(3,2), 950.0 ) + + call radiator%get_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( asymmetry_factors(1,1,1), 9.0 ) + ASSERT_EQ( asymmetry_factors(2,1,1), 8.0 ) + ASSERT_EQ( asymmetry_factors(3,1,1), 7.0 ) + ASSERT_EQ( asymmetry_factors(1,2,1), 5.0 ) + ASSERT_EQ( asymmetry_factors(2,2,1), 4.0 ) + ASSERT_EQ( asymmetry_factors(3,2,1), 3.0 ) + deallocate( grid ) deallocate( grids ) deallocate( profile ) deallocate( profile_copy ) deallocate( profiles ) + deallocate( radiator_copy ) + deallocate( radiator ) + deallocate( radiators ) + deallocate( height_grid ) + deallocate( wavelength_grid ) deallocate( tuvx ) end subroutine test_tuvx_solve diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index 2b2f730a..121e3cb0 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -18,18 +18,18 @@ function create_radiator_c(radiator_name, height_grid, wavelength_grid, error) & bind(C, name="CreateRadiator") use iso_c_binding, only : c_ptr, c_char use musica_util, only: error_t_c - character(len=1, kind=c_char), intent(in) :: radiator_name(*) - type(c_ptr), value, intent(in) :: height_grid - type(c_ptr), value, intent(in) :: wavelength_grid - type(error_t_c), intent(inout) :: error + character(len=1, kind=c_char), intent(in) :: radiator_name(*) + type(c_ptr), value, intent(in) :: height_grid + type(c_ptr), value, intent(in) :: wavelength_grid + type(error_t_c), intent(inout) :: error type(c_ptr) :: create_radiator_c end function create_radiator_c subroutine delete_radiator_c(radiator, error) bind(C, name="DeleteRadiator") use iso_c_binding, only : c_ptr use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: radiator - type(error_t_c), intent(inout) :: error + type(c_ptr), value, intent(in) :: radiator + type(error_t_c), intent(inout) :: error end subroutine delete_radiator_c subroutine set_optical_depths_c(radiator, optical_depths, num_vertical_layers, & @@ -112,15 +112,15 @@ end subroutine get_asymmetry_factors_c procedure :: set_optical_depths ! Get radiator optical depths procedure :: get_optical_depths - ! Set the radiator single scattering albedos + ! Set radiator single scattering albedos procedure :: set_single_scattering_albedos - ! Get the radiator single scattering albedos + ! Get radiator single scattering albedos procedure :: get_single_scattering_albedos - ! Set the radiator asymmetry_factors + ! Set radiator asymmetry_factors procedure :: set_asymmetry_factors - ! Get the radiator asymmetry factors + ! Get radiator asymmetry factors procedure :: get_asymmetry_factors - ! Deallocate the radiator instance + ! Deallocate radiator instance final :: finalize_radiator_t end type radiator_t From ceb64d5eea817ae00e73a41fb6f9d1bf94ac98c2 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 10:25:23 -0600 Subject: [PATCH 25/31] revert cmake --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 27b92e20..175f4b8b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -27,7 +27,7 @@ option(MUSICA_ENABLE_MPI "Enable MPI parallel support" OFF) option(MUSICA_ENABLE_OPENMP "Enable OpemMP support" OFF) option(MUSICA_ENABLE_MEMCHECK "Enable memory checking" OFF) option(MUSICA_BUILD_DOCS "Build the documentation" OFF) -option(MUSICA_ENABLE_MICM "Enable MICM" OFF) +option(MUSICA_ENABLE_MICM "Enable MICM" ON) option(MUSICA_ENABLE_TUVX "Enable TUV-x" ON) set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE "1" CACHE STRING "Set MICM vector-ordered matrix dimension") From b75e012637678a5dcd19fb4bf57af3701eef460b Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 13:41:39 -0600 Subject: [PATCH 26/31] clean up --- src/tuvx/interface_profile_map.F90 | 8 ++++---- src/tuvx/interface_radiator_map.F90 | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/tuvx/interface_profile_map.F90 b/src/tuvx/interface_profile_map.F90 index a6057095..47e9cba7 100644 --- a/src/tuvx/interface_profile_map.F90 +++ b/src/tuvx/interface_profile_map.F90 @@ -3,11 +3,11 @@ ! module tuvx_interface_profile_map - use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char - use tuvx_profile, only : profile_t + use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char + use tuvx_profile, only : profile_t use tuvx_profile_warehouse, only : profile_warehouse_t - use musica_tuvx_util, only : to_f_string, string_t_c - use musica_string, only : string_t + use musica_tuvx_util, only : to_f_string, string_t_c + use musica_string, only : string_t implicit none diff --git a/src/tuvx/interface_radiator_map.F90 b/src/tuvx/interface_radiator_map.F90 index 3e5b1369..1ff04482 100644 --- a/src/tuvx/interface_radiator_map.F90 +++ b/src/tuvx/interface_radiator_map.F90 @@ -4,8 +4,8 @@ module tuvx_interface_radiator_map use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char - use tuvx_radiator_warehouse, only : radiator_warehouse_t use tuvx_radiator, only : radiator_t + use tuvx_radiator_warehouse, only : radiator_warehouse_t use musica_tuvx_util, only : to_f_string, string_t_c use musica_string, only : string_t From 3611be0202cc308988c752ef886762d923c27cc7 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 15:49:06 -0600 Subject: [PATCH 27/31] code cleanup --- .../temp_radiator.F90 | 201 ---------- src/test/unit/tuvx/CMakeLists.txt | 1 - src/test/unit/tuvx/radiatortest.cpp | 361 ------------------ src/test/unit/tuvx/tuvx_c_api.cpp | 326 ++++++++++++++++ 4 files changed, 326 insertions(+), 563 deletions(-) delete mode 100644 fortran/test/fetch_content_integration/temp_radiator.F90 delete mode 100644 src/test/unit/tuvx/radiatortest.cpp diff --git a/fortran/test/fetch_content_integration/temp_radiator.F90 b/fortran/test/fetch_content_integration/temp_radiator.F90 deleted file mode 100644 index 5673ddd8..00000000 --- a/fortran/test/fetch_content_integration/temp_radiator.F90 +++ /dev/null @@ -1,201 +0,0 @@ -! Copyright (C) 2023-2024 National Center for Atmospheric Research -! SPDX-License-Identifier: Apache-2.0 -! -program combined_tuvx_tests2 - use iso_c_binding - use musica_tuvx, only: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t, & - radiator_map_t, radiator_t - use musica_util, only: assert, error_t, dk => musica_dk - - implicit none - -#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) -#define ASSERT_EQ( a, b ) call assert( a == b, __FILE__, __LINE__ ) - - ! Call the valid test subroutine - call test_jiwon_solve() - - contains - subroutine test_jiwon_solve() - - type(tuvx_t), pointer :: tuvx - type(error_t) :: error - type(grid_map_t), pointer :: grids - character(len=256) :: config_path - type(grid_t), pointer :: grid, height_grid, wavelength_grid - type(profile_map_t), pointer :: profiles - type(profile_t), pointer :: profile, profile_copy - type(radiator_map_t), pointer :: radiators - type(radiator_t), pointer :: radiator, radiator_copy - real*8, dimension(5), target :: edges, edge_values, temp_edge - real*8, dimension(4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint - real*8 :: temp_real - integer :: num_vertical_layers, num_wavelength_bins - real*8, dimension(3,2), target :: optical_depths, temp_od - real*8, dimension(3,2), target :: single_scattering_albedos, temp_ssa - real*8, dimension(3,2,1), target :: asymmetry_factors, temp_asym - - edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) - midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) - edge_values = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) - midpoint_values = (/ 15.0, 25.0, 35.0, 45.0 /) - layer_densities = (/ 2.0, 4.0, 1.0, 7.0 /) - - num_vertical_layers = 3 - num_wavelength_bins = 2 - - optical_depths(:,1) = (/ 30.0, 20.0, 10.0 /) - optical_depths(:,2) = (/ 70.0, 80.0, 90.0 /) - single_scattering_albedos(:,1) = (/ 300.0, 200.0, 100.0 /) - single_scattering_albedos(:,2) = (/ 700.0, 800.0, 900.0 /) - asymmetry_factors(:,1,1) = (/ 3.0, 2.0, 1.0 /) - asymmetry_factors(:,2,1) = (/ 7.0, 8.0, 9.0 /) - - config_path = "examples/ts1_tsmlt.json" - - tuvx => tuvx_t( config_path, error ) - ASSERT( error%is_success() ) - -! ! -! ! TODO - Radiator starts here? -! ! - radiators => tuvx%get_radiators( error ) - ASSERT( error%is_success() ) - - radiator => radiators%get( "foo_radiator", error ) - ASSERT( .not. error%is_success() ) ! non-accessible grid - deallocate( radiator ) - deallocate( radiators ) - - radiators =>radiator_map_t( error ) - ASSERT( error%is_success() ) - - height_grid => grid_t( "height", "km", num_vertical_layers, error ) - wavelength_grid => grid_t( "wavelength", "nm", num_wavelength_bins, error ) - radiator => radiator_t( "foo_radiator", height_grid, wavelength_grid, error ) - ASSERT( error%is_success() ) - - call radiator%set_optical_depths( optical_depths, error ) - ASSERT( error%is_success() ) - - call radiator%get_optical_depths( temp_od, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( temp_od(1,1), 30.0 ) - ASSERT_EQ( temp_od(2,1), 20.0 ) - ASSERT_EQ( temp_od(3,1), 10.0 ) - ASSERT_EQ( temp_od(1,2), 70.0 ) - ASSERT_EQ( temp_od(2,2), 80.0 ) - ASSERT_EQ( temp_od(3,2), 90.0 ) - - call radiator%set_single_scattering_albedos( single_scattering_albedos, error ) - ASSERT( error%is_success() ) - - call radiator%get_single_scattering_albedos( temp_ssa, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( temp_ssa(1,1), 300.0 ) - ASSERT_EQ( temp_ssa(2,1), 200.0 ) - ASSERT_EQ( temp_ssa(3,1), 100.0 ) - ASSERT_EQ( temp_ssa(1,2), 700.0 ) - ASSERT_EQ( temp_ssa(2,2), 800.0 ) - ASSERT_EQ( temp_ssa(3,2), 900.0 ) - - call radiator%set_asymmetry_factors( asymmetry_factors, error ) - ASSERT( error%is_success() ) - - call radiator%get_asymmetry_factors( temp_asym, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( temp_asym(1,1,1), 3.0 ) - ASSERT_EQ( temp_asym(2,1,1), 2.0 ) - ASSERT_EQ( temp_asym(3,1,1), 1.0 ) - ASSERT_EQ( temp_asym(1,2,1), 7.0 ) - ASSERT_EQ( temp_asym(2,2,1), 8.0 ) - ASSERT_EQ( temp_asym(3,2,1), 9.0 ) -! - call radiators%add( radiator, error ) - radiator_copy => radiators%get( "foo_radiator", error ) - - ! call radiator_copy - - optical_depths(:,:) = 0.0 - single_scattering_albedos(:,:) = 0.0 - asymmetry_factors(:,:,:) = 0.0 - - call radiator_copy%get_optical_depths( optical_depths, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( optical_depths(1,1), 30.0 ) - ASSERT_EQ( optical_depths(2,1), 20.0 ) - ASSERT_EQ( optical_depths(3,1), 10.0 ) - ASSERT_EQ( optical_depths(1,2), 70.0 ) - ASSERT_EQ( optical_depths(2,2), 80.0 ) - ASSERT_EQ( optical_depths(3,2), 90.0 ) - - call radiator_copy%get_single_scattering_albedos( single_scattering_albedos, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( single_scattering_albedos(1,1), 300.0 ) - ASSERT_EQ( single_scattering_albedos(2,1), 200.0 ) - ASSERT_EQ( single_scattering_albedos(3,1), 100.0 ) - ASSERT_EQ( single_scattering_albedos(1,2), 700.0 ) - ASSERT_EQ( single_scattering_albedos(2,2), 800.0 ) - ASSERT_EQ( single_scattering_albedos(3,2), 900.0 ) - - call radiator_copy%get_asymmetry_factors( asymmetry_factors, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( asymmetry_factors(1,1,1), 3.0 ) - ASSERT_EQ( asymmetry_factors(2,1,1), 2.0 ) - ASSERT_EQ( asymmetry_factors(3,1,1), 1.0 ) - ASSERT_EQ( asymmetry_factors(1,2,1), 7.0 ) - ASSERT_EQ( asymmetry_factors(2,2,1), 8.0 ) - ASSERT_EQ( asymmetry_factors(3,2,1), 9.0 ) - - optical_depths(:,1) = (/ 90.0, 80.0, 70.0 /) - optical_depths(:,2) = (/ 75.0, 85.0, 95.0 /) - single_scattering_albedos(:,1) = (/ 900.0, 800.0, 700.0 /) - single_scattering_albedos(:,2) = (/ 750.0, 850.0, 950.0 /) - asymmetry_factors(:,1,1) = (/ 9.0, 8.0, 7.0 /) - asymmetry_factors(:,2,1) = (/ 5.0, 4.0, 3.0 /) - - call radiator_copy%set_optical_depths( optical_depths, error ) - call radiator_copy%set_single_scattering_albedos( single_scattering_albedos, error ) - call radiator_copy%set_asymmetry_factors( asymmetry_factors, error ) - ASSERT( error%is_success() ) - - optical_depths(:,:) = 0.0 - single_scattering_albedos(:,:) = 0.0 - asymmetry_factors(:,:,:) = 0.0 - - call radiator%get_optical_depths( optical_depths, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( optical_depths(1,1), 90.0 ) - ASSERT_EQ( optical_depths(2,1), 80.0 ) - ASSERT_EQ( optical_depths(3,1), 70.0 ) - ASSERT_EQ( optical_depths(1,2), 75.0 ) - ASSERT_EQ( optical_depths(2,2), 85.0 ) - ASSERT_EQ( optical_depths(3,2), 95.0 ) - - call radiator%get_single_scattering_albedos( single_scattering_albedos, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( single_scattering_albedos(1,1), 900.0 ) - ASSERT_EQ( single_scattering_albedos(2,1), 800.0 ) - ASSERT_EQ( single_scattering_albedos(3,1), 700.0 ) - ASSERT_EQ( single_scattering_albedos(1,2), 750.0 ) - ASSERT_EQ( single_scattering_albedos(2,2), 850.0 ) - ASSERT_EQ( single_scattering_albedos(3,2), 950.0 ) - - call radiator%get_asymmetry_factors( asymmetry_factors, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( asymmetry_factors(1,1,1), 9.0 ) - ASSERT_EQ( asymmetry_factors(2,1,1), 8.0 ) - ASSERT_EQ( asymmetry_factors(3,1,1), 7.0 ) - ASSERT_EQ( asymmetry_factors(1,2,1), 5.0 ) - ASSERT_EQ( asymmetry_factors(2,2,1), 4.0 ) - ASSERT_EQ( asymmetry_factors(3,2,1), 3.0 ) - - deallocate( radiator_copy ) - deallocate( radiator ) - deallocate( radiators ) - deallocate( height_grid ) - deallocate( wavelength_grid ) - deallocate( tuvx ) - end subroutine test_jiwon_solve - -end program combined_tuvx_tests2 \ No newline at end of file diff --git a/src/test/unit/tuvx/CMakeLists.txt b/src/test/unit/tuvx/CMakeLists.txt index 05dcc0f8..28b926c0 100644 --- a/src/test/unit/tuvx/CMakeLists.txt +++ b/src/test/unit/tuvx/CMakeLists.txt @@ -1,7 +1,6 @@ include(test_util) create_standard_test_cxx(NAME tuvx_c_api SOURCES tuvx_c_api.cpp) -create_standard_test_cxx(NAME tuvx_radiator_test SOURCES radiatortest.cpp) ################################################################################ # Copy tuvx test data diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp deleted file mode 100644 index 33e3e354..00000000 --- a/src/test/unit/tuvx/radiatortest.cpp +++ /dev/null @@ -1,361 +0,0 @@ -#include -#include - -#include -#include -#include - -using namespace musica; - -// Test fixture for the TUVX C API -class TuvxCApiTest : public ::testing::Test -{ - protected: - TUVX* tuvx; - - // the function that google test actually calls before each test - void SetUp() override - { - tuvx = nullptr; - } - - void SetUp(const char* config_path) - { - Error error; - tuvx = CreateTuvx(config_path, &error); - if (!IsSuccess(error)) - { - std::cerr << "Error creating TUVX instance: " << error.message_.value_ << std::endl; - } - ASSERT_TRUE(IsSuccess(error)); - DeleteError(&error); - } - - void TearDown() override - { - if (tuvx == nullptr) - { - return; - } - Error error; - DeleteTuvx(tuvx, &error); - ASSERT_TRUE(IsSuccess(error)); - DeleteError(&error); - tuvx = nullptr; - } -}; - -TEST_F(TuvxCApiTest, CannotGetConfiguredRadiator) -{ - const char* yaml_config_path = "examples/ts1_tsmlt.yml"; - SetUp(yaml_config_path); - Error error; - RadiatorMap* radiator_map = GetRadiatorMap(tuvx, &error); - ASSERT_TRUE(IsSuccess(error)); - ASSERT_NE(radiator_map, nullptr); - Radiator* radiator = GetRadiator(radiator_map, "foo", &error); - ASSERT_FALSE(IsSuccess(error)); // non-host grid - ASSERT_EQ(radiator, nullptr); - DeleteRadiatorMap(radiator_map, &error); - ASSERT_TRUE(IsSuccess(error)); - DeleteError(&error); -} - -TEST_F(TuvxCApiTest, CanCreateRadiator) -{ - Error error; - Grid* height = CreateGrid("height", "km", 3, &error); - Grid* wavelength = CreateGrid("wavelength", "nm", 2, &error); - Radiator* radiator = CreateRadiator("foo", height, wavelength, &error); - ASSERT_TRUE(IsSuccess(error)); - ASSERT_NE(radiator, nullptr); - - // Test for optical depths - std::size_t num_vertical_layers = 3; - std::size_t num_wavelength_bins = 2; - // Allocate array as 1D - double* optical_depths_1D = new double[num_wavelength_bins * num_vertical_layers]; - // Allocate an array of pointers to each row - double** optical_depths = new double* [num_vertical_layers]; - // Fill in the pointers to the rows - for(int row =0; row Date: Mon, 5 Aug 2024 17:00:26 -0600 Subject: [PATCH 28/31] code clean up --- cmake/dependencies.cmake | 3 +- docker/Dockerfile | 2 +- docker/Dockerfile.fortran-gcc | 4 +- .../fetch_content_integration/CMakeLists.txt | 22 +-- fortran/test/unit/CMakeLists.txt | 1 - fortran/tuvx/radiator.F90 | 44 +++--- include/musica/tuvx/tuvx.hpp | 4 +- src/test/unit/tuvx/tuvx_c_api.cpp | 121 +++++++++------- src/tuvx/interface.F90 | 20 +-- src/tuvx/interface_radiator.F90 | 137 ++++++++---------- src/tuvx/interface_radiator_map.F90 | 24 +-- src/tuvx/radiator.cpp | 3 +- 12 files changed, 177 insertions(+), 208 deletions(-) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index d819d737..43de1d73 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -75,8 +75,7 @@ if (MUSICA_ENABLE_TUVX AND MUSICA_BUILD_C_CXX_INTERFACE) set(TUVX_INSTALL_INCLUDE_DIR ${MUSICA_INSTALL_INCLUDE_DIR} CACHE STRING "" FORCE) set_git_default(TUVX_GIT_REPOSITORY https://github.com/NCAR/tuv-x.git) - # set_git_default(TUVX_GIT_TAG 80f896a0fb591987c2a79209377bd6f599b4fb6f) - set_git_default(TUVX_GIT_TAG make-radiator-updatable) + set_git_default(TUVX_GIT_TAG f8ae5a2) FetchContent_Declare(tuvx GIT_REPOSITORY ${TUVX_GIT_REPOSITORY} diff --git a/docker/Dockerfile b/docker/Dockerfile index 377af261..d93a7d06 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -1,6 +1,6 @@ FROM fedora:35 -ARG BUILD_TYPE=Debug +ARG BUILD_TYPE=Release RUN dnf -y update \ && dnf -y install \ diff --git a/docker/Dockerfile.fortran-gcc b/docker/Dockerfile.fortran-gcc index f4b1833b..77912573 100644 --- a/docker/Dockerfile.fortran-gcc +++ b/docker/Dockerfile.fortran-gcc @@ -33,14 +33,12 @@ ENV FFLAGS="-I/usr/include/" # Copy the musica code COPY . musica -ARG MUSICA_GIT_TAG=122-make-radiator-updatable - # Build and install MUSICA RUN cd musica \ && cmake -S . \ -B build \ - -D MUSICA_GIT_TAG=${MUSICA_GIT_TAG} \ -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ + -D MUSICA_GIT_TAG=${MUSICA_GIT_TAG} \ -D MUSICA_BUILD_FORTRAN_INTERFACE=ON \ -D MUSICA_ENABLE_MEMCHECK=ON \ && cd build \ diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 7ec611b1..1b4de550 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -117,24 +117,4 @@ if (MUSICA_ENABLE_TUVX) copy_tuvx_data_dir ALL ${CMAKE_COMMAND} -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../../../build/_deps/tuvx-src/data ${CMAKE_BINARY_DIR}/data ) -endif() - - -# # TODO(jiwon) - just a temp test -# add_executable(test_jiwon temp_radiator.F90) - -# target_link_libraries(test_jiwon -# PRIVATE -# musica::musica-fortran -# ) - -# set_target_properties(test_jiwon -# PROPERTIES -# LINKER_LANGUAGE Fortran -# ) - -# add_test( -# NAME test_jiwon -# COMMAND $ -# WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} -# ) \ No newline at end of file +endif() \ No newline at end of file diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index e97843ba..c2946b08 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -12,7 +12,6 @@ endif() if (MUSICA_ENABLE_TUVX) create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) - create_standard_test_fortran(NAME temp_jiwon SOURCES ../fetch_content_integration/temp_radiator.F90) if (MUSICA_ENABLE_OPENMP) create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index 121e3cb0..60a79ee6 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -157,10 +157,10 @@ function radiator_t_constructor(radiator_name, height_grid, wavelength_grid, & use musica_util, only: error_t, error_t_c, to_c_string ! Arguments - character(len=*), intent(in) :: radiator_name - type(grid_t), intent(in) :: height_grid - type(grid_t), intent(in) :: wavelength_grid - type(error_t), intent(inout) :: error + character(len=*), intent(in) :: radiator_name + type(grid_t), intent(in) :: height_grid + type(grid_t), intent(in) :: wavelength_grid + type(error_t), intent(inout) :: error ! Return value type(radiator_t), pointer :: this @@ -182,9 +182,9 @@ subroutine set_optical_depths(this, optical_depths, error) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:), intent(in) :: optical_depths - type(error_t), intent(inout) :: error + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:), intent(in) :: optical_depths + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -207,9 +207,9 @@ subroutine get_optical_depths(this, optical_depths, error) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:), intent(in) :: optical_depths - type(error_t), intent(inout) :: error + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:), intent(in) :: optical_depths + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -233,9 +233,9 @@ subroutine set_single_scattering_albedos(this, single_scattering_albedos, & use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos - type(error_t), intent(inout) :: error + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -260,9 +260,9 @@ subroutine get_single_scattering_albedos(this, single_scattering_albedos, & use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos - type(error_t), intent(inout) :: error + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -286,9 +286,9 @@ subroutine set_asymmetry_factors(this, asymmetry_factors, error) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:,:), intent(in) :: asymmetry_factors - type(error_t), intent(inout) :: error + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:,:), intent(in) :: asymmetry_factors + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -313,9 +313,9 @@ subroutine get_asymmetry_factors(this, asymmetry_factors, error) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:,:), intent(in) :: asymmetry_factors - type(error_t), intent(inout) :: error + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:,:), intent(in) :: asymmetry_factors + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c diff --git a/include/musica/tuvx/tuvx.hpp b/include/musica/tuvx/tuvx.hpp index 47516256..bd862fde 100644 --- a/include/musica/tuvx/tuvx.hpp +++ b/include/musica/tuvx/tuvx.hpp @@ -39,8 +39,8 @@ namespace musica /// @return a profile map pointer ProfileMap *CreateProfileMap(Error *error); - /// @brief Create a radiator map. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later - /// on to be transparent to downstream projects + /// @brief Create a radiator map. For now, this calls the interal tuvx fortran api, but will allow the change to c++ + /// later on to be transparent to downstream projects /// @param error The error struct to indicate success or failure /// @return a radiator map pointer RadiatorMap *CreateRadiatorMap(Error *error); diff --git a/src/test/unit/tuvx/tuvx_c_api.cpp b/src/test/unit/tuvx/tuvx_c_api.cpp index bfa47c3f..91dbbc93 100644 --- a/src/test/unit/tuvx/tuvx_c_api.cpp +++ b/src/test/unit/tuvx/tuvx_c_api.cpp @@ -417,16 +417,16 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) // Allocate array as 1D double* optical_depths_1D = new double[num_wavelength_bins * num_vertical_layers]; // Allocate an array of pointers to each row - double** optical_depths = new double* [num_vertical_layers]; + double** optical_depths = new double*[num_vertical_layers]; // Fill in the pointers to the rows - for(int row =0; row Date: Mon, 5 Aug 2024 17:12:42 -0600 Subject: [PATCH 29/31] revert back to main branch --- fortran/test/fetch_content_integration/CMakeLists.txt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 1b4de550..d0707f7b 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -9,8 +9,7 @@ set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}) include(FetchContent) -# set(MUSICA_GIT_TAG "main" CACHE STRING "Git tag for the musica_fortran repository") -set(MUSICA_GIT_TAG "122-make-radiator-updatable" CACHE STRING "Git tag for the musica_fortran repository") +set(MUSICA_GIT_TAG "main" CACHE STRING "Git tag for the musica_fortran repository") message(STATUS "Using MUSICA_GIT_TAG: ${MUSICA_GIT_TAG}") From d41d152b424f1655816750a8c3d0d2a96fb8935f Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 7 Aug 2024 11:16:57 -0600 Subject: [PATCH 30/31] Address review comments --- cmake/dependencies.cmake | 2 +- docker/Dockerfile | 1 - docker/Dockerfile.fortran-gcc | 1 - docker/Dockerfile.fortran-gcc.integration | 1 - docker/Dockerfile.memcheck | 1 - docker/Dockerfile.mpi | 1 - docker/Dockerfile.mpi_openmp | 1 - docker/Dockerfile.openmp | 1 - docker/Dockerfile.python | 1 - include/musica/tuvx/grid.hpp | 5 +++-- include/musica/tuvx/grid_map.hpp | 5 +++-- include/musica/tuvx/profile.hpp | 5 +++-- include/musica/tuvx/profile_map.hpp | 5 +++-- 13 files changed, 13 insertions(+), 17 deletions(-) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index 43de1d73..f50decd0 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -75,7 +75,7 @@ if (MUSICA_ENABLE_TUVX AND MUSICA_BUILD_C_CXX_INTERFACE) set(TUVX_INSTALL_INCLUDE_DIR ${MUSICA_INSTALL_INCLUDE_DIR} CACHE STRING "" FORCE) set_git_default(TUVX_GIT_REPOSITORY https://github.com/NCAR/tuv-x.git) - set_git_default(TUVX_GIT_TAG f8ae5a2) + set_git_default(TUVX_GIT_TAG 0e27463) FetchContent_Declare(tuvx GIT_REPOSITORY ${TUVX_GIT_REPOSITORY} diff --git a/docker/Dockerfile b/docker/Dockerfile index d93a7d06..31f319f2 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -9,7 +9,6 @@ RUN dnf -y update \ gfortran \ gdb \ git \ - # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.fortran-gcc b/docker/Dockerfile.fortran-gcc index 77912573..0a181191 100644 --- a/docker/Dockerfile.fortran-gcc +++ b/docker/Dockerfile.fortran-gcc @@ -13,7 +13,6 @@ RUN dnf -y update \ git \ hdf5-devel \ json-devel \ - # lapack-devel \ lcov \ libcurl-devel \ m4 \ diff --git a/docker/Dockerfile.fortran-gcc.integration b/docker/Dockerfile.fortran-gcc.integration index 8fdae414..610eebc8 100644 --- a/docker/Dockerfile.fortran-gcc.integration +++ b/docker/Dockerfile.fortran-gcc.integration @@ -14,7 +14,6 @@ RUN dnf -y update \ git \ hdf5-devel \ json-devel \ - # lapack-devel \ lcov \ libcurl-devel \ m4 \ diff --git a/docker/Dockerfile.memcheck b/docker/Dockerfile.memcheck index d31397d6..8b330b51 100644 --- a/docker/Dockerfile.memcheck +++ b/docker/Dockerfile.memcheck @@ -9,7 +9,6 @@ RUN dnf -y update \ gfortran \ gdb \ git \ - # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.mpi b/docker/Dockerfile.mpi index 3a16b622..8935ca62 100644 --- a/docker/Dockerfile.mpi +++ b/docker/Dockerfile.mpi @@ -16,7 +16,6 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.mpi_openmp b/docker/Dockerfile.mpi_openmp index d6dfade1..7a5eb9b8 100644 --- a/docker/Dockerfile.mpi_openmp +++ b/docker/Dockerfile.mpi_openmp @@ -16,7 +16,6 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.openmp b/docker/Dockerfile.openmp index 0ab97773..cb612509 100644 --- a/docker/Dockerfile.openmp +++ b/docker/Dockerfile.openmp @@ -16,7 +16,6 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.python b/docker/Dockerfile.python index 5765515b..8484ddc7 100644 --- a/docker/Dockerfile.python +++ b/docker/Dockerfile.python @@ -9,7 +9,6 @@ RUN dnf -y update \ gcc-fortran \ gdb \ git \ - # lapack-devel \ make \ netcdf-fortran-devel \ pip \ diff --git a/include/musica/tuvx/grid.hpp b/include/musica/tuvx/grid.hpp index 86c7f46f..bd7a6d3b 100644 --- a/include/musica/tuvx/grid.hpp +++ b/include/musica/tuvx/grid.hpp @@ -14,9 +14,10 @@ namespace musica class Profile; class Radiator; - /// @brief A grid struct used to access grid information in tuvx - struct Grid + /// @brief A grid class used to access grid information in tuvx + class Grid { + public: /// @brief Creates a grid instance /// @param grid_name The name of the grid /// @param units The units of the grid diff --git a/include/musica/tuvx/grid_map.hpp b/include/musica/tuvx/grid_map.hpp index b1d95ae0..50686593 100644 --- a/include/musica/tuvx/grid_map.hpp +++ b/include/musica/tuvx/grid_map.hpp @@ -12,9 +12,10 @@ namespace musica { - /// @brief A grid map struct used to access grid information in tuvx - struct GridMap + /// @brief A grid map class used to access grid information in tuvx + class GridMap { + public: GridMap(void *grid_map) : grid_map_(grid_map), owns_grid_map_(false) diff --git a/include/musica/tuvx/profile.hpp b/include/musica/tuvx/profile.hpp index 147d970a..309f9bbc 100644 --- a/include/musica/tuvx/profile.hpp +++ b/include/musica/tuvx/profile.hpp @@ -14,9 +14,10 @@ namespace musica { class ProfileMap; - /// @brief A struct used to interact with TUV-x profiles (properties with values on a grid) - struct Profile + /// @brief A class used to interact with TUV-x profiles (properties with values on a grid) + class Profile { + public: /// @brief Creates a profile instance /// @param profile_name The name of the profile /// @param units The units of the profile diff --git a/include/musica/tuvx/profile_map.hpp b/include/musica/tuvx/profile_map.hpp index 35fc8857..0b5ee6fe 100644 --- a/include/musica/tuvx/profile_map.hpp +++ b/include/musica/tuvx/profile_map.hpp @@ -13,9 +13,10 @@ namespace musica { - /// @brief A struct used to store a collection of profiles - struct ProfileMap + /// @brief A class used to store a collection of profiles + class ProfileMap { + public: ProfileMap(void *profile_map) : profile_map_(profile_map), owns_profile_map_(false) From 2a419e9dc0d1e24f143fb1dfa5f3cf2c921cf98c Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 7 Aug 2024 11:28:16 -0600 Subject: [PATCH 31/31] fix tuvx git tag --- cmake/dependencies.cmake | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index f50decd0..81d930e2 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -75,7 +75,7 @@ if (MUSICA_ENABLE_TUVX AND MUSICA_BUILD_C_CXX_INTERFACE) set(TUVX_INSTALL_INCLUDE_DIR ${MUSICA_INSTALL_INCLUDE_DIR} CACHE STRING "" FORCE) set_git_default(TUVX_GIT_REPOSITORY https://github.com/NCAR/tuv-x.git) - set_git_default(TUVX_GIT_TAG 0e27463) + set_git_default(TUVX_GIT_TAG 674ee1e72853bb44d23c36602fa73c955b2f021d) FetchContent_Declare(tuvx GIT_REPOSITORY ${TUVX_GIT_REPOSITORY}