From 92d7db3fd9d3bcf7174ea3d18882dc8f7c4c5808 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 10 Jul 2024 16:35:27 -0600 Subject: [PATCH] space uniformly --- fortran/micm.F90 | 880 +++++++++--------- .../test_get_micm_version.F90 | 12 +- .../test_micm_box_model.F90 | 96 +- fortran/tuvx/grid.F90 | 412 ++++---- fortran/tuvx/grid_map.F90 | 280 +++--- fortran/tuvx/profile.F90 | 700 +++++++------- fortran/tuvx/profile_map.F90 | 286 +++--- fortran/tuvx/tuvx.F90 | 270 +++--- 8 files changed, 1468 insertions(+), 1468 deletions(-) diff --git a/fortran/micm.F90 b/fortran/micm.F90 index db1ab198..dc35145b 100644 --- a/fortran/micm.F90 +++ b/fortran/micm.F90 @@ -3,448 +3,448 @@ ! module musica_micm #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - use iso_c_binding, only: c_ptr, c_char, c_int, c_int64_t, c_bool, c_double, c_null_char, & - c_size_t, c_f_pointer, c_funptr, c_null_ptr, c_associated - use iso_fortran_env, only: int64 - use musica_util, only: assert, mapping_t, string_t, string_t_c - implicit none - - public :: micm_t, solver_stats_t, get_micm_version - public :: Rosenbrock, RosenbrockStandardOrder - private - - !> Wrapper for c solver stats - type, bind(c) :: solver_stats_t_c - integer(c_int64_t) :: function_calls_ = 0_c_int64_t - integer(c_int64_t) :: jacobian_updates_ = 0_c_int64_t - integer(c_int64_t) :: number_of_steps_ = 0_c_int64_t - integer(c_int64_t) :: accepted_ = 0_c_int64_t - integer(c_int64_t) :: rejected_ = 0_c_int64_t - integer(c_int64_t) :: decompositions_ = 0_c_int64_t - integer(c_int64_t) :: solves_ = 0_c_int64_t - integer(c_int64_t) :: singular_ = 0_c_int64_t - real(c_double) :: final_time_ = 0._c_double - end type solver_stats_t_c - - ! We could use Fortran 2023 enum type feature if Fortran 2023 is supported - ! https://fortran-lang.discourse.group/t/enumerator-type-in-bind-c-derived-type-best-practice/5947/2 - enum, bind(c) - enumerator :: Rosenbrock = 1 - enumerator :: RosenbrockStandardOrder = 2 - end enum - - interface - function create_micm_c(config_path, solver_type, num_grid_cells, error) bind(C, name="CreateMicm") - use musica_util, only: error_t_c - import c_ptr, c_int, c_char - character(kind=c_char), intent(in) :: config_path(*) - integer(kind=c_int), value, intent(in) :: solver_type - integer(kind=c_int), value, intent(in) :: num_grid_cells - type(error_t_c), intent(inout) :: error - type(c_ptr) :: create_micm_c - end function create_micm_c - - subroutine delete_micm_c(micm, error) bind(C, name="DeleteMicm") - use musica_util, only: error_t_c - import c_ptr - type(c_ptr), value, intent(in) :: micm - type(error_t_c), intent(inout) :: error - end subroutine delete_micm_c - - subroutine micm_solve_c(micm, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & - num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) & - bind(C, name="MicmSolve") - use musica_util, only: string_t_c, error_t_c - import c_ptr, c_double, c_int, solver_stats_t_c - type(c_ptr), value, intent(in) :: micm - real(kind=c_double), value, intent(in) :: time_step - real(kind=c_double), value, intent(in) :: temperature - real(kind=c_double), value, intent(in) :: pressure - real(kind=c_double), value, intent(in) :: air_density - integer(kind=c_int), value, intent(in) :: num_concentrations - real(kind=c_double), intent(inout) :: concentrations(num_concentrations) - integer(kind=c_int), value, intent(in) :: num_user_defined_reaction_rates - real(kind=c_double), intent(inout) :: user_defined_reaction_rates(num_user_defined_reaction_rates) - type(string_t_c), intent(out) :: solver_state - type(solver_stats_t_c), intent(out) :: solver_stats - type(error_t_c), intent(inout) :: error - end subroutine micm_solve_c - - function get_micm_version_c() bind(C, name="MicmVersion") - use musica_util, only: string_t_c - type(string_t_c) :: get_micm_version_c - end function get_micm_version_c - - function get_species_property_string_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyString") - use musica_util, only: error_t_c, string_t_c - import c_ptr, c_char - type(c_ptr), value, intent(in) :: micm - character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) - type(error_t_c), intent(inout) :: error - type(string_t_c) :: get_species_property_string_c - end function get_species_property_string_c - - function get_species_property_double_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyDouble") - use musica_util, only: error_t_c - import c_ptr, c_char, c_double - type(c_ptr), value, intent(in) :: micm - character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) - type(error_t_c), intent(inout) :: error - real(kind=c_double) :: get_species_property_double_c - end function get_species_property_double_c - - function get_species_property_int_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyInt") - use musica_util, only: error_t_c - import c_ptr, c_char, c_int - type(c_ptr), value, intent(in) :: micm - character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) - type(error_t_c), intent(inout) :: error - integer(kind=c_int) :: get_species_property_int_c - end function get_species_property_int_c - - function get_species_property_bool_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyBool") - use musica_util, only: error_t_c - import c_ptr, c_char, c_bool - type(c_ptr), value, intent(in) :: micm - character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) - type(error_t_c), intent(inout) :: error - logical(kind=c_bool) :: get_species_property_bool_c - end function get_species_property_bool_c - - type(c_ptr) function get_species_ordering_c(micm, array_size, error) bind(c, name="GetSpeciesOrdering") - use musica_util, only: error_t_c - import c_ptr, c_size_t - type(c_ptr), value, intent(in) :: micm - integer(kind=c_size_t), intent(out) :: array_size - type(error_t_c), intent(inout) :: error - end function get_species_ordering_c - - type(c_ptr) function get_user_defined_reaction_rates_ordering_c(micm, array_size, error) & - bind(c, name="GetUserDefinedReactionRatesOrdering") - use musica_util, only: error_t_c - import c_ptr, c_size_t - type(c_ptr), value, intent(in) :: micm - integer(kind=c_size_t), intent(out) :: array_size - type(error_t_c), intent(inout) :: error - end function get_user_defined_reaction_rates_ordering_c - - subroutine delete_mappings_c(mappings, array_size) bind(C, name="DeleteMappings") - import c_ptr, c_size_t - type(c_ptr), value, intent(in) :: mappings - integer(kind=c_size_t), value, intent(in) :: array_size - end subroutine delete_mappings_c - end interface - - type :: micm_t - type(mapping_t), allocatable :: species_ordering(:) - type(mapping_t), allocatable :: user_defined_reaction_rates(:) - type(c_ptr), private :: ptr = c_null_ptr - contains - ! Solve the chemical system - procedure :: solve - ! Get species properties - procedure :: get_species_property_string - procedure :: get_species_property_double - procedure :: get_species_property_int - procedure :: get_species_property_bool - ! Deallocate the micm instance - final :: finalize - end type micm_t - - interface micm_t - procedure constructor - end interface micm_t - - !> Solver stats type - type :: solver_stats_t - integer(int64) :: function_calls_ - integer(int64) :: jacobian_updates_ - integer(int64) :: number_of_steps_ - integer(int64) :: accepted_ - integer(int64) :: rejected_ - integer(int64) :: decompositions_ - integer(int64) :: solves_ - integer(int64) :: singular_ - real :: final_time_ - contains - procedure :: function_calls => solver_stats_t_function_calls - procedure :: jacobian_updates => solver_stats_t_jacobian_updates - procedure :: number_of_steps => solver_stats_t_number_of_steps - procedure :: accepted => solver_stats_t_accepted - procedure :: rejected => solver_stats_t_rejected - procedure :: decompositions => solver_stats_t_decompositions - procedure :: solves => solver_stats_t_solves - procedure :: singular => solver_stats_t_singular - procedure :: final_time => solver_stats_t_final_time - end type solver_stats_t - - interface solver_stats_t - procedure solver_stats_t_constructor - end interface solver_stats_t + use iso_c_binding, only: c_ptr, c_char, c_int, c_int64_t, c_bool, c_double, c_null_char, & + c_size_t, c_f_pointer, c_funptr, c_null_ptr, c_associated + use iso_fortran_env, only: int64 + use musica_util, only: assert, mapping_t, string_t, string_t_c + implicit none + + public :: micm_t, solver_stats_t, get_micm_version + public :: Rosenbrock, RosenbrockStandardOrder + private + + !> Wrapper for c solver stats + type, bind(c) :: solver_stats_t_c + integer(c_int64_t) :: function_calls_ = 0_c_int64_t + integer(c_int64_t) :: jacobian_updates_ = 0_c_int64_t + integer(c_int64_t) :: number_of_steps_ = 0_c_int64_t + integer(c_int64_t) :: accepted_ = 0_c_int64_t + integer(c_int64_t) :: rejected_ = 0_c_int64_t + integer(c_int64_t) :: decompositions_ = 0_c_int64_t + integer(c_int64_t) :: solves_ = 0_c_int64_t + integer(c_int64_t) :: singular_ = 0_c_int64_t + real(c_double) :: final_time_ = 0._c_double + end type solver_stats_t_c + + ! We could use Fortran 2023 enum type feature if Fortran 2023 is supported + ! https://fortran-lang.discourse.group/t/enumerator-type-in-bind-c-derived-type-best-practice/5947/2 + enum, bind(c) + enumerator :: Rosenbrock = 1 + enumerator :: RosenbrockStandardOrder = 2 + end enum + + interface + function create_micm_c(config_path, solver_type, num_grid_cells, error) bind(C, name="CreateMicm") + use musica_util, only: error_t_c + import c_ptr, c_int, c_char + character(kind=c_char), intent(in) :: config_path(*) + integer(kind=c_int), value, intent(in) :: solver_type + integer(kind=c_int), value, intent(in) :: num_grid_cells + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_micm_c + end function create_micm_c + + subroutine delete_micm_c(micm, error) bind(C, name="DeleteMicm") + use musica_util, only: error_t_c + import c_ptr + type(c_ptr), value, intent(in) :: micm + type(error_t_c), intent(inout) :: error + end subroutine delete_micm_c + + subroutine micm_solve_c(micm, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & + num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) & + bind(C, name="MicmSolve") + use musica_util, only: string_t_c, error_t_c + import c_ptr, c_double, c_int, solver_stats_t_c + type(c_ptr), value, intent(in) :: micm + real(kind=c_double), value, intent(in) :: time_step + real(kind=c_double), value, intent(in) :: temperature + real(kind=c_double), value, intent(in) :: pressure + real(kind=c_double), value, intent(in) :: air_density + integer(kind=c_int), value, intent(in) :: num_concentrations + real(kind=c_double), intent(inout) :: concentrations(num_concentrations) + integer(kind=c_int), value, intent(in) :: num_user_defined_reaction_rates + real(kind=c_double), intent(inout) :: user_defined_reaction_rates(num_user_defined_reaction_rates) + type(string_t_c), intent(out) :: solver_state + type(solver_stats_t_c), intent(out) :: solver_stats + type(error_t_c), intent(inout) :: error + end subroutine micm_solve_c + + function get_micm_version_c() bind(C, name="MicmVersion") + use musica_util, only: string_t_c + type(string_t_c) :: get_micm_version_c + end function get_micm_version_c + + function get_species_property_string_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyString") + use musica_util, only: error_t_c, string_t_c + import c_ptr, c_char + type(c_ptr), value, intent(in) :: micm + character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) + type(error_t_c), intent(inout) :: error + type(string_t_c) :: get_species_property_string_c + end function get_species_property_string_c + + function get_species_property_double_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyDouble") + use musica_util, only: error_t_c + import c_ptr, c_char, c_double + type(c_ptr), value, intent(in) :: micm + character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) + type(error_t_c), intent(inout) :: error + real(kind=c_double) :: get_species_property_double_c + end function get_species_property_double_c + + function get_species_property_int_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyInt") + use musica_util, only: error_t_c + import c_ptr, c_char, c_int + type(c_ptr), value, intent(in) :: micm + character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) + type(error_t_c), intent(inout) :: error + integer(kind=c_int) :: get_species_property_int_c + end function get_species_property_int_c + + function get_species_property_bool_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyBool") + use musica_util, only: error_t_c + import c_ptr, c_char, c_bool + type(c_ptr), value, intent(in) :: micm + character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) + type(error_t_c), intent(inout) :: error + logical(kind=c_bool) :: get_species_property_bool_c + end function get_species_property_bool_c + + type(c_ptr) function get_species_ordering_c(micm, array_size, error) bind(c, name="GetSpeciesOrdering") + use musica_util, only: error_t_c + import c_ptr, c_size_t + type(c_ptr), value, intent(in) :: micm + integer(kind=c_size_t), intent(out) :: array_size + type(error_t_c), intent(inout) :: error + end function get_species_ordering_c + + type(c_ptr) function get_user_defined_reaction_rates_ordering_c(micm, array_size, error) & + bind(c, name="GetUserDefinedReactionRatesOrdering") + use musica_util, only: error_t_c + import c_ptr, c_size_t + type(c_ptr), value, intent(in) :: micm + integer(kind=c_size_t), intent(out) :: array_size + type(error_t_c), intent(inout) :: error + end function get_user_defined_reaction_rates_ordering_c + + subroutine delete_mappings_c(mappings, array_size) bind(C, name="DeleteMappings") + import c_ptr, c_size_t + type(c_ptr), value, intent(in) :: mappings + integer(kind=c_size_t), value, intent(in) :: array_size + end subroutine delete_mappings_c + end interface + + type :: micm_t + type(mapping_t), allocatable :: species_ordering(:) + type(mapping_t), allocatable :: user_defined_reaction_rates(:) + type(c_ptr), private :: ptr = c_null_ptr + contains + ! Solve the chemical system + procedure :: solve + ! Get species properties + procedure :: get_species_property_string + procedure :: get_species_property_double + procedure :: get_species_property_int + procedure :: get_species_property_bool + ! Deallocate the micm instance + final :: finalize + end type micm_t + + interface micm_t + procedure constructor + end interface micm_t + + !> Solver stats type + type :: solver_stats_t + integer(int64) :: function_calls_ + integer(int64) :: jacobian_updates_ + integer(int64) :: number_of_steps_ + integer(int64) :: accepted_ + integer(int64) :: rejected_ + integer(int64) :: decompositions_ + integer(int64) :: solves_ + integer(int64) :: singular_ + real :: final_time_ + contains + procedure :: function_calls => solver_stats_t_function_calls + procedure :: jacobian_updates => solver_stats_t_jacobian_updates + procedure :: number_of_steps => solver_stats_t_number_of_steps + procedure :: accepted => solver_stats_t_accepted + procedure :: rejected => solver_stats_t_rejected + procedure :: decompositions => solver_stats_t_decompositions + procedure :: solves => solver_stats_t_solves + procedure :: singular => solver_stats_t_singular + procedure :: final_time => solver_stats_t_final_time + end type solver_stats_t + + interface solver_stats_t + procedure solver_stats_t_constructor + end interface solver_stats_t contains - function get_micm_version() result(value) - use musica_util, only: string_t, string_t_c - type(string_t) :: value - type(string_t_c) :: string_c - string_c = get_micm_version_c() - value = string_t(string_c) - end function get_micm_version - - function constructor(config_path, solver_type, num_grid_cells, error) result( this ) - use musica_util, only: error_t_c, error_t, copy_mappings - type(micm_t), pointer :: this - character(len=*), intent(in) :: config_path - integer(c_int), intent(in) :: solver_type - integer(c_int), intent(in) :: num_grid_cells - type(error_t), intent(inout) :: error - character(len=1, kind=c_char) :: c_config_path(len_trim(config_path)+1) - integer :: n, i - type(c_ptr) :: mappings_ptr - integer(c_size_t) :: mappings_length - type(error_t_c) :: error_c - - allocate( this ) - - n = len_trim(config_path) - do i = 1, n - c_config_path(i) = config_path(i:i) - end do - c_config_path(n+1) = c_null_char - - this%ptr = create_micm_c(c_config_path, solver_type, num_grid_cells, error_c) - error = error_t(error_c) - if (.not. error%is_success()) then - deallocate(this) - nullify(this) - return - end if - - mappings_ptr = get_species_ordering_c(this%ptr, mappings_length, error_c) - error = error_t(error_c) - if (.not. error%is_success()) then - deallocate(this) - nullify(this) - return - end if - this%species_ordering = copy_mappings(mappings_ptr, mappings_length) - call delete_mappings_c(mappings_ptr, mappings_length) - - mappings_ptr = get_user_defined_reaction_rates_ordering_c(this%ptr, & - mappings_length, error_c) - error = error_t(error_c) - if (.not. error%is_success()) then - deallocate(this) - nullify(this) - return - end if - this%user_defined_reaction_rates = copy_mappings(mappings_ptr, mappings_length) - call delete_mappings_c(mappings_ptr, mappings_length) - - end function constructor - - subroutine solve(this, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & - num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) - use musica_util, only: string_t, string_t_c, error_t_c, error_t - class(micm_t) :: this - real(c_double), intent(in) :: time_step - real(c_double), intent(in) :: temperature - real(c_double), intent(in) :: pressure - real(c_double), intent(in) :: air_density - integer(c_int), intent(in) :: num_concentrations - real(c_double), intent(inout) :: concentrations(*) - integer(c_int), intent(in) :: num_user_defined_reaction_rates - real(c_double), intent(inout) :: user_defined_reaction_rates(*) - type(string_t), intent(out) :: solver_state - type(solver_stats_t), intent(out) :: solver_stats - type(error_t), intent(out) :: error - - type(string_t_c) :: solver_state_c - type(solver_stats_t_c) :: solver_stats_c - type(error_t_c) :: error_c - - call micm_solve_c(this%ptr, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & - num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state_c, solver_stats_c, error_c) - - solver_state = string_t(solver_state_c) - solver_stats = solver_stats_t(solver_stats_c) - error = error_t(error_c) - - end subroutine solve - - !> Constructor for solver_stats_t object that takes ownership of solver_stats_t_c - function solver_stats_t_constructor( c_solver_stats ) result( new_solver_stats ) - use iso_fortran_env, only: int64 - use musica_util, only: string_t - type(solver_stats_t_c), intent(inout) :: c_solver_stats - type(solver_stats_t) :: new_solver_stats - - new_solver_stats%function_calls_ = c_solver_stats%function_calls_ - new_solver_stats%jacobian_updates_ = c_solver_stats%jacobian_updates_ - new_solver_stats%number_of_steps_ = c_solver_stats%number_of_steps_ - new_solver_stats%accepted_ = c_solver_stats%accepted_ - new_solver_stats%rejected_ = c_solver_stats%rejected_ - new_solver_stats%decompositions_ = c_solver_stats%decompositions_ - new_solver_stats%solves_ = c_solver_stats%solves_ - new_solver_stats%singular_ = c_solver_stats%singular_ - new_solver_stats%final_time_ = real( c_solver_stats%final_time_ ) - - end function solver_stats_t_constructor - - !> Get the number of forcing function calls - function solver_stats_t_function_calls( this ) result( function_calls ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: function_calls - - function_calls = this%function_calls_ - - end function solver_stats_t_function_calls - - !> Get the number of jacobian function calls - function solver_stats_t_jacobian_updates( this ) result( jacobian_updates ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: jacobian_updates - - jacobian_updates = this%jacobian_updates_ - - end function solver_stats_t_jacobian_updates - - !> Get the total number of internal time steps taken - function solver_stats_t_number_of_steps( this ) result( number_of_steps ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: number_of_steps - - number_of_steps = this%number_of_steps_ - - end function solver_stats_t_number_of_steps - - !> Get the number of accepted integrations - function solver_stats_t_accepted( this ) result( accepted ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: accepted - - accepted = this%accepted_ - - end function solver_stats_t_accepted - - !> Get the number of rejected integrations - function solver_stats_t_rejected( this ) result( rejected ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: rejected - - rejected = this%rejected_ - - end function solver_stats_t_rejected - - !> Get the number of LU decompositions - function solver_stats_t_decompositions( this ) result( decompositions ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: decompositions - - decompositions = this%decompositions_ - - end function solver_stats_t_decompositions - - !> Get the number of linear solves - function solver_stats_t_solves( this ) result( solves ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: solves - - solves = this%solves_ - - end function solver_stats_t_solves - - !> Get the number of times a singular matrix is detected - function solver_stats_t_singular( this ) result( singular ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: singular - - singular = this%function_calls_ - - end function solver_stats_t_singular - - !> Get the final time the solver iterated to - function solver_stats_t_final_time( this ) result( final_time ) - class(solver_stats_t), intent(in) :: this - real :: final_time - - final_time = this%final_time_ - - end function solver_stats_t_final_time - - function get_species_property_string(this, species_name, property_name, error) result(value) - use musica_util, only: error_t_c, error_t, string_t, string_t_c, to_c_string - class(micm_t), intent(inout) :: this - character(len=*), intent(in) :: species_name, property_name - type(error_t), intent(inout) :: error - type(string_t) :: value - - type(error_t_c) :: error_c - type(string_t_c) :: string_c - string_c = get_species_property_string_c(this%ptr, & - to_c_string(species_name), to_c_string(property_name), error_c) - value = string_t(string_c) - error = error_t(error_c) - end function get_species_property_string - - function get_species_property_double(this, species_name, property_name, error) result(value) - use musica_util, only: error_t_c, error_t, to_c_string - class(micm_t) :: this - character(len=*), intent(in) :: species_name, property_name - type(error_t), intent(inout) :: error - real(c_double) :: value - - type(error_t_c) :: error_c - value = get_species_property_double_c(this%ptr, & - to_c_string(species_name), to_c_string(property_name), error_c) - error = error_t(error_c) - end function get_species_property_double - - function get_species_property_int(this, species_name, property_name, error) result(value) - use musica_util, only: error_t_c, error_t, to_c_string - class(micm_t) :: this - character(len=*), intent(in) :: species_name, property_name - type(error_t), intent(inout) :: error - integer(c_int) :: value - - type(error_t_c) :: error_c - value = get_species_property_int_c(this%ptr, & - to_c_string(species_name), to_c_string(property_name), error_c) - error = error_t(error_c) - end function get_species_property_int - - function get_species_property_bool(this, species_name, property_name, error) result(value) - use musica_util, only: error_t_c, error_t, to_c_string - class(micm_t) :: this - character(len=*), intent(in) :: species_name, property_name - type(error_t), intent(inout) :: error - logical :: value - - type(error_t_c) :: error_c - value = get_species_property_bool_c(this%ptr, & - to_c_string(species_name), to_c_string(property_name), error_c) - error = error_t(error_c) - end function get_species_property_bool - - subroutine finalize(this) - use musica_util, only: error_t, error_t_c - type(micm_t), intent(inout) :: this - - type(error_t_c) :: error_c - type(error_t) :: error - call delete_micm_c(this%ptr, error_c) - this%ptr = c_null_ptr - error = error_t(error_c) - ASSERT(error%is_success()) - end subroutine finalize + function get_micm_version() result(value) + use musica_util, only: string_t, string_t_c + type(string_t) :: value + type(string_t_c) :: string_c + string_c = get_micm_version_c() + value = string_t(string_c) + end function get_micm_version + + function constructor(config_path, solver_type, num_grid_cells, error) result( this ) + use musica_util, only: error_t_c, error_t, copy_mappings + type(micm_t), pointer :: this + character(len=*), intent(in) :: config_path + integer(c_int), intent(in) :: solver_type + integer(c_int), intent(in) :: num_grid_cells + type(error_t), intent(inout) :: error + character(len=1, kind=c_char) :: c_config_path(len_trim(config_path)+1) + integer :: n, i + type(c_ptr) :: mappings_ptr + integer(c_size_t) :: mappings_length + type(error_t_c) :: error_c + + allocate( this ) + + n = len_trim(config_path) + do i = 1, n + c_config_path(i) = config_path(i:i) + end do + c_config_path(n+1) = c_null_char + + this%ptr = create_micm_c(c_config_path, solver_type, num_grid_cells, error_c) + error = error_t(error_c) + if (.not. error%is_success()) then + deallocate(this) + nullify(this) + return + end if + + mappings_ptr = get_species_ordering_c(this%ptr, mappings_length, error_c) + error = error_t(error_c) + if (.not. error%is_success()) then + deallocate(this) + nullify(this) + return + end if + this%species_ordering = copy_mappings(mappings_ptr, mappings_length) + call delete_mappings_c(mappings_ptr, mappings_length) + + mappings_ptr = get_user_defined_reaction_rates_ordering_c(this%ptr, & + mappings_length, error_c) + error = error_t(error_c) + if (.not. error%is_success()) then + deallocate(this) + nullify(this) + return + end if + this%user_defined_reaction_rates = copy_mappings(mappings_ptr, mappings_length) + call delete_mappings_c(mappings_ptr, mappings_length) + + end function constructor + + subroutine solve(this, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & + num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) + use musica_util, only: string_t, string_t_c, error_t_c, error_t + class(micm_t) :: this + real(c_double), intent(in) :: time_step + real(c_double), intent(in) :: temperature + real(c_double), intent(in) :: pressure + real(c_double), intent(in) :: air_density + integer(c_int), intent(in) :: num_concentrations + real(c_double), intent(inout) :: concentrations(*) + integer(c_int), intent(in) :: num_user_defined_reaction_rates + real(c_double), intent(inout) :: user_defined_reaction_rates(*) + type(string_t), intent(out) :: solver_state + type(solver_stats_t), intent(out) :: solver_stats + type(error_t), intent(out) :: error + + type(string_t_c) :: solver_state_c + type(solver_stats_t_c) :: solver_stats_c + type(error_t_c) :: error_c + + call micm_solve_c(this%ptr, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & + num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state_c, solver_stats_c, error_c) + + solver_state = string_t(solver_state_c) + solver_stats = solver_stats_t(solver_stats_c) + error = error_t(error_c) + + end subroutine solve + + !> Constructor for solver_stats_t object that takes ownership of solver_stats_t_c + function solver_stats_t_constructor( c_solver_stats ) result( new_solver_stats ) + use iso_fortran_env, only: int64 + use musica_util, only: string_t + type(solver_stats_t_c), intent(inout) :: c_solver_stats + type(solver_stats_t) :: new_solver_stats + + new_solver_stats%function_calls_ = c_solver_stats%function_calls_ + new_solver_stats%jacobian_updates_ = c_solver_stats%jacobian_updates_ + new_solver_stats%number_of_steps_ = c_solver_stats%number_of_steps_ + new_solver_stats%accepted_ = c_solver_stats%accepted_ + new_solver_stats%rejected_ = c_solver_stats%rejected_ + new_solver_stats%decompositions_ = c_solver_stats%decompositions_ + new_solver_stats%solves_ = c_solver_stats%solves_ + new_solver_stats%singular_ = c_solver_stats%singular_ + new_solver_stats%final_time_ = real( c_solver_stats%final_time_ ) + + end function solver_stats_t_constructor + + !> Get the number of forcing function calls + function solver_stats_t_function_calls( this ) result( function_calls ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: function_calls + + function_calls = this%function_calls_ + + end function solver_stats_t_function_calls + + !> Get the number of jacobian function calls + function solver_stats_t_jacobian_updates( this ) result( jacobian_updates ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: jacobian_updates + + jacobian_updates = this%jacobian_updates_ + + end function solver_stats_t_jacobian_updates + + !> Get the total number of internal time steps taken + function solver_stats_t_number_of_steps( this ) result( number_of_steps ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: number_of_steps + + number_of_steps = this%number_of_steps_ + + end function solver_stats_t_number_of_steps + + !> Get the number of accepted integrations + function solver_stats_t_accepted( this ) result( accepted ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: accepted + + accepted = this%accepted_ + + end function solver_stats_t_accepted + + !> Get the number of rejected integrations + function solver_stats_t_rejected( this ) result( rejected ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: rejected + + rejected = this%rejected_ + + end function solver_stats_t_rejected + + !> Get the number of LU decompositions + function solver_stats_t_decompositions( this ) result( decompositions ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: decompositions + + decompositions = this%decompositions_ + + end function solver_stats_t_decompositions + + !> Get the number of linear solves + function solver_stats_t_solves( this ) result( solves ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: solves + + solves = this%solves_ + + end function solver_stats_t_solves + + !> Get the number of times a singular matrix is detected + function solver_stats_t_singular( this ) result( singular ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: singular + + singular = this%function_calls_ + + end function solver_stats_t_singular + + !> Get the final time the solver iterated to + function solver_stats_t_final_time( this ) result( final_time ) + class(solver_stats_t), intent(in) :: this + real :: final_time + + final_time = this%final_time_ + + end function solver_stats_t_final_time + + function get_species_property_string(this, species_name, property_name, error) result(value) + use musica_util, only: error_t_c, error_t, string_t, string_t_c, to_c_string + class(micm_t), intent(inout) :: this + character(len=*), intent(in) :: species_name, property_name + type(error_t), intent(inout) :: error + type(string_t) :: value + + type(error_t_c) :: error_c + type(string_t_c) :: string_c + string_c = get_species_property_string_c(this%ptr, & + to_c_string(species_name), to_c_string(property_name), error_c) + value = string_t(string_c) + error = error_t(error_c) + end function get_species_property_string + + function get_species_property_double(this, species_name, property_name, error) result(value) + use musica_util, only: error_t_c, error_t, to_c_string + class(micm_t) :: this + character(len=*), intent(in) :: species_name, property_name + type(error_t), intent(inout) :: error + real(c_double) :: value + + type(error_t_c) :: error_c + value = get_species_property_double_c(this%ptr, & + to_c_string(species_name), to_c_string(property_name), error_c) + error = error_t(error_c) + end function get_species_property_double + + function get_species_property_int(this, species_name, property_name, error) result(value) + use musica_util, only: error_t_c, error_t, to_c_string + class(micm_t) :: this + character(len=*), intent(in) :: species_name, property_name + type(error_t), intent(inout) :: error + integer(c_int) :: value + + type(error_t_c) :: error_c + value = get_species_property_int_c(this%ptr, & + to_c_string(species_name), to_c_string(property_name), error_c) + error = error_t(error_c) + end function get_species_property_int + + function get_species_property_bool(this, species_name, property_name, error) result(value) + use musica_util, only: error_t_c, error_t, to_c_string + class(micm_t) :: this + character(len=*), intent(in) :: species_name, property_name + type(error_t), intent(inout) :: error + logical :: value + + type(error_t_c) :: error_c + value = get_species_property_bool_c(this%ptr, & + to_c_string(species_name), to_c_string(property_name), error_c) + error = error_t(error_c) + end function get_species_property_bool + + subroutine finalize(this) + use musica_util, only: error_t, error_t_c + type(micm_t), intent(inout) :: this + + type(error_t_c) :: error_c + type(error_t) :: error + call delete_micm_c(this%ptr, error_c) + this%ptr = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end subroutine finalize end module musica_micm \ No newline at end of file diff --git a/fortran/test/fetch_content_integration/test_get_micm_version.F90 b/fortran/test/fetch_content_integration/test_get_micm_version.F90 index 299411bc..98e30f3e 100644 --- a/fortran/test/fetch_content_integration/test_get_micm_version.F90 +++ b/fortran/test/fetch_content_integration/test_get_micm_version.F90 @@ -1,8 +1,8 @@ program demo - use musica_util, only: string_t - use musica_micm, only: get_micm_version - implicit none - type(string_t) :: micm_version - micm_version = get_micm_version() - print *, "MICM version ", micm_version%get_char_array() + use musica_util, only: string_t + use musica_micm, only: get_micm_version + implicit none + type(string_t) :: micm_version + micm_version = get_micm_version() + print *, "MICM version ", micm_version%get_char_array() end program demo diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index b80a4af1..2af6aae9 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -1,74 +1,74 @@ program test_micm_box_model - use, intrinsic :: iso_c_binding - use, intrinsic :: ieee_arithmetic + use, intrinsic :: iso_c_binding + use, intrinsic :: ieee_arithmetic - use musica_util, only: error_t, string_t, mapping_t - use musica_micm, only: micm_t, solver_stats_t - use musica_micm, only: Rosenbrock, RosenbrockStandardOrder + use musica_util, only: error_t, string_t, mapping_t + use musica_micm, only: micm_t, solver_stats_t + use musica_micm, only: Rosenbrock, RosenbrockStandardOrder - implicit none + implicit none - call box_model() + call box_model() contains - subroutine box_model() + subroutine box_model() - character(len=256) :: config_path - integer(c_int) :: solver_type - integer(c_int) :: num_grid_cells + character(len=256) :: config_path + integer(c_int) :: solver_type + integer(c_int) :: num_grid_cells - real(c_double), parameter :: GAS_CONSTANT = 8.31446261815324_c_double ! J mol-1 K-1 + real(c_double), parameter :: GAS_CONSTANT = 8.31446261815324_c_double ! J mol-1 K-1 - real(c_double) :: time_step - real(c_double) :: temperature - real(c_double) :: pressure - real(c_double) :: air_density + real(c_double) :: time_step + real(c_double) :: temperature + real(c_double) :: pressure + real(c_double) :: air_density - integer(c_int) :: num_concentrations = 3 - real(c_double), dimension(3) :: concentrations + integer(c_int) :: num_concentrations = 3 + real(c_double), dimension(3) :: concentrations - integer(c_int) :: num_user_defined_reaction_rates = 0 - real(c_double), dimension(:), allocatable :: user_defined_reaction_rates + integer(c_int) :: num_user_defined_reaction_rates = 0 + real(c_double), dimension(:), allocatable :: user_defined_reaction_rates - type(string_t) :: solver_state - type(solver_stats_t) :: solver_stats - type(error_t) :: error + type(string_t) :: solver_state + type(solver_stats_t) :: solver_stats + type(error_t) :: error - type(micm_t), pointer :: micm + type(micm_t), pointer :: micm - integer :: i + integer :: i - config_path = "configs/analytical" - solver_type = RosenbrockStandardOrder - num_grid_cells = 1 + config_path = "configs/analytical" + solver_type = RosenbrockStandardOrder + num_grid_cells = 1 - time_step = 200 - temperature = 273.0 - pressure = 1.0e5 - air_density = pressure / (GAS_CONSTANT * temperature) + time_step = 200 + temperature = 273.0 + pressure = 1.0e5 + air_density = pressure / (GAS_CONSTANT * temperature) - concentrations = (/ 1.0, 1.0, 1.0 /) + concentrations = (/ 1.0, 1.0, 1.0 /) - write(*,*) "Creating MICM solver..." - micm => micm_t(config_path, solver_type, num_grid_cells, error) + write(*,*) "Creating MICM solver..." + micm => micm_t(config_path, solver_type, num_grid_cells, error) - do i = 1, size( micm%species_ordering ) - associate(the_mapping => micm%species_ordering(i)) - print *, "Species Name:", the_mapping%name(), ", Index:", the_mapping%index() - end associate - end do + do i = 1, size( micm%species_ordering ) + associate(the_mapping => micm%species_ordering(i)) + print *, "Species Name:", the_mapping%name(), ", Index:", the_mapping%index() + end associate + end do - write(*,*) "Solving starts..." - ! call micm%solve(time_step, temperature, pressure, num_concentrations, concentrations, & - ! num_user_defined_reaction_rates, user_defined_reaction_rates, error) - call micm%solve(time_step, temperature, pressure, air_density, num_concentrations, concentrations, & - num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) - write(*,*) "After solving, concentrations", concentrations + write(*,*) "Solving starts..." + ! call micm%solve(time_step, temperature, pressure, num_concentrations, concentrations, & + ! num_user_defined_reaction_rates, user_defined_reaction_rates, error) + call micm%solve(time_step, temperature, pressure, air_density, num_concentrations, concentrations, & + num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) + write(*,*) "After solving, concentrations", concentrations - deallocate( micm ) + deallocate( micm ) - end subroutine box_model + end subroutine box_model end program test_micm_box_model diff --git a/fortran/tuvx/grid.F90 b/fortran/tuvx/grid.F90 index f53d6190..b0a99a04 100644 --- a/fortran/tuvx/grid.F90 +++ b/fortran/tuvx/grid.F90 @@ -2,255 +2,255 @@ ! SPDX-License-Identifier: Apache-2.0 ! module musica_tuvx_grid - use iso_c_binding, only: c_ptr, c_null_ptr - - implicit none + use iso_c_binding, only: c_ptr, c_null_ptr + + implicit none #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - private - public :: grid_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - interface - function create_grid_c(grid_name, grid_units, number_of_sections, error) & - bind(C, name="CreateGrid") - use iso_c_binding, only : c_ptr, c_size_t, c_char - use musica_util, only: error_t_c - character(len=1, kind=c_char), intent(in) :: grid_name(*) - character(len=1, kind=c_char), intent(in) :: grid_units(*) - integer(c_size_t), value, intent(in) :: number_of_sections - type(error_t_c), intent(inout) :: error - type(c_ptr) :: create_grid_c - end function create_grid_c - - subroutine delete_grid_c(grid, error) bind(C, name="DeleteGrid") - use iso_c_binding, only : c_ptr - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: grid - type(error_t_c), intent(inout) :: error - end subroutine delete_grid_c - - subroutine set_grid_edges_c(grid, edges, n_edges, error) & - bind(C, name="SetGridEdges") - use iso_c_binding, only : c_ptr, c_size_t - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: grid - type(c_ptr), value, intent(in) :: edges - integer(c_size_t), value, intent(in) :: n_edges - type(error_t_c), intent(inout) :: error - end subroutine set_grid_edges_c - - subroutine get_grid_edges_c(grid, edges, n_edges, error) & - bind(C, name="GetGridEdges") - use iso_c_binding, only : c_ptr, c_size_t - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: grid - type(c_ptr), value, intent(in) :: edges - integer(c_size_t), value, intent(in) :: n_edges - type(error_t_c), intent(inout) :: error - end subroutine get_grid_edges_c - - subroutine set_grid_midpoints_c(grid, midpoints, n_midpoints, error) & - bind(C, name="SetGridMidpoints") - use iso_c_binding, only : c_ptr, c_size_t - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: grid - type(c_ptr), value, intent(in) :: midpoints - integer(c_size_t), value, intent(in) :: n_midpoints - type(error_t_c), intent(inout) :: error - end subroutine set_grid_midpoints_c - - subroutine get_grid_midpoints_c(grid, midpoints, n_midpoints, error) & - bind(C, name="GetGridMidpoints") - use iso_c_binding, only : c_ptr, c_size_t - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: grid - type(c_ptr), value, intent(in) :: midpoints - integer(c_size_t), value, intent(in) :: n_midpoints - type(error_t_c), intent(inout) :: error - end subroutine get_grid_midpoints_c - end interface - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: grid_t - type(c_ptr) :: ptr_ = c_null_ptr - contains - ! Set grid edges - procedure :: set_edges - ! Get grid edges - procedure :: get_edges - ! Set the grid edges and midpoints - procedure :: set_midpoints - ! Get the grid midpoints - procedure :: get_midpoints - ! Deallocate the grid instance - final :: finalize_grid_t - end type grid_t - - interface grid_t - procedure grid_t_ptr_constructor - procedure grid_t_constructor - end interface grid_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - + private + public :: grid_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_grid_c(grid_name, grid_units, number_of_sections, error) & + bind(C, name="CreateGrid") + use iso_c_binding, only : c_ptr, c_size_t, c_char + use musica_util, only: error_t_c + character(len=1, kind=c_char), intent(in) :: grid_name(*) + character(len=1, kind=c_char), intent(in) :: grid_units(*) + integer(c_size_t), value, intent(in) :: number_of_sections + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_grid_c + end function create_grid_c + + subroutine delete_grid_c(grid, error) bind(C, name="DeleteGrid") + use iso_c_binding, only : c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid + type(error_t_c), intent(inout) :: error + end subroutine delete_grid_c + + subroutine set_grid_edges_c(grid, edges, n_edges, error) & + bind(C, name="SetGridEdges") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid + type(c_ptr), value, intent(in) :: edges + integer(c_size_t), value, intent(in) :: n_edges + type(error_t_c), intent(inout) :: error + end subroutine set_grid_edges_c + + subroutine get_grid_edges_c(grid, edges, n_edges, error) & + bind(C, name="GetGridEdges") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid + type(c_ptr), value, intent(in) :: edges + integer(c_size_t), value, intent(in) :: n_edges + type(error_t_c), intent(inout) :: error + end subroutine get_grid_edges_c + + subroutine set_grid_midpoints_c(grid, midpoints, n_midpoints, error) & + bind(C, name="SetGridMidpoints") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid + type(c_ptr), value, intent(in) :: midpoints + integer(c_size_t), value, intent(in) :: n_midpoints + type(error_t_c), intent(inout) :: error + end subroutine set_grid_midpoints_c + + subroutine get_grid_midpoints_c(grid, midpoints, n_midpoints, error) & + bind(C, name="GetGridMidpoints") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid + type(c_ptr), value, intent(in) :: midpoints + integer(c_size_t), value, intent(in) :: n_midpoints + type(error_t_c), intent(inout) :: error + end subroutine get_grid_midpoints_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: grid_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Set grid edges + procedure :: set_edges + ! Get grid edges + procedure :: get_edges + ! Set the grid edges and midpoints + procedure :: set_midpoints + ! Get the grid midpoints + procedure :: get_midpoints + ! Deallocate the grid instance + final :: finalize_grid_t + end type grid_t + + interface grid_t + procedure grid_t_ptr_constructor + procedure grid_t_constructor + end interface grid_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + contains - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Constructs a grid instance that wraps an existing TUV-x grid - function grid_t_ptr_constructor(grid_c_ptr) result(this) - ! Arguments - type(c_ptr), intent(in) :: grid_c_ptr + !> Constructs a grid instance that wraps an existing TUV-x grid + function grid_t_ptr_constructor(grid_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: grid_c_ptr - ! Return value - type(grid_t), pointer :: this + ! Return value + type(grid_t), pointer :: this - allocate( this ) - this%ptr_ = grid_c_ptr + allocate( this ) + this%ptr_ = grid_c_ptr - end function grid_t_ptr_constructor + end function grid_t_ptr_constructor - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Constructs a grid instance that allocates a new TUV-x grid - function grid_t_constructor(grid_name, grid_units, number_of_sections, error) & - result(this) - use iso_c_binding, only: c_size_t - use musica_util, only: error_t, error_t_c, to_c_string + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a grid instance that allocates a new TUV-x grid + function grid_t_constructor(grid_name, grid_units, number_of_sections, error) & + result(this) + use iso_c_binding, only: c_size_t + use musica_util, only: error_t, error_t_c, to_c_string - ! Arguments - character(len=*), intent(in) :: grid_name - character(len=*), intent(in) :: grid_units - integer, intent(in) :: number_of_sections - type(error_t), intent(inout) :: error + ! Arguments + character(len=*), intent(in) :: grid_name + character(len=*), intent(in) :: grid_units + integer, intent(in) :: number_of_sections + type(error_t), intent(inout) :: error - ! Return value - type(grid_t), pointer :: this + ! Return value + type(grid_t), pointer :: this - type(error_t_c) :: error_c + type(error_t_c) :: error_c - allocate( this ) - this%ptr_ = create_grid_c(to_c_string(grid_name), to_c_string(grid_units), & - int(number_of_sections, kind=c_size_t), error_c) - error = error_t(error_c) + allocate( this ) + this%ptr_ = create_grid_c(to_c_string(grid_name), to_c_string(grid_units), & + int(number_of_sections, kind=c_size_t), error_c) + error = error_t(error_c) - end function grid_t_constructor - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end function grid_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 + 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(grid_t), intent(inout) :: this - real(dk), target, dimension(:), intent(in) :: edges - type(error_t), intent(inout) :: error + ! Arguments + class(grid_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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edges - n_edges = size(edges) + n_edges = size(edges) - call set_grid_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) - error = error_t(error_c) + call set_grid_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + error = error_t(error_c) - end subroutine set_edges + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + 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(grid_t), intent(inout) :: this - real(dk), target, dimension(:), intent(inout) :: edges - type(error_t), intent(inout) :: error + ! Arguments + class(grid_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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edges - n_edges = size(edges) + n_edges = size(edges) - call get_grid_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) - error = error_t(error_c) + call get_grid_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + error = error_t(error_c) - end subroutine get_edges - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + 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(grid_t), intent(inout) :: this - real(dk), target, dimension(:), intent(in) :: midpoints - type(error_t), intent(inout) :: error + ! Arguments + class(grid_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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoints - n_midpoints = size(midpoints) + n_midpoints = size(midpoints) - call set_grid_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) - error = error_t(error_c) + call set_grid_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + error = error_t(error_c) - end subroutine set_midpoints + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + 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(grid_t), intent(inout) :: this - real(dk), target, dimension(:), intent(inout) :: midpoints - type(error_t), intent(inout) :: error + ! Arguments + class(grid_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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoints - n_midpoints = size(midpoints) + n_midpoints = size(midpoints) - call get_grid_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) - error = error_t(error_c) + call get_grid_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + error = error_t(error_c) - end subroutine get_midpoints - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end subroutine get_midpoints + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Deallocate the grid instance - subroutine finalize_grid_t(this) - use iso_c_binding, only: c_associated - use musica_util, only: error_t, error_t_c, assert + !> Deallocate the grid instance + subroutine finalize_grid_t(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert - ! Arguments - type(grid_t), intent(inout) :: this + ! Arguments + type(grid_t), intent(inout) :: this - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error - if (c_associated(this%ptr_)) then - call delete_grid_c(this%ptr_, error_c) - this%ptr_ = c_null_ptr - error = error_t(error_c) - ASSERT(error%is_success()) - end if + if (c_associated(this%ptr_)) then + call delete_grid_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end if - end subroutine finalize_grid_t + end subroutine finalize_grid_t - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -end module musica_tuvx_grid +end module musica_tuvx_grid \ No newline at end of file diff --git a/fortran/tuvx/grid_map.F90 b/fortran/tuvx/grid_map.F90 index c0d5e33f..2b79410c 100644 --- a/fortran/tuvx/grid_map.F90 +++ b/fortran/tuvx/grid_map.F90 @@ -2,178 +2,178 @@ ! SPDX-License-Identifier: Apache-2.0 ! module musica_tuvx_grid_map - use iso_c_binding, only: c_ptr, c_null_ptr + use iso_c_binding, only: c_ptr, c_null_ptr - implicit none + implicit none #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - private - public :: grid_map_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - interface - function create_grid_map_c(error) bind(C, name="CreateGridMap") - 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_grid_map_c - end function create_grid_map_c - - subroutine delete_grid_map_c(grid_map, error) bind(C, name="DeleteGridMap") - use iso_c_binding, only: c_ptr - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: grid_map - type(error_t_c), intent(inout) :: error - end subroutine delete_grid_map_c - - subroutine add_grid_c(grid_map, grid, error) bind(C, name="AddGrid") - use iso_c_binding, only: c_ptr - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: grid_map - type(c_ptr), value, intent(in) :: grid - type(error_t_c), intent(inout) :: error - end subroutine add_grid_c - - function get_grid_c(grid_map, grid_name, grid_units, error) & - bind(C, name="GetGrid") - use musica_util, only: error_t_c - use iso_c_binding, only: c_ptr, c_char - type(c_ptr), value, intent(in) :: grid_map - character(len=1, kind=c_char), intent(in) :: grid_name(*), grid_units(*) - type(error_t_c), intent(inout) :: error - type(c_ptr) :: get_grid_c - end function get_grid_c - end interface - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: grid_map_t - type(c_ptr) :: ptr_ = c_null_ptr - contains - ! Adds a grid to the grid map - procedure :: add => add_grid - ! Get a grid given its name and units - procedure :: get => get_grid - ! Deallocate the grid map instance - final :: finalize_grid_map_t - end type grid_map_t - - interface grid_map_t - procedure grid_map_t_ptr_constructor - procedure grid_map_t_constructor - end interface grid_map_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + private + public :: grid_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_grid_map_c(error) bind(C, name="CreateGridMap") + 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_grid_map_c + end function create_grid_map_c + + subroutine delete_grid_map_c(grid_map, error) bind(C, name="DeleteGridMap") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid_map + type(error_t_c), intent(inout) :: error + end subroutine delete_grid_map_c + + subroutine add_grid_c(grid_map, grid, error) bind(C, name="AddGrid") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid_map + type(c_ptr), value, intent(in) :: grid + type(error_t_c), intent(inout) :: error + end subroutine add_grid_c + + function get_grid_c(grid_map, grid_name, grid_units, error) & + bind(C, name="GetGrid") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr, c_char + type(c_ptr), value, intent(in) :: grid_map + character(len=1, kind=c_char), intent(in) :: grid_name(*), grid_units(*) + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_grid_c + end function get_grid_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: grid_map_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Adds a grid to the grid map + procedure :: add => add_grid + ! Get a grid given its name and units + procedure :: get => get_grid + ! Deallocate the grid map instance + final :: finalize_grid_map_t + end type grid_map_t + + interface grid_map_t + procedure grid_map_t_ptr_constructor + procedure grid_map_t_constructor + end interface grid_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! contains - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Wraps an existing grid map - function grid_map_t_ptr_constructor(grid_map_c_ptr) result(this) - ! Arguments - type(c_ptr), intent(in) :: grid_map_c_ptr - ! Return value - type(grid_map_t), pointer :: this + !> Wraps an existing grid map + function grid_map_t_ptr_constructor(grid_map_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: grid_map_c_ptr + ! Return value + type(grid_map_t), pointer :: this - allocate( this ) - this%ptr_ = grid_map_c_ptr + allocate( this ) + this%ptr_ = grid_map_c_ptr - end function grid_map_t_ptr_constructor + end function grid_map_t_ptr_constructor - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Creates a new grid map - function grid_map_t_constructor(error) result(this) - use musica_util, only: error_t, error_t_c, assert + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Creates a new grid map + function grid_map_t_constructor(error) result(this) + use musica_util, only: error_t, error_t_c, assert - ! Arguments - type(error_t), intent(inout) :: error + ! Arguments + type(error_t), intent(inout) :: error - ! Return value - type(grid_map_t), pointer :: this + ! Return value + type(grid_map_t), pointer :: this - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - allocate( this ) - this%ptr_ = create_grid_map_c(error_c) - error = error_t(error_c) + allocate( this ) + this%ptr_ = create_grid_map_c(error_c) + error = error_t(error_c) - end function grid_map_t_constructor - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Adds a grid to a grid map - subroutine add_grid(this, grid, error) - use musica_tuvx_grid, only: grid_t - use musica_util, only: error_t, error_t_c, assert + end function grid_map_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a grid to a grid map + subroutine add_grid(this, grid, error) + use musica_tuvx_grid, only: grid_t + use musica_util, only: error_t, error_t_c, assert - ! Arguments - class(grid_map_t), intent(inout) :: this - type(grid_t), intent(in) :: grid - type(error_t), intent(inout) :: error + ! Arguments + class(grid_map_t), intent(inout) :: this + type(grid_t), intent(in) :: grid + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - call add_grid_c(this%ptr_, grid%ptr_, error_c) - error = error_t(error_c) - - end subroutine add_grid - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call add_grid_c(this%ptr_, grid%ptr_, error_c) + error = error_t(error_c) + + end subroutine add_grid + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Gets a grid given its name and units - function get_grid(this, grid_name, grid_units, error) result(grid) - use iso_c_binding, only: c_char - use musica_tuvx_grid, only : grid_t - use musica_util, only: error_t, error_t_c, to_c_string + !> Gets a grid given its name and units + function get_grid(this, grid_name, grid_units, error) result(grid) + use iso_c_binding, only: c_char + use musica_tuvx_grid, only : grid_t + use musica_util, only: error_t, error_t_c, to_c_string - ! Arguments - class(grid_map_t), intent(in) :: this - character(len=*), intent(in) :: grid_name - character(len=*), intent(in) :: grid_units - type(error_t), intent(inout) :: error + ! Arguments + class(grid_map_t), intent(in) :: this + character(len=*), intent(in) :: grid_name + character(len=*), intent(in) :: grid_units + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - ! Return value - type(grid_t), pointer :: grid + ! Return value + type(grid_t), pointer :: grid - grid => grid_t(get_grid_c(this%ptr_, to_c_string(grid_name), & - to_c_string(grid_units), error_c)) + grid => grid_t(get_grid_c(this%ptr_, to_c_string(grid_name), & + to_c_string(grid_units), error_c)) - error = error_t(error_c) + error = error_t(error_c) - end function get_grid + end function get_grid - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Deallocates the grid map instance - subroutine finalize_grid_map_t(this) - use iso_c_binding, only: c_associated - use musica_util, only: error_t, error_t_c, assert + !> Deallocates the grid map instance + subroutine finalize_grid_map_t(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert - ! Arguments - type(grid_map_t), intent(inout) :: this + ! Arguments + type(grid_map_t), intent(inout) :: this - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error - if (c_associated(this%ptr_)) then - call delete_grid_map_c(this%ptr_, error_c) - this%ptr_ = c_null_ptr - error = error_t(error_c) - ASSERT(error%is_success()) - end if + if (c_associated(this%ptr_)) then + call delete_grid_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_grid_map_t + end subroutine finalize_grid_map_t - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module musica_tuvx_grid_map diff --git a/fortran/tuvx/profile.F90 b/fortran/tuvx/profile.F90 index a8348fb8..68c8bd6a 100644 --- a/fortran/tuvx/profile.F90 +++ b/fortran/tuvx/profile.F90 @@ -2,425 +2,425 @@ ! SPDX-License-Identifier: Apache-2.0 ! module musica_tuvx_profile - use iso_c_binding, only: c_ptr, c_null_ptr + use iso_c_binding, only: c_ptr, c_null_ptr - implicit none + implicit none #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - private - public :: profile_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - 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 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(*) - type(c_ptr), value, intent(in) :: grid - type(error_t_c), intent(inout) :: error - type(c_ptr) :: create_profile_c - end function create_profile_c - - subroutine delete_profile_c(profile, error) bind(C, name="DeleteProfile") - use iso_c_binding, only: c_ptr - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile - type(error_t_c), intent(inout) :: error - end subroutine delete_profile_c - - subroutine set_profile_edge_values_c(profile, edge_values, n_edge_values, & - error) bind(C, name="SetProfileEdgeValues") - use iso_c_binding, only: c_ptr, c_size_t - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile - type(c_ptr), value, intent(in) :: edge_values - integer(c_size_t), value, intent(in) :: n_edge_values - type(error_t_c), intent(inout) :: error - end subroutine set_profile_edge_values_c - - subroutine get_profile_edge_values_c(profile, edge_values, n_edge_values, & - error) bind(C, name="GetProfileEdgeValues") - use iso_c_binding, only: c_ptr, c_size_t - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile - type(c_ptr), value, intent(in) :: edge_values - integer(c_size_t), value, intent(in) :: n_edge_values - type(error_t_c), intent(inout) :: error - end subroutine get_profile_edge_values_c - - subroutine set_profile_midpoint_values_c(profile, midpoint_values, & - n_midpoint_values, error) bind(C, name="SetProfileMidpointValues") - use iso_c_binding, only: c_ptr, c_size_t - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile - type(c_ptr), value, intent(in) :: midpoint_values - integer(c_size_t), value, intent(in) :: n_midpoint_values - type(error_t_c), intent(inout) :: error - end subroutine set_profile_midpoint_values_c - - subroutine get_profile_midpoint_values_c(profile, midpoint_values, & - n_midpoint_values, error) bind(C, name="GetProfileMidpointValues") - use iso_c_binding, only: c_ptr, c_size_t - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile - type(c_ptr), value, intent(in) :: midpoint_values - integer(c_size_t), value, intent(in) :: n_midpoint_values - type(error_t_c), intent(inout) :: error - end subroutine get_profile_midpoint_values_c - - subroutine set_profile_layer_densities_c(profile, layer_densities, & - n_layer_densities, error) bind(C, name="SetProfileLayerDensities") - use iso_c_binding, only: c_ptr, c_size_t - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile - type(c_ptr), value, intent(in) :: layer_densities - integer(c_size_t), value, intent(in) :: n_layer_densities - type(error_t_c), intent(inout) :: error - end subroutine set_profile_layer_densities_c - - subroutine get_profile_layer_densities_c(profile, layer_densities, & - n_layer_densities, error) bind(C, name="GetProfileLayerDensities") - use iso_c_binding, only: c_ptr, c_size_t - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile - type(c_ptr), value, intent(in) :: layer_densities - integer(c_size_t), value, intent(in) :: n_layer_densities - type(error_t_c), intent(inout) :: error - end subroutine get_profile_layer_densities_c - - subroutine set_profile_exo_layer_density_c(profile, exo_layer_density, & - error) bind(C, name="SetProfileExoLayerDensity") - use iso_c_binding, only: c_ptr, c_double - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile - real(c_double), value, intent(in) :: exo_layer_density - type(error_t_c), intent(inout) :: error - end subroutine set_profile_exo_layer_density_c - - subroutine calculate_profile_exo_layer_density(profile, scale_height, & - error) bind(C, name="CalculateProfileExoLayerDensity") - use iso_c_binding, only: c_ptr, c_double - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile - real(c_double), value, intent(in) :: scale_height - type(error_t_c), intent(inout) :: error - end subroutine calculate_profile_exo_layer_density - - function get_profile_exo_layer_density_c(profile, error) & - bind(C, name="GetProfileExoLayerDensity") - use iso_c_binding, only: c_ptr, c_double - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile - type(error_t_c), intent(inout) :: error - real(c_double) :: get_profile_exo_layer_density_c - end function get_profile_exo_layer_density_c - end interface - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: profile_t - type(c_ptr) :: ptr_ = c_null_ptr - contains - ! Set profile edge values - procedure :: set_edge_values - ! Get profile edge values - procedure :: get_edge_values - ! Set the profile midpoint values - procedure :: set_midpoint_values - ! Get the profile midpoint values - procedure :: get_midpoint_values - ! Set the profile layer densities - procedure :: set_layer_densities - ! Get the profile layer densities - procedure :: get_layer_densities - ! Set the profile exo layer density - procedure :: set_exo_layer_density - ! Calculate the profile exo layer density - procedure :: calculate_exo_layer_density - ! Get the profile exo layer density - procedure :: get_exo_layer_density - ! Finalize the profile - final :: finalize_profile - end type profile_t - - interface profile_t - procedure profile_t_ptr_constructor - procedure profile_t_constructor - end interface profile_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + private + public :: profile_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + 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 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(*) + type(c_ptr), value, intent(in) :: grid + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_profile_c + end function create_profile_c + + subroutine delete_profile_c(profile, error) bind(C, name="DeleteProfile") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(error_t_c), intent(inout) :: error + end subroutine delete_profile_c + + subroutine set_profile_edge_values_c(profile, edge_values, n_edge_values, & + error) bind(C, name="SetProfileEdgeValues") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: edge_values + integer(c_size_t), value, intent(in) :: n_edge_values + type(error_t_c), intent(inout) :: error + end subroutine set_profile_edge_values_c + + subroutine get_profile_edge_values_c(profile, edge_values, n_edge_values, & + error) bind(C, name="GetProfileEdgeValues") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: edge_values + integer(c_size_t), value, intent(in) :: n_edge_values + type(error_t_c), intent(inout) :: error + end subroutine get_profile_edge_values_c + + subroutine set_profile_midpoint_values_c(profile, midpoint_values, & + n_midpoint_values, error) bind(C, name="SetProfileMidpointValues") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: midpoint_values + integer(c_size_t), value, intent(in) :: n_midpoint_values + type(error_t_c), intent(inout) :: error + end subroutine set_profile_midpoint_values_c + + subroutine get_profile_midpoint_values_c(profile, midpoint_values, & + n_midpoint_values, error) bind(C, name="GetProfileMidpointValues") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: midpoint_values + integer(c_size_t), value, intent(in) :: n_midpoint_values + type(error_t_c), intent(inout) :: error + end subroutine get_profile_midpoint_values_c + + subroutine set_profile_layer_densities_c(profile, layer_densities, & + n_layer_densities, error) bind(C, name="SetProfileLayerDensities") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: layer_densities + integer(c_size_t), value, intent(in) :: n_layer_densities + type(error_t_c), intent(inout) :: error + end subroutine set_profile_layer_densities_c + + subroutine get_profile_layer_densities_c(profile, layer_densities, & + n_layer_densities, error) bind(C, name="GetProfileLayerDensities") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: layer_densities + integer(c_size_t), value, intent(in) :: n_layer_densities + type(error_t_c), intent(inout) :: error + end subroutine get_profile_layer_densities_c + + subroutine set_profile_exo_layer_density_c(profile, exo_layer_density, & + error) bind(C, name="SetProfileExoLayerDensity") + use iso_c_binding, only: c_ptr, c_double + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + real(c_double), value, intent(in) :: exo_layer_density + type(error_t_c), intent(inout) :: error + end subroutine set_profile_exo_layer_density_c + + subroutine calculate_profile_exo_layer_density(profile, scale_height, & + error) bind(C, name="CalculateProfileExoLayerDensity") + use iso_c_binding, only: c_ptr, c_double + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + real(c_double), value, intent(in) :: scale_height + type(error_t_c), intent(inout) :: error + end subroutine calculate_profile_exo_layer_density + + function get_profile_exo_layer_density_c(profile, error) & + bind(C, name="GetProfileExoLayerDensity") + use iso_c_binding, only: c_ptr, c_double + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(error_t_c), intent(inout) :: error + real(c_double) :: get_profile_exo_layer_density_c + end function get_profile_exo_layer_density_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: profile_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Set profile edge values + procedure :: set_edge_values + ! Get profile edge values + procedure :: get_edge_values + ! Set the profile midpoint values + procedure :: set_midpoint_values + ! Get the profile midpoint values + procedure :: get_midpoint_values + ! Set the profile layer densities + procedure :: set_layer_densities + ! Get the profile layer densities + procedure :: get_layer_densities + ! Set the profile exo layer density + procedure :: set_exo_layer_density + ! Calculate the profile exo layer density + procedure :: calculate_exo_layer_density + ! Get the profile exo layer density + procedure :: get_exo_layer_density + ! Finalize the profile + final :: finalize_profile + end type profile_t + + interface profile_t + procedure profile_t_ptr_constructor + procedure profile_t_constructor + end interface profile_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! contains - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Construct a profile instance - function profile_t_ptr_constructor(profile_c_ptr) result(this) - ! Arguments - type(c_ptr), intent(in) :: profile_c_ptr + !> Construct a profile instance + function profile_t_ptr_constructor(profile_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: profile_c_ptr - ! Return value - type(profile_t), pointer :: this + ! Return value + type(profile_t), pointer :: this - allocate( this ) - this%ptr_ = profile_c_ptr + allocate( this ) + this%ptr_ = profile_c_ptr - end function profile_t_ptr_constructor + end function profile_t_ptr_constructor - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Construct a profile instance that allocates a new TUV-x profile - function profile_t_constructor(profile_name, profile_units, grid, error) & - result(this) - use musica_tuvx_grid, only: grid_t - use musica_util, only: error_t, error_t_c, to_c_string + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Construct a profile instance that allocates a new TUV-x profile + function profile_t_constructor(profile_name, profile_units, 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) :: profile_name - character(len=*), intent(in) :: profile_units - type(grid_t), intent(in) :: grid - type(error_t), intent(inout) :: error + ! Arguments + character(len=*), intent(in) :: profile_name + character(len=*), intent(in) :: profile_units + type(grid_t), intent(in) :: grid + type(error_t), intent(inout) :: error - ! Return value - type(profile_t), pointer :: this + ! Return value + type(profile_t), pointer :: this - ! Local variables - type(error_t_c) :: error_c - - allocate( this ) - this%ptr_ = create_profile_c(to_c_string(profile_name), & - to_c_string(profile_units), grid%ptr_, error_c) - error = error_t(error_c) + ! Local variables + type(error_t_c) :: error_c + + allocate( this ) + this%ptr_ = create_profile_c(to_c_string(profile_name), & + to_c_string(profile_units), grid%ptr_, error_c) + error = error_t(error_c) - end function profile_t_constructor - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end function profile_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine set_edge_values(this, edge_values, error) - use iso_c_binding, only: c_size_t, c_loc - use musica_util, only: error_t, error_t_c, dk => musica_dk + subroutine set_edge_values(this, edge_values, 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(profile_t), intent(inout) :: this - real(dk), target, dimension(:), intent(in) :: edge_values - type(error_t), intent(inout) :: error + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(in) :: edge_values + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_edge_values + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edge_values - n_edge_values = size(edge_values) + n_edge_values = size(edge_values) - call set_profile_edge_values_c(this%ptr_, c_loc(edge_values), & - n_edge_values, error_c) - error = error_t(error_c) + call set_profile_edge_values_c(this%ptr_, c_loc(edge_values), & + n_edge_values, error_c) + error = error_t(error_c) - end subroutine set_edge_values + end subroutine set_edge_values - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine get_edge_values(this, edge_values, error) - use iso_c_binding, only: c_size_t, c_loc - use musica_util, only: error_t, error_t_c, dk => musica_dk + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_edge_values(this, edge_values, 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(profile_t), intent(inout) :: this - real(dk), target, dimension(:), intent(inout) :: edge_values - type(error_t), intent(inout) :: error + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(inout) :: edge_values + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_edge_values + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edge_values - n_edge_values = size(edge_values) + n_edge_values = size(edge_values) - call get_profile_edge_values_c(this%ptr_, c_loc(edge_values), & - n_edge_values, error_c) - error = error_t(error_c) + call get_profile_edge_values_c(this%ptr_, c_loc(edge_values), & + n_edge_values, error_c) + error = error_t(error_c) - end subroutine get_edge_values - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end subroutine get_edge_values + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine set_midpoint_values(this, midpoint_values, error) - use iso_c_binding, only: c_size_t, c_loc - use musica_util, only: error_t, error_t_c, dk => musica_dk + subroutine set_midpoint_values(this, midpoint_values, 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(profile_t), intent(inout) :: this - real(dk), target, dimension(:), intent(in) :: midpoint_values - type(error_t), intent(inout) :: error + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(in) :: midpoint_values + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_midpoint_values + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoint_values - n_midpoint_values = size(midpoint_values) + n_midpoint_values = size(midpoint_values) - call set_profile_midpoint_values_c(this%ptr_, c_loc(midpoint_values), & - n_midpoint_values, error_c) - error = error_t(error_c) + call set_profile_midpoint_values_c(this%ptr_, c_loc(midpoint_values), & + n_midpoint_values, error_c) + error = error_t(error_c) - end subroutine set_midpoint_values + end subroutine set_midpoint_values - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine get_midpoint_values(this, midpoint_values, error) - use iso_c_binding, only: c_size_t, c_loc - use musica_util, only: error_t, error_t_c, dk => musica_dk + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_midpoint_values(this, midpoint_values, 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(profile_t), intent(inout) :: this - real(dk), target, dimension(:), intent(inout) :: midpoint_values - type(error_t), intent(inout) :: error + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(inout) :: midpoint_values + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_midpoint_values + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoint_values - n_midpoint_values = size(midpoint_values) + n_midpoint_values = size(midpoint_values) - call get_profile_midpoint_values_c(this%ptr_, c_loc(midpoint_values), & - n_midpoint_values, error_c) - error = error_t(error_c) + call get_profile_midpoint_values_c(this%ptr_, c_loc(midpoint_values), & + n_midpoint_values, error_c) + error = error_t(error_c) - end subroutine get_midpoint_values - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end subroutine get_midpoint_values + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine set_layer_densities(this, layer_densities, error) - use iso_c_binding, only: c_size_t, c_loc - use musica_util, only: error_t, error_t_c, dk => musica_dk + subroutine set_layer_densities(this, layer_densities, 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(profile_t), intent(inout) :: this - real(dk), target, dimension(:), intent(in) :: layer_densities - type(error_t), intent(inout) :: error + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(in) :: layer_densities + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_layer_densities + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_layer_densities - n_layer_densities = size(layer_densities) + n_layer_densities = size(layer_densities) - call set_profile_layer_densities_c(this%ptr_, c_loc(layer_densities), & - n_layer_densities, error_c) - error = error_t(error_c) + call set_profile_layer_densities_c(this%ptr_, c_loc(layer_densities), & + n_layer_densities, error_c) + error = error_t(error_c) - end subroutine set_layer_densities + end subroutine set_layer_densities - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine get_layer_densities(this, layer_densities, error) - use iso_c_binding, only: c_size_t, c_loc - use musica_util, only: error_t, error_t_c, dk => musica_dk + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_layer_densities(this, layer_densities, 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(profile_t), intent(inout) :: this - real(dk), target, dimension(:), intent(inout) :: layer_densities - type(error_t), intent(inout) :: error + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(inout) :: layer_densities + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_layer_densities + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_layer_densities - n_layer_densities = size(layer_densities) + n_layer_densities = size(layer_densities) - call get_profile_layer_densities_c(this%ptr_, c_loc(layer_densities), & - n_layer_densities, error_c) - error = error_t(error_c) + call get_profile_layer_densities_c(this%ptr_, c_loc(layer_densities), & + n_layer_densities, error_c) + error = error_t(error_c) - end subroutine get_layer_densities - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end subroutine get_layer_densities + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine set_exo_layer_density(this, exo_layer_density, error) - use iso_c_binding, only: c_double, c_size_t - use musica_util, only: error_t, error_t_c, dk => musica_dk + subroutine set_exo_layer_density(this, exo_layer_density, error) + use iso_c_binding, only: c_double, c_size_t + use musica_util, only: error_t, error_t_c, dk => musica_dk - ! Arguments - class(profile_t), intent(inout) :: this - real(dk), intent(in) :: exo_layer_density - type(error_t), intent(inout) :: error + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), intent(in) :: exo_layer_density + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - call set_profile_exo_layer_density_c(this%ptr_, & - real(exo_layer_density, kind=c_double), error_c) - error = error_t(error_c) + call set_profile_exo_layer_density_c(this%ptr_, & + real(exo_layer_density, kind=c_double), error_c) + error = error_t(error_c) - end subroutine set_exo_layer_density + end subroutine set_exo_layer_density - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine calculate_exo_layer_density(this, scale_height, error) - use iso_c_binding, only: c_double, c_size_t - use musica_util, only: error_t, error_t_c, dk => musica_dk + subroutine calculate_exo_layer_density(this, scale_height, error) + use iso_c_binding, only: c_double, c_size_t + use musica_util, only: error_t, error_t_c, dk => musica_dk - ! Arguments - class(profile_t), intent(inout) :: this - real(dk), intent(in) :: scale_height - type(error_t), intent(inout) :: error + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), intent(in) :: scale_height + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - call calculate_profile_exo_layer_density(this%ptr_, & - real(scale_height, kind=dk), error_c) - error = error_t(error_c) + call calculate_profile_exo_layer_density(this%ptr_, & + real(scale_height, kind=dk), error_c) + error = error_t(error_c) + + end subroutine calculate_exo_layer_density + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function get_exo_layer_density(this, error) result(exo_layer_density) + use iso_c_binding, only: c_size_t + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(profile_t), intent(inout) :: this + type(error_t), intent(inout) :: error + + ! Return value + real(dk) :: exo_layer_density - end subroutine calculate_exo_layer_density + ! Local variables + type(error_t_c) :: error_c - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - function get_exo_layer_density(this, error) result(exo_layer_density) - use iso_c_binding, only: c_size_t - use musica_util, only: error_t, error_t_c, dk => musica_dk + exo_layer_density = & + real(get_profile_exo_layer_density_c(this%ptr_, error_c), kind=dk) + error = error_t(error_c) - ! Arguments - class(profile_t), intent(inout) :: this - type(error_t), intent(inout) :: error + end function get_exo_layer_density + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Deallocate the profile instance + subroutine finalize_profile(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert - ! Return value - real(dk) :: exo_layer_density + ! Arguments + type(profile_t), intent(inout) :: this - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error - exo_layer_density = & - real(get_profile_exo_layer_density_c(this%ptr_, error_c), kind=dk) + if (c_associated(this%ptr_)) then + call delete_profile_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr error = error_t(error_c) + ASSERT(error%is_success()) + end if - end function get_exo_layer_density - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Deallocate the profile instance - subroutine finalize_profile(this) - use iso_c_binding, only: c_associated - use musica_util, only: error_t, error_t_c, assert - - ! Arguments - type(profile_t), intent(inout) :: this - - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error - - if (c_associated(this%ptr_)) then - call delete_profile_c(this%ptr_, error_c) - this%ptr_ = c_null_ptr - error = error_t(error_c) - ASSERT(error%is_success()) - end if - - end subroutine finalize_profile - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end subroutine finalize_profile + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module musica_tuvx_profile diff --git a/fortran/tuvx/profile_map.F90 b/fortran/tuvx/profile_map.F90 index 707633fe..53fd7072 100644 --- a/fortran/tuvx/profile_map.F90 +++ b/fortran/tuvx/profile_map.F90 @@ -2,181 +2,181 @@ ! SPDX-License-Identifier: Apache-2.0 ! module musica_tuvx_profile_map - use iso_c_binding, only: c_ptr, c_null_ptr + use iso_c_binding, only: c_ptr, c_null_ptr - implicit none + implicit none #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - private - public :: profile_map_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - interface - function create_profile_map_c(error) bind(C, name="CreateProfileMap") - 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_profile_map_c - end function create_profile_map_c - - subroutine delete_profile_map_c(profile_map, error) & - bind(C, name="DeleteProfileMap") - use iso_c_binding, only: c_ptr - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile_map - type(error_t_c), intent(inout) :: error - end subroutine delete_profile_map_c - - subroutine add_profile_c(profile_map, profile, error) & - bind(C, name="AddProfile") - use iso_c_binding, only: c_ptr - use musica_util, only: error_t_c - type(c_ptr), value, intent(in) :: profile_map - type(c_ptr), value, intent(in) :: profile - type(error_t_c), intent(inout) :: error - end subroutine add_profile_c - - function get_profile_c(profile_map, profile_name, profile_units, error) & - bind(C, name="GetProfile") - use musica_util, only: error_t_c - use iso_c_binding, only: c_ptr, c_char - type(c_ptr), value, intent(in) :: profile_map - character(len=1, kind=c_char), intent(in) :: profile_name(*), & - profile_units(*) - type(error_t_c), intent(inout) :: error - type(c_ptr) :: get_profile_c - end function get_profile_c - end interface - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: profile_map_t - type(c_ptr) :: ptr_ = c_null_ptr - contains - ! Adds a profile to the profile map - procedure :: add => add_profile - ! Get a profile given its name and units - procedure :: get => get_profile - ! Deallocate the profile map instance - final :: finalize_profile_map_t - end type profile_map_t - - interface profile_map_t - procedure profile_map_t_ptr_constructor - procedure profile_map_t_constructor - end interface profile_map_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + private + public :: profile_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_profile_map_c(error) bind(C, name="CreateProfileMap") + 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_profile_map_c + end function create_profile_map_c + + subroutine delete_profile_map_c(profile_map, error) & + bind(C, name="DeleteProfileMap") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile_map + type(error_t_c), intent(inout) :: error + end subroutine delete_profile_map_c + + subroutine add_profile_c(profile_map, profile, error) & + bind(C, name="AddProfile") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile_map + type(c_ptr), value, intent(in) :: profile + type(error_t_c), intent(inout) :: error + end subroutine add_profile_c + + function get_profile_c(profile_map, profile_name, profile_units, error) & + bind(C, name="GetProfile") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr, c_char + type(c_ptr), value, intent(in) :: profile_map + character(len=1, kind=c_char), intent(in) :: profile_name(*), & + profile_units(*) + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_profile_c + end function get_profile_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: profile_map_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Adds a profile to the profile map + procedure :: add => add_profile + ! Get a profile given its name and units + procedure :: get => get_profile + ! Deallocate the profile map instance + final :: finalize_profile_map_t + end type profile_map_t + + interface profile_map_t + procedure profile_map_t_ptr_constructor + procedure profile_map_t_constructor + end interface profile_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! contains - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Construct a profile map instance - function profile_map_t_ptr_constructor(profile_map_c_ptr) result(this) - ! Arguments - type(c_ptr), intent(in) :: profile_map_c_ptr - ! Return value - type(profile_map_t), pointer :: this + !> Construct a profile map instance + function profile_map_t_ptr_constructor(profile_map_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: profile_map_c_ptr + ! Return value + type(profile_map_t), pointer :: this - allocate( this ) - this%ptr_ = profile_map_c_ptr + allocate( this ) + this%ptr_ = profile_map_c_ptr - end function profile_map_t_ptr_constructor + end function profile_map_t_ptr_constructor - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Create a new profile map - function profile_map_t_constructor(error) result(this) - use musica_util, only: error_t, error_t_c, assert + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Create a new profile map + function profile_map_t_constructor(error) result(this) + use musica_util, only: error_t, error_t_c, assert - ! Arguments - type(error_t), intent(inout) :: error + ! Arguments + type(error_t), intent(inout) :: error - ! Return value - type(profile_map_t), pointer :: this + ! Return value + type(profile_map_t), pointer :: this - ! Local variables - type(error_t_c) error_c + ! Local variables + type(error_t_c) error_c - allocate( this ) - this%ptr_ = create_profile_map_c(error_c) - error = error_t(error_c) + allocate( this ) + this%ptr_ = create_profile_map_c(error_c) + error = error_t(error_c) - end function profile_map_t_constructor - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Adds a profile to the profile map - subroutine add_profile(this, profile, error) - use musica_tuvx_profile, only: profile_t - use musica_util, only: error_t, error_t_c, assert + end function profile_map_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a profile to the profile map + subroutine add_profile(this, profile, error) + use musica_tuvx_profile, only: profile_t + use musica_util, only: error_t, error_t_c, assert - ! Arguments - class(profile_map_t), intent(inout) :: this - type(profile_t), intent(in) :: profile - type(error_t), intent(inout) :: error + ! Arguments + class(profile_map_t), intent(inout) :: this + type(profile_t), intent(in) :: profile + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - call add_profile_c(this%ptr_, profile%ptr_, error_c) - error = error_t(error_c) + call add_profile_c(this%ptr_, profile%ptr_, error_c) + error = error_t(error_c) - end subroutine add_profile - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end subroutine add_profile + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Gets a profile given its name and units - function get_profile(this, profile_name, profile_units, error) result(profile) - use iso_c_binding, only: c_char - use musica_tuvx_profile, only: profile_t - use musica_util, only: error_t, error_t_c, to_c_string + !> Gets a profile given its name and units + function get_profile(this, profile_name, profile_units, error) result(profile) + use iso_c_binding, only: c_char + use musica_tuvx_profile, only: profile_t + use musica_util, only: error_t, error_t_c, to_c_string - ! Arguments - class(profile_map_t), intent(in) :: this - character(len=*), intent(in) :: profile_name - character(len=*), intent(in) :: profile_units - type(error_t), intent(inout) :: error + ! Arguments + class(profile_map_t), intent(in) :: this + character(len=*), intent(in) :: profile_name + character(len=*), intent(in) :: profile_units + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c - - ! Return value - type(profile_t), pointer :: profile + ! Local variables + type(error_t_c) :: error_c + + ! Return value + type(profile_t), pointer :: profile - profile => profile_t(get_profile_c(this%ptr_, to_c_string(profile_name), & - to_c_string(profile_units), error_c)) + profile => profile_t(get_profile_c(this%ptr_, to_c_string(profile_name), & + to_c_string(profile_units), error_c)) - error = error_t(error_c) + error = error_t(error_c) - end function get_profile + end function get_profile - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Deallocates the profile map instance - subroutine finalize_profile_map_t(this) - use iso_c_binding, only: c_associated - use musica_util, only: error_t, error_t_c, assert + !> Deallocates the profile map instance + subroutine finalize_profile_map_t(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert - ! Arguments - type(profile_map_t), intent(inout) :: this + ! Arguments + type(profile_map_t), intent(inout) :: this - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error - if (c_associated(this%ptr_)) then - call delete_profile_map_c(this%ptr_, error_c) - this%ptr_ = c_null_ptr - error = error_t(error_c) - ASSERT(error%is_success()) - end if + if (c_associated(this%ptr_)) then + call delete_profile_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_profile_map_t + end subroutine finalize_profile_map_t - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module musica_tuvx_profile_map diff --git a/fortran/tuvx/tuvx.F90 b/fortran/tuvx/tuvx.F90 index 850f6f14..94e4edd0 100644 --- a/fortran/tuvx/tuvx.F90 +++ b/fortran/tuvx/tuvx.F90 @@ -2,176 +2,176 @@ ! 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 - implicit none + implicit none #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - private - public :: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - interface - function create_tuvx_c(config_path, error) bind(C, name="CreateTuvx") - use musica_util, only: error_t_c - use iso_c_binding, only: c_ptr, c_int, c_char - character(len=1, kind=c_char), intent(in) :: config_path(*) - type(error_t_c), intent(inout) :: error - type(c_ptr) :: create_tuvx_c - end function create_tuvx_c - - subroutine delete_tuvx_c(tuvx, error) bind(C, name="DeleteTuvx") - 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 - end subroutine delete_tuvx_c - - function get_grid_map_c(tuvx, error) bind(C, name="GetGridMap") - 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_grid_map_c - end function get_grid_map_c - - 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 - end function get_profile_map_c - end interface - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: tuvx_t - type(c_ptr), private :: ptr_ = c_null_ptr - contains - ! Create a grid map - procedure :: get_grids - ! Create a profile map - procedure :: get_profiles - ! Deallocate the tuvx instance - final :: finalize - end type tuvx_t - - interface tuvx_t - procedure constructor - end interface tuvx_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + private + public :: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_tuvx_c(config_path, error) bind(C, name="CreateTuvx") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr, c_int, c_char + character(len=1, kind=c_char), intent(in) :: config_path(*) + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_tuvx_c + end function create_tuvx_c + + subroutine delete_tuvx_c(tuvx, error) bind(C, name="DeleteTuvx") + 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 + end subroutine delete_tuvx_c + + function get_grid_map_c(tuvx, error) bind(C, name="GetGridMap") + 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_grid_map_c + end function get_grid_map_c + + 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 + end function get_profile_map_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: tuvx_t + type(c_ptr), private :: ptr_ = c_null_ptr + contains + ! Create a grid map + procedure :: get_grids + ! Create a profile map + procedure :: get_profiles + ! Deallocate the tuvx instance + final :: finalize + end type tuvx_t + + interface tuvx_t + procedure constructor + end interface tuvx_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! contains - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Construct a tuvx instance - function constructor(config_path, error) result( this ) - use iso_c_binding, only: c_char, c_null_char - use musica_util, only: error_t_c, error_t + !> Construct a tuvx instance + function constructor(config_path, error) result( this ) + use iso_c_binding, only: c_char, c_null_char + use musica_util, only: error_t_c, error_t - ! Arguments - type(error_t), intent(inout) :: error - character(len=*), intent(in) :: config_path + ! Arguments + type(error_t), intent(inout) :: error + character(len=*), intent(in) :: config_path - ! Local variables - character(len=1, kind=c_char) :: c_config_path(len_trim(config_path)+1) - integer :: n, i - type(error_t_c) :: error_c + ! Local variables + character(len=1, kind=c_char) :: c_config_path(len_trim(config_path)+1) + integer :: n, i + type(error_t_c) :: error_c - ! Return value - type(tuvx_t), pointer :: this + ! Return value + type(tuvx_t), pointer :: this - allocate( this ) + allocate( this ) - n = len_trim(config_path) - do i = 1, n - c_config_path(i) = config_path(i:i) - end do - c_config_path(n+1) = c_null_char + n = len_trim(config_path) + do i = 1, n + c_config_path(i) = config_path(i:i) + end do + c_config_path(n+1) = c_null_char - this%ptr_ = create_tuvx_c(c_config_path, error_c) + this%ptr_ = create_tuvx_c(c_config_path, error_c) - error = error_t(error_c) - if (.not. error%is_success()) then - deallocate(this) - nullify(this) - return - end if - end function constructor + error = error_t(error_c) + if (.not. error%is_success()) then + deallocate(this) + nullify(this) + return + end if + end function constructor - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Get the grid map - function get_grids(this, error) result(grid_map) - use musica_util, only: error_t, error_t_c + !> Get the grid map + function get_grids(this, error) result(grid_map) + use musica_util, only: error_t, error_t_c - ! Arguments - class(tuvx_t), intent(inout) :: this - type(error_t), intent(inout) :: error + ! Arguments + class(tuvx_t), intent(inout) :: this + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - ! Return value - type(grid_map_t), pointer :: grid_map + ! Return value + type(grid_map_t), pointer :: grid_map - grid_map => grid_map_t(get_grid_map_c(this%ptr_, error_c)) - - error = error_t(error_c) + grid_map => grid_map_t(get_grid_map_c(this%ptr_, error_c)) + + error = error_t(error_c) - end function get_grids + end function get_grids - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Get the profile map - function get_profiles(this, error) result(profile_map) - use musica_util, only: error_t, error_t_c + !> Get the profile map + function get_profiles(this, error) result(profile_map) + use musica_util, only: error_t, error_t_c - ! Arguments - class(tuvx_t), intent(inout) :: this - type(error_t), intent(inout) :: error + ! Arguments + class(tuvx_t), intent(inout) :: this + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - ! Return value - type(profile_map_t), pointer :: profile_map + ! Return value + type(profile_map_t), pointer :: profile_map - profile_map => profile_map_t(get_profile_map_c(this%ptr_, error_c)) - - error = error_t(error_c) + profile_map => profile_map_t(get_profile_map_c(this%ptr_, error_c)) + + error = error_t(error_c) - end function get_profiles + end function get_profiles - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Deallocate the tuvx instance - subroutine finalize(this) - use musica_util, only: error_t, error_t_c, assert + !> Deallocate the tuvx instance + subroutine finalize(this) + use musica_util, only: error_t, error_t_c, assert - ! Arguments - type(tuvx_t), intent(inout) :: this + ! Arguments + type(tuvx_t), intent(inout) :: this - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error - call delete_tuvx_c(this%ptr_, error_c) - this%ptr_ = c_null_ptr - error = error_t(error_c) - ASSERT(error%is_success()) + call delete_tuvx_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) - end subroutine finalize + end subroutine finalize - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module musica_tuvx