From 9993aa333be7c8e339675df8f0b037edd04177b6 Mon Sep 17 00:00:00 2001 From: Matt Dawson Date: Wed, 6 Nov 2024 10:39:55 -0800 Subject: [PATCH] Add `contiguous` attribute for arrays passed to c functions (#242) * add contiguous attribute for arrays passed to c functions * add tests with array slices and fix intents * revert to previous intel image to avoid gfortran ICE --- docker/Dockerfile.fortran-intel | 2 +- fortran/micm.F90 | 20 +- .../test_micm_api.F90 | 102 ++-- .../test_tuvx_api.F90 | 500 +++++++++--------- fortran/tuvx/grid.F90 | 26 +- fortran/tuvx/profile.F90 | 38 +- fortran/tuvx/radiator.F90 | 36 +- fortran/tuvx/tuvx.F90 | 12 +- fortran/util.F90 | 6 +- 9 files changed, 380 insertions(+), 362 deletions(-) diff --git a/docker/Dockerfile.fortran-intel b/docker/Dockerfile.fortran-intel index a3f3ec94..da120605 100644 --- a/docker/Dockerfile.fortran-intel +++ b/docker/Dockerfile.fortran-intel @@ -1,5 +1,5 @@ # versions and sizes from here: https://hub.docker.com/r/intel/oneapi-hpckit/tags -FROM intel/oneapi-hpckit:latest +FROM intel/oneapi-hpckit:2024.0.1-devel-ubuntu22.04 # Based off of this: https://dgpu-docs.intel.com/driver/installation.html#repository-public-key-used-for-package-and-repository-signing # however those docs (at the time of this writing are incorrect) and this is the correct url diff --git a/fortran/micm.F90 b/fortran/micm.F90 index 92383920..e55ab0d3 100644 --- a/fortran/micm.F90 +++ b/fortran/micm.F90 @@ -252,16 +252,16 @@ subroutine solve_arrays(this, time_step, temperature, pressure, air_density, & use iso_c_binding, only: c_loc use iso_fortran_env, only: real64 use musica_util, only: string_t, string_t_c, error_t_c, error_t - class(micm_t), intent(in) :: this - real(real64), intent(in) :: time_step - real(real64), target, intent(in) :: temperature(:) - real(real64), target, intent(in) :: pressure(:) - real(real64), target, intent(in) :: air_density(:) - real(real64), target, intent(inout) :: concentrations(:,:) - real(real64), target, intent(in) :: 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 + class(micm_t), intent(in) :: this + real(real64), intent(in) :: time_step + real(real64), target, contiguous, intent(in) :: temperature(:) + real(real64), target, contiguous, intent(in) :: pressure(:) + real(real64), target, contiguous, intent(in) :: air_density(:) + real(real64), target, contiguous, intent(inout) :: concentrations(:,:) + real(real64), target, contiguous, intent(in) :: 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 diff --git a/fortran/test/fetch_content_integration/test_micm_api.F90 b/fortran/test/fetch_content_integration/test_micm_api.F90 index 7168f853..87d1a909 100644 --- a/fortran/test/fetch_content_integration/test_micm_api.F90 +++ b/fortran/test/fetch_content_integration/test_micm_api.F90 @@ -182,13 +182,18 @@ subroutine test_vector_multiple_grid_cells(micm, NUM_GRID_CELLS, time_step, test integer, parameter :: NUM_SPECIES = 6 integer, parameter :: NUM_USER_DEFINED_REACTION_RATES = 2 - real(real64), target :: temperature(NUM_GRID_CELLS) - real(real64), target :: pressure(NUM_GRID_CELLS) - real(real64), target :: air_density(NUM_GRID_CELLS) - real(real64), target :: concentrations(NUM_GRID_CELLS,NUM_SPECIES) + ! set up arrays to pass to MICM as slices to ensure contiguous memory is passed to c functions + real(real64), target :: temperature(2,NUM_GRID_CELLS) + real(real64), target :: temperature_c_ptrs(NUM_GRID_CELLS) + real(real64), target :: pressure(2,NUM_GRID_CELLS) + real(real64), target :: pressure_c_ptrs(NUM_GRID_CELLS) + real(real64), target :: air_density(3,NUM_GRID_CELLS) + real(real64), target :: air_density_c_ptrs(NUM_GRID_CELLS) + real(real64), target :: concentrations(4,NUM_GRID_CELLS,NUM_SPECIES) real(real64), target :: concentrations_c_ptrs(NUM_GRID_CELLS,NUM_SPECIES) - real(real64), target :: initial_concentrations(NUM_GRID_CELLS,NUM_SPECIES) - real(real64), target :: user_defined_reaction_rates(NUM_GRID_CELLS,NUM_USER_DEFINED_REACTION_RATES) + real(real64), target :: initial_concentrations(4,NUM_GRID_CELLS,NUM_SPECIES) + real(real64), target :: user_defined_reaction_rates(3,NUM_GRID_CELLS,NUM_USER_DEFINED_REACTION_RATES) + real(real64), target :: user_defined_reaction_rates_c_ptrs(NUM_GRID_CELLS,NUM_USER_DEFINED_REACTION_RATES) type(string_t) :: solver_state type(solver_stats_t) :: solver_stats integer :: solver_type @@ -221,51 +226,62 @@ subroutine test_vector_multiple_grid_cells(micm, NUM_GRID_CELLS, time_step, test R2_index = micm%user_defined_reaction_rates%index( "USER.reaction 2", error ) ASSERT( error%is_success() ) + temperature(:,:) = 1.0e300_real64 + pressure(:,:) = 1.0e300_real64 + air_density(:,:) = 1.0e300_real64 + concentrations(:,:,:) = 1.0e300_real64 + user_defined_reaction_rates(:,:,:) = 1.0e300_real64 do i_cell = 1, NUM_GRID_CELLS call random_number( temp ) - temperature(i_cell) = 265.0 + temp * 20.0 + temperature(2,i_cell) = 265.0 + temp * 20.0 call random_number( temp ) - pressure(i_cell) = 100753.3 + temp * 1000.0 - air_density(i_cell) = pressure(i_cell) / ( GAS_CONSTANT * temperature(i_cell) ) + pressure(2,i_cell) = 100753.3 + temp * 1000.0 + air_density(2,i_cell) = pressure(2,i_cell) / ( GAS_CONSTANT * temperature(2,i_cell) ) call random_number( temp ) - concentrations(i_cell,A_index) = 0.7 + temp * 0.1 - concentrations(i_cell,B_index) = 0.0 + concentrations(2,i_cell,A_index) = 0.7 + temp * 0.1 + concentrations(2,i_cell,B_index) = 0.0 call random_number( temp ) - concentrations(i_cell,C_index) = 0.35 + temp * 0.1 + concentrations(2,i_cell,C_index) = 0.35 + temp * 0.1 call random_number( temp ) - concentrations(i_cell,D_index) = 0.75 + temp * 0.1 - concentrations(i_cell,E_index) = 0.0 + concentrations(2,i_cell,D_index) = 0.75 + temp * 0.1 + concentrations(2,i_cell,E_index) = 0.0 call random_number( temp ) - concentrations(i_cell,F_index) = 0.05 + temp * 0.1 + concentrations(2,i_cell,F_index) = 0.05 + temp * 0.1 call random_number( temp ) - user_defined_reaction_rates(i_cell,R1_index) = 0.0005 + temp * 0.0001 + user_defined_reaction_rates(2,i_cell,R1_index) = 0.0005 + temp * 0.0001 call random_number( temp ) - user_defined_reaction_rates(i_cell,R2_index) = 0.0015 + temp * 0.0001 + user_defined_reaction_rates(2,i_cell,R2_index) = 0.0015 + temp * 0.0001 end do - initial_concentrations(:,:) = concentrations(:,:) - concentrations_c_ptrs(:,:) = concentrations(:,:) + initial_concentrations(:,:,:) = concentrations(:,:,:) + concentrations_c_ptrs(:,:) = concentrations(2,:,:) + user_defined_reaction_rates_c_ptrs(:,:) = user_defined_reaction_rates(2,:,:) + temperature_c_ptrs(:) = temperature(2,:) + pressure_c_ptrs(:) = pressure(2,:) + air_density_c_ptrs(:) = air_density(2,:) ! solve by passing fortran arrays - call micm%solve(time_step, temperature, pressure, air_density, concentrations, & - user_defined_reaction_rates, solver_state, solver_stats, error) + call micm%solve(time_step, temperature(2,:), pressure(2,:), air_density(2,:), & + concentrations(2,:,:), user_defined_reaction_rates(2,:,:), & + solver_state, solver_stats, error) ASSERT( error%is_success() ) ASSERT_EQ(solver_state%get_char_array(), "Converged") ! solve by passing C pointers - call micm%solve(time_step, c_loc(temperature), c_loc(pressure), c_loc(air_density), & - c_loc(concentrations_c_ptrs), c_loc(user_defined_reaction_rates), & + call micm%solve(time_step, c_loc(temperature_c_ptrs), c_loc(pressure_c_ptrs), & + c_loc(air_density_c_ptrs), c_loc(concentrations_c_ptrs), & + c_loc(user_defined_reaction_rates_c_ptrs), & solver_state, solver_stats, error) ASSERT( error%is_success() ) ASSERT_EQ(solver_state%get_char_array(), "Converged") ! check concentrations do i_cell = 1, NUM_GRID_CELLS - ASSERT_EQ(concentrations(i_cell,A_index), concentrations_c_ptrs(i_cell,A_index)) - ASSERT_EQ(concentrations(i_cell,B_index), concentrations_c_ptrs(i_cell,B_index)) - ASSERT_EQ(concentrations(i_cell,C_index), concentrations_c_ptrs(i_cell,C_index)) - ASSERT_EQ(concentrations(i_cell,D_index), concentrations_c_ptrs(i_cell,D_index)) - ASSERT_EQ(concentrations(i_cell,E_index), concentrations_c_ptrs(i_cell,E_index)) - ASSERT_EQ(concentrations(i_cell,F_index), concentrations_c_ptrs(i_cell,F_index)) + ASSERT_EQ(concentrations(2,i_cell,A_index), concentrations_c_ptrs(i_cell,A_index)) + ASSERT_EQ(concentrations(2,i_cell,B_index), concentrations_c_ptrs(i_cell,B_index)) + ASSERT_EQ(concentrations(2,i_cell,C_index), concentrations_c_ptrs(i_cell,C_index)) + ASSERT_EQ(concentrations(2,i_cell,D_index), concentrations_c_ptrs(i_cell,D_index)) + ASSERT_EQ(concentrations(2,i_cell,E_index), concentrations_c_ptrs(i_cell,E_index)) + ASSERT_EQ(concentrations(2,i_cell,F_index), concentrations_c_ptrs(i_cell,F_index)) end do r1%A_ = 0.004 @@ -277,26 +293,26 @@ subroutine test_vector_multiple_grid_cells(micm, NUM_GRID_CELLS, time_step, test r2%E_ = 1.0e-6 do i_cell = 1, NUM_GRID_CELLS - initial_A = initial_concentrations(i_cell,A_index) - initial_C = initial_concentrations(i_cell,C_index) - initial_D = initial_concentrations(i_cell,D_index) - initial_F = initial_concentrations(i_cell,F_index) - k1 = user_defined_reaction_rates(i_cell,R1_index) - k2 = user_defined_reaction_rates(i_cell,R2_index) - k3 = calculate_arrhenius( r1, temperature(i_cell), pressure(i_cell) ) - k4 = calculate_arrhenius( r2, temperature(i_cell), pressure(i_cell) ) + initial_A = initial_concentrations(2,i_cell,A_index) + initial_C = initial_concentrations(2,i_cell,C_index) + initial_D = initial_concentrations(2,i_cell,D_index) + initial_F = initial_concentrations(2,i_cell,F_index) + k1 = user_defined_reaction_rates(2,i_cell,R1_index) + k2 = user_defined_reaction_rates(2,i_cell,R2_index) + k3 = calculate_arrhenius( r1, temperature(2,i_cell), pressure(2,i_cell) ) + k4 = calculate_arrhenius( r2, temperature(2,i_cell), pressure(2,i_cell) ) A = initial_A * exp( -k3 * time_step ) B = initial_A * (k3 / (k4 - k3)) * (exp(-k3 * time_step) - exp(-k4 * time_step)) C = initial_C + initial_A * (1.0 + (k3 * exp(-k4 * time_step) - k4 * exp(-k3 * time_step)) / (k4 - k3)) D = initial_D * exp( -k1 * time_step ) E = initial_D * (k1 / (k2 - k1)) * (exp(-k1 * time_step) - exp(-k2 * time_step)) F = initial_F + initial_D * (1.0 + (k1 * exp(-k2 * time_step) - k2 * exp(-k1 * time_step)) / (k2 - k1)) - ASSERT_NEAR(concentrations(i_cell,A_index), A, test_accuracy) - ASSERT_NEAR(concentrations(i_cell,B_index), B, test_accuracy) - ASSERT_NEAR(concentrations(i_cell,C_index), C, test_accuracy) - ASSERT_NEAR(concentrations(i_cell,D_index), D, test_accuracy) - ASSERT_NEAR(concentrations(i_cell,E_index), E, test_accuracy) - ASSERT_NEAR(concentrations(i_cell,F_index), F, test_accuracy) + ASSERT_NEAR(concentrations(2,i_cell,A_index), A, test_accuracy) + ASSERT_NEAR(concentrations(2,i_cell,B_index), B, test_accuracy) + ASSERT_NEAR(concentrations(2,i_cell,C_index), C, test_accuracy) + ASSERT_NEAR(concentrations(2,i_cell,D_index), D, test_accuracy) + ASSERT_NEAR(concentrations(2,i_cell,E_index), E, test_accuracy) + ASSERT_NEAR(concentrations(2,i_cell,F_index), F, test_accuracy) end do end subroutine test_vector_multiple_grid_cells diff --git a/fortran/test/fetch_content_integration/test_tuvx_api.F90 b/fortran/test/fetch_content_integration/test_tuvx_api.F90 index a8e91432..a5e660c7 100644 --- a/fortran/test/fetch_content_integration/test_tuvx_api.F90 +++ b/fortran/test/fetch_content_integration/test_tuvx_api.F90 @@ -78,36 +78,38 @@ end subroutine test_tuvx_api_invalid_config subroutine test_tuvx_solve() - type(tuvx_t), pointer :: tuvx - type(error_t) :: error - character(len=256) :: config_path - type(grid_map_t), pointer :: grids, grids_from_host - type(grid_t), pointer :: grid, height_grid, wavelength_grid - type(profile_map_t), pointer :: profiles, profiles_from_host - type(profile_t), pointer :: profile, profile_copy - type(radiator_map_t), pointer :: radiators, radiators_from_host - type(radiator_t), pointer :: radiator, radiator_copy - real*8, dimension(5), target :: edges, edge_values, temp_edge - real*8, dimension(4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint - real*8 :: temp_real - integer :: num_vertical_layers, num_wavelength_bins - real*8, dimension(3,2), target :: optical_depths, temp_od - real*8, dimension(3,2), target :: single_scattering_albedos, temp_ssa - real*8, dimension(3,2,1), target :: asymmetry_factors, temp_asym - - edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) - midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) - edge_values = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) - midpoint_values = (/ 15.0, 25.0, 35.0, 45.0 /) - layer_densities = (/ 2.0, 4.0, 1.0, 7.0 /) + type(tuvx_t), pointer :: tuvx + type(error_t) :: error + character(len=256) :: config_path + type(grid_map_t), pointer :: grids, grids_from_host + type(grid_t), pointer :: grid, height_grid, wavelength_grid + type(profile_map_t), pointer :: profiles, profiles_from_host + type(profile_t), pointer :: profile, profile_copy + type(radiator_map_t), pointer :: radiators, radiators_from_host + type(radiator_t), pointer :: radiator, radiator_copy + ! set up arrays with extra dimensions to test whether arrays passed to + ! c functions are contiguous + real*8, dimension(3,5), target :: edges, edge_values, temp_edge + real*8, dimension(2,4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint + real*8 :: temp_real + integer :: num_vertical_layers, num_wavelength_bins + real*8, dimension(4,3,2), target :: optical_depths, temp_od + real*8, dimension(3,3,2), target :: single_scattering_albedos, temp_ssa + real*8, dimension(2,3,2,1), target :: asymmetry_factors, temp_asym + + edges(2,:) = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) + midpoints(2,:) = (/ 15.0, 25.0, 35.0, 45.0 /) + edge_values(2,:) = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) + midpoint_values(2,:) = (/ 15.0, 25.0, 35.0, 45.0 /) + layer_densities(2,:) = (/ 2.0, 4.0, 1.0, 7.0 /) num_vertical_layers = 3 num_wavelength_bins = 2 - optical_depths(:,1) = (/ 30.0, 20.0, 10.0 /) - optical_depths(:,2) = (/ 70.0, 80.0, 90.0 /) - single_scattering_albedos(:,1) = (/ 300.0, 200.0, 100.0 /) - single_scattering_albedos(:,2) = (/ 700.0, 800.0, 900.0 /) - asymmetry_factors(:,1,1) = (/ 3.0, 2.0, 1.0 /) - asymmetry_factors(:,2,1) = (/ 7.0, 8.0, 9.0 /) + optical_depths(2,:,1) = (/ 30.0, 20.0, 10.0 /) + optical_depths(2,:,2) = (/ 70.0, 80.0, 90.0 /) + single_scattering_albedos(2,:,1) = (/ 300.0, 200.0, 100.0 /) + single_scattering_albedos(2,:,2) = (/ 700.0, 800.0, 900.0 /) + asymmetry_factors(2,:,1,1) = (/ 3.0, 2.0, 1.0 /) + asymmetry_factors(2,:,2,1) = (/ 7.0, 8.0, 9.0 /) config_path = "examples/ts1_tsmlt.json" @@ -137,132 +139,132 @@ subroutine test_tuvx_solve() ASSERT_EQ( grid%number_of_sections( error ), 4 ) ASSERT( error%is_success() ) - call grid%set_edges( edges, error ) + call grid%set_edges( edges(2,:), error ) ASSERT( error%is_success() ) - call grid%get_edges( temp_edge, error ) + call grid%get_edges( temp_edge(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_edge(1), 1.0 ) - ASSERT_EQ( temp_edge(2), 2.0 ) - ASSERT_EQ( temp_edge(3), 3.0 ) - ASSERT_EQ( temp_edge(4), 4.0 ) - ASSERT_EQ( temp_edge(5), 5.0 ) + ASSERT_EQ( temp_edge(2,1), 1.0 ) + ASSERT_EQ( temp_edge(2,2), 2.0 ) + ASSERT_EQ( temp_edge(2,3), 3.0 ) + ASSERT_EQ( temp_edge(2,4), 4.0 ) + ASSERT_EQ( temp_edge(2,5), 5.0 ) - edges = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) + edges(2,:) = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) - call grid%set_edges( edges, error ) + call grid%set_edges( edges(2,:), error ) ASSERT( error%is_success() ) - call grid%set_midpoints( midpoints, error ) + call grid%set_midpoints( midpoints(2,:), error ) ASSERT( error%is_success() ) - call grid%get_edges( temp_edge, error ) + call grid%get_edges( temp_edge(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_edge(1), 10.0 ) - ASSERT_EQ( temp_edge(2), 20.0 ) - ASSERT_EQ( temp_edge(3), 30.0 ) - ASSERT_EQ( temp_edge(4), 40.0 ) - ASSERT_EQ( temp_edge(5), 50.0 ) + ASSERT_EQ( temp_edge(2,1), 10.0 ) + ASSERT_EQ( temp_edge(2,2), 20.0 ) + ASSERT_EQ( temp_edge(2,3), 30.0 ) + ASSERT_EQ( temp_edge(2,4), 40.0 ) + ASSERT_EQ( temp_edge(2,5), 50.0 ) - call grid%get_midpoints( temp_midpoint, error ) + call grid%get_midpoints( temp_midpoint(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_midpoint(1), 15.0 ) - ASSERT_EQ( temp_midpoint(2), 25.0 ) - ASSERT_EQ( temp_midpoint(3), 35.0 ) - ASSERT_EQ( temp_midpoint(4), 45.0 ) + ASSERT_EQ( temp_midpoint(2,1), 15.0 ) + ASSERT_EQ( temp_midpoint(2,2), 25.0 ) + ASSERT_EQ( temp_midpoint(2,3), 35.0 ) + ASSERT_EQ( temp_midpoint(2,4), 45.0 ) call grids%add( grid, error ) - edges(:) = 0.0 - midpoints(:) = 0.0 + edges(2,:) = 0.0 + midpoints(2,:) = 0.0 - call grid%get_edges( edges, error ) + call grid%get_edges( edges(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( edges(1), 10.0 ) - ASSERT_EQ( edges(2), 20.0 ) - ASSERT_EQ( edges(3), 30.0 ) - ASSERT_EQ( edges(4), 40.0 ) - ASSERT_EQ( edges(5), 50.0 ) + ASSERT_EQ( edges(2,1), 10.0 ) + ASSERT_EQ( edges(2,2), 20.0 ) + ASSERT_EQ( edges(2,3), 30.0 ) + ASSERT_EQ( edges(2,4), 40.0 ) + ASSERT_EQ( edges(2,5), 50.0 ) - call grid%get_midpoints( midpoints, error ) + call grid%get_midpoints( midpoints(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( midpoints(1), 15.0 ) - ASSERT_EQ( midpoints(2), 25.0 ) - ASSERT_EQ( midpoints(3), 35.0 ) - ASSERT_EQ( midpoints(4), 45.0 ) + ASSERT_EQ( midpoints(2,1), 15.0 ) + ASSERT_EQ( midpoints(2,2), 25.0 ) + ASSERT_EQ( midpoints(2,3), 35.0 ) + ASSERT_EQ( midpoints(2,4), 45.0 ) - edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) - midpoints = (/ 1.5, 2.5, 3.5, 4.5 /) + edges(2,:) = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) + midpoints(2,:) = (/ 1.5, 2.5, 3.5, 4.5 /) - call grid%set_edges( edges, error ) + call grid%set_edges( edges(2,:), error ) ASSERT( error%is_success() ) - call grid%set_midpoints( midpoints, error ) + call grid%set_midpoints( midpoints(2,:), error ) ASSERT( error%is_success() ) - edges(:) = 0.0 - midpoints(:) = 0.0 + edges(2,:) = 0.0 + midpoints(2,:) = 0.0 - call grid%get_edges( edges, error ) + call grid%get_edges( edges(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( edges(1), 1.0 ) - ASSERT_EQ( edges(2), 2.0 ) - ASSERT_EQ( edges(3), 3.0 ) - ASSERT_EQ( edges(4), 4.0 ) - ASSERT_EQ( edges(5), 5.0 ) + ASSERT_EQ( edges(2,1), 1.0 ) + ASSERT_EQ( edges(2,2), 2.0 ) + ASSERT_EQ( edges(2,3), 3.0 ) + ASSERT_EQ( edges(2,4), 4.0 ) + ASSERT_EQ( edges(2,5), 5.0 ) - call grid%get_midpoints( midpoints, error ) + call grid%get_midpoints( midpoints(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( midpoints(1), 1.5 ) - ASSERT_EQ( midpoints(2), 2.5 ) - ASSERT_EQ( midpoints(3), 3.5 ) - ASSERT_EQ( midpoints(4), 4.5 ) + ASSERT_EQ( midpoints(2,1), 1.5 ) + ASSERT_EQ( midpoints(2,2), 2.5 ) + ASSERT_EQ( midpoints(2,3), 3.5 ) + ASSERT_EQ( midpoints(2,4), 4.5 ) deallocate( grid ) grid => grids%get( "foo", "bars", error ) ASSERT( error%is_success() ) - edges(:) = 0.0 - midpoints(:) = 0.0 + edges(2,:) = 0.0 + midpoints(2,:) = 0.0 - call grid%get_edges( edges, error ) + call grid%get_edges( edges(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( edges(1), 1.0 ) - ASSERT_EQ( edges(2), 2.0 ) - ASSERT_EQ( edges(3), 3.0 ) - ASSERT_EQ( edges(4), 4.0 ) - ASSERT_EQ( edges(5), 5.0 ) + ASSERT_EQ( edges(2,1), 1.0 ) + ASSERT_EQ( edges(2,2), 2.0 ) + ASSERT_EQ( edges(2,3), 3.0 ) + ASSERT_EQ( edges(2,4), 4.0 ) + ASSERT_EQ( edges(2,5), 5.0 ) - call grid%get_midpoints( midpoints, error ) + call grid%get_midpoints( midpoints(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( midpoints(1), 1.5 ) - ASSERT_EQ( midpoints(2), 2.5 ) - ASSERT_EQ( midpoints(3), 3.5 ) - ASSERT_EQ( midpoints(4), 4.5 ) + ASSERT_EQ( midpoints(2,1), 1.5 ) + ASSERT_EQ( midpoints(2,2), 2.5 ) + ASSERT_EQ( midpoints(2,3), 3.5 ) + ASSERT_EQ( midpoints(2,4), 4.5 ) - edges = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) - midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) + edges(2,:) = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) + midpoints(2,:) = (/ 15.0, 25.0, 35.0, 45.0 /) - call grid%set_edges( edges, error ) - call grid%set_midpoints( midpoints, error ) + call grid%set_edges( edges(2,:), error ) + call grid%set_midpoints( midpoints(2,:), error ) ASSERT( error%is_success() ) - edges(:) = 0.0 - midpoints(:) = 0.0 + edges(2,:) = 0.0 + midpoints(2,:) = 0.0 - call grid%get_edges( edges, error ) + call grid%get_edges( edges(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( edges(1), 10.0 ) - ASSERT_EQ( edges(2), 20.0 ) - ASSERT_EQ( edges(3), 30.0 ) - ASSERT_EQ( edges(4), 40.0 ) - ASSERT_EQ( edges(5), 50.0 ) + ASSERT_EQ( edges(2,1), 10.0 ) + ASSERT_EQ( edges(2,2), 20.0 ) + ASSERT_EQ( edges(2,3), 30.0 ) + ASSERT_EQ( edges(2,4), 40.0 ) + ASSERT_EQ( edges(2,5), 50.0 ) - call grid%get_midpoints( midpoints, error ) + call grid%get_midpoints( midpoints(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( midpoints(1), 15.0 ) - ASSERT_EQ( midpoints(2), 25.0 ) - ASSERT_EQ( midpoints(3), 35.0 ) - ASSERT_EQ( midpoints(4), 45.0 ) + ASSERT_EQ( midpoints(2,1), 15.0 ) + ASSERT_EQ( midpoints(2,2), 25.0 ) + ASSERT_EQ( midpoints(2,3), 35.0 ) + ASSERT_EQ( midpoints(2,4), 45.0 ) profiles => tuvx%get_profiles( error ) ASSERT( error%is_success() ) @@ -278,36 +280,36 @@ subroutine test_tuvx_solve() profile => profile_t( "baz", "qux", grid, error ) ASSERT( error%is_success() ) - call profile%set_edge_values( edge_values, error ) + call profile%set_edge_values( edge_values(2,:), error ) ASSERT( error%is_success() ) - call profile%get_edge_values( temp_edge, error ) + call profile%get_edge_values( temp_edge(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_edge(1), 10.0 ) - ASSERT_EQ( temp_edge(2), 20.0 ) - ASSERT_EQ( temp_edge(3), 30.0 ) - ASSERT_EQ( temp_edge(4), 40.0 ) - ASSERT_EQ( temp_edge(5), 50.0 ) + ASSERT_EQ( temp_edge(2,1), 10.0 ) + ASSERT_EQ( temp_edge(2,2), 20.0 ) + ASSERT_EQ( temp_edge(2,3), 30.0 ) + ASSERT_EQ( temp_edge(2,4), 40.0 ) + ASSERT_EQ( temp_edge(2,5), 50.0 ) - call profile%set_midpoint_values( midpoint_values, error ) + call profile%set_midpoint_values( midpoint_values(2,:), error ) ASSERT( error%is_success() ) - call profile%get_midpoint_values( temp_midpoint, error ) + call profile%get_midpoint_values( temp_midpoint(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_midpoint(1), 15.0 ) - ASSERT_EQ( temp_midpoint(2), 25.0 ) - ASSERT_EQ( temp_midpoint(3), 35.0 ) - ASSERT_EQ( temp_midpoint(4), 45.0 ) + ASSERT_EQ( temp_midpoint(2,1), 15.0 ) + ASSERT_EQ( temp_midpoint(2,2), 25.0 ) + ASSERT_EQ( temp_midpoint(2,3), 35.0 ) + ASSERT_EQ( temp_midpoint(2,4), 45.0 ) - call profile%set_layer_densities( layer_densities, error ) + call profile%set_layer_densities( layer_densities(2,:), error ) ASSERT( error%is_success() ) - call profile%get_layer_densities( temp_midpoint, error ) + call profile%get_layer_densities( temp_midpoint(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_midpoint(1), 2.0 ) - ASSERT_EQ( temp_midpoint(2), 4.0 ) - ASSERT_EQ( temp_midpoint(3), 1.0 ) - ASSERT_EQ( temp_midpoint(4), 7.0 ) + ASSERT_EQ( temp_midpoint(2,1), 2.0 ) + ASSERT_EQ( temp_midpoint(2,2), 4.0 ) + ASSERT_EQ( temp_midpoint(2,3), 1.0 ) + ASSERT_EQ( temp_midpoint(2,4), 7.0 ) call profile%set_exo_layer_density( 1.0d0, error ) ASSERT( error%is_success() ) @@ -316,12 +318,12 @@ subroutine test_tuvx_solve() ASSERT( error%is_success() ) ASSERT_EQ( temp_real, 1.0 ) - call profile%get_layer_densities( temp_midpoint, error ) + call profile%get_layer_densities( temp_midpoint(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_midpoint(1), 2.0 ) - ASSERT_EQ( temp_midpoint(2), 4.0 ) - ASSERT_EQ( temp_midpoint(3), 1.0 ) - ASSERT_EQ( temp_midpoint(4), 7.0 + 1.0 ) + ASSERT_EQ( temp_midpoint(2,1), 2.0 ) + ASSERT_EQ( temp_midpoint(2,2), 4.0 ) + ASSERT_EQ( temp_midpoint(2,3), 1.0 ) + ASSERT_EQ( temp_midpoint(2,4), 7.0 + 1.0 ) call profile%calculate_exo_layer_density( 10.0d0, error ) ASSERT( error%is_success() ) @@ -331,34 +333,34 @@ subroutine test_tuvx_solve() ! Revisit this after non-SI units are converted in the TUV-x internal functions ASSERT_EQ( temp_real, 10.0 * 7.0 * 100.0 ) - call profile%get_layer_densities( temp_midpoint, error ) + call profile%get_layer_densities( temp_midpoint(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_midpoint(1), 2.0 ) - ASSERT_EQ( temp_midpoint(2), 4.0 ) - ASSERT_EQ( temp_midpoint(3), 1.0 ) - ASSERT_EQ( temp_midpoint(4), 7.0 + 10.0 * 7.0 * 100.0 ) + ASSERT_EQ( temp_midpoint(2,1), 2.0 ) + ASSERT_EQ( temp_midpoint(2,2), 4.0 ) + ASSERT_EQ( temp_midpoint(2,3), 1.0 ) + ASSERT_EQ( temp_midpoint(2,4), 7.0 + 10.0 * 7.0 * 100.0 ) call profiles%add( profile, error ) profile_copy => profiles%get( "baz", "qux", error ) - call profile_copy%get_edge_values( temp_edge, error ) + call profile_copy%get_edge_values( temp_edge(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_edge(1), 10.0 ) - ASSERT_EQ( temp_edge(2), 20.0 ) - ASSERT_EQ( temp_edge(3), 30.0 ) - ASSERT_EQ( temp_edge(4), 40.0 ) - ASSERT_EQ( temp_edge(5), 50.0 ) + ASSERT_EQ( temp_edge(2,1), 10.0 ) + ASSERT_EQ( temp_edge(2,2), 20.0 ) + ASSERT_EQ( temp_edge(2,3), 30.0 ) + ASSERT_EQ( temp_edge(2,4), 40.0 ) + ASSERT_EQ( temp_edge(2,5), 50.0 ) - edge_values = (/ 32.0, 34.0, 36.0, 38.0, 40.0 /) - call profile_copy%set_edge_values( edge_values, error ) + edge_values(2,:) = (/ 32.0, 34.0, 36.0, 38.0, 40.0 /) + call profile_copy%set_edge_values( edge_values(2,:), error ) - call profile%get_edge_values( temp_edge, error ) + call profile%get_edge_values( temp_edge(2,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_edge(1), 32.0 ) - ASSERT_EQ( temp_edge(2), 34.0 ) - ASSERT_EQ( temp_edge(3), 36.0 ) - ASSERT_EQ( temp_edge(4), 38.0 ) - ASSERT_EQ( temp_edge(5), 40.0 ) + ASSERT_EQ( temp_edge(2,1), 32.0 ) + ASSERT_EQ( temp_edge(2,2), 34.0 ) + ASSERT_EQ( temp_edge(2,3), 36.0 ) + ASSERT_EQ( temp_edge(2,4), 38.0 ) + ASSERT_EQ( temp_edge(2,5), 40.0 ) radiators => tuvx%get_radiators( error ) ASSERT( error%is_success() ) @@ -376,118 +378,118 @@ subroutine test_tuvx_solve() radiator => radiator_t( "foo_radiator", height_grid, wavelength_grid, error ) ASSERT( error%is_success() ) - call radiator%set_optical_depths( optical_depths, error ) + call radiator%set_optical_depths( optical_depths(2,:,:), error ) ASSERT( error%is_success() ) - call radiator%get_optical_depths( temp_od, error ) + call radiator%get_optical_depths( temp_od(2,:,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_od(1,1), 30.0 ) - ASSERT_EQ( temp_od(2,1), 20.0 ) - ASSERT_EQ( temp_od(3,1), 10.0 ) - ASSERT_EQ( temp_od(1,2), 70.0 ) - ASSERT_EQ( temp_od(2,2), 80.0 ) - ASSERT_EQ( temp_od(3,2), 90.0 ) + ASSERT_EQ( temp_od(2,1,1), 30.0 ) + ASSERT_EQ( temp_od(2,2,1), 20.0 ) + ASSERT_EQ( temp_od(2,3,1), 10.0 ) + ASSERT_EQ( temp_od(2,1,2), 70.0 ) + ASSERT_EQ( temp_od(2,2,2), 80.0 ) + ASSERT_EQ( temp_od(2,3,2), 90.0 ) - call radiator%set_single_scattering_albedos( single_scattering_albedos, error ) + call radiator%set_single_scattering_albedos( single_scattering_albedos(2,:,:), error ) ASSERT( error%is_success() ) - call radiator%get_single_scattering_albedos( temp_ssa, error ) + call radiator%get_single_scattering_albedos( temp_ssa(2,:,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_ssa(1,1), 300.0 ) - ASSERT_EQ( temp_ssa(2,1), 200.0 ) - ASSERT_EQ( temp_ssa(3,1), 100.0 ) - ASSERT_EQ( temp_ssa(1,2), 700.0 ) - ASSERT_EQ( temp_ssa(2,2), 800.0 ) - ASSERT_EQ( temp_ssa(3,2), 900.0 ) + ASSERT_EQ( temp_ssa(2,1,1), 300.0 ) + ASSERT_EQ( temp_ssa(2,2,1), 200.0 ) + ASSERT_EQ( temp_ssa(2,3,1), 100.0 ) + ASSERT_EQ( temp_ssa(2,1,2), 700.0 ) + ASSERT_EQ( temp_ssa(2,2,2), 800.0 ) + ASSERT_EQ( temp_ssa(2,3,2), 900.0 ) - call radiator%set_asymmetry_factors( asymmetry_factors, error ) + call radiator%set_asymmetry_factors( asymmetry_factors(2,:,:,:), error ) ASSERT( error%is_success() ) - call radiator%get_asymmetry_factors( temp_asym, error ) + call radiator%get_asymmetry_factors( temp_asym(2,:,:,:), error ) ASSERT( error%is_success() ) - ASSERT_EQ( temp_asym(1,1,1), 3.0 ) - ASSERT_EQ( temp_asym(2,1,1), 2.0 ) - ASSERT_EQ( temp_asym(3,1,1), 1.0 ) - ASSERT_EQ( temp_asym(1,2,1), 7.0 ) - ASSERT_EQ( temp_asym(2,2,1), 8.0 ) - ASSERT_EQ( temp_asym(3,2,1), 9.0 ) + ASSERT_EQ( temp_asym(2,1,1,1), 3.0 ) + ASSERT_EQ( temp_asym(2,2,1,1), 2.0 ) + ASSERT_EQ( temp_asym(2,3,1,1), 1.0 ) + ASSERT_EQ( temp_asym(2,1,2,1), 7.0 ) + ASSERT_EQ( temp_asym(2,2,2,1), 8.0 ) + ASSERT_EQ( temp_asym(2,3,2,1), 9.0 ) ! call radiators%add( radiator, error ) radiator_copy => radiators%get( "foo_radiator", error ) - optical_depths(:,:) = 0.0 - single_scattering_albedos(:,:) = 0.0 - asymmetry_factors(:,:,:) = 0.0 - - call radiator_copy%get_optical_depths( optical_depths, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( optical_depths(1,1), 30.0 ) - ASSERT_EQ( optical_depths(2,1), 20.0 ) - ASSERT_EQ( optical_depths(3,1), 10.0 ) - ASSERT_EQ( optical_depths(1,2), 70.0 ) - ASSERT_EQ( optical_depths(2,2), 80.0 ) - ASSERT_EQ( optical_depths(3,2), 90.0 ) - - call radiator_copy%get_single_scattering_albedos( single_scattering_albedos, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( single_scattering_albedos(1,1), 300.0 ) - ASSERT_EQ( single_scattering_albedos(2,1), 200.0 ) - ASSERT_EQ( single_scattering_albedos(3,1), 100.0 ) - ASSERT_EQ( single_scattering_albedos(1,2), 700.0 ) - ASSERT_EQ( single_scattering_albedos(2,2), 800.0 ) - ASSERT_EQ( single_scattering_albedos(3,2), 900.0 ) - - call radiator_copy%get_asymmetry_factors( asymmetry_factors, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( asymmetry_factors(1,1,1), 3.0 ) - ASSERT_EQ( asymmetry_factors(2,1,1), 2.0 ) - ASSERT_EQ( asymmetry_factors(3,1,1), 1.0 ) - ASSERT_EQ( asymmetry_factors(1,2,1), 7.0 ) - ASSERT_EQ( asymmetry_factors(2,2,1), 8.0 ) - ASSERT_EQ( asymmetry_factors(3,2,1), 9.0 ) - - optical_depths(:,1) = (/ 90.0, 80.0, 70.0 /) - optical_depths(:,2) = (/ 75.0, 85.0, 95.0 /) - single_scattering_albedos(:,1) = (/ 900.0, 800.0, 700.0 /) - single_scattering_albedos(:,2) = (/ 750.0, 850.0, 950.0 /) - asymmetry_factors(:,1,1) = (/ 9.0, 8.0, 7.0 /) - asymmetry_factors(:,2,1) = (/ 5.0, 4.0, 3.0 /) - - call radiator_copy%set_optical_depths( optical_depths, error ) - call radiator_copy%set_single_scattering_albedos( single_scattering_albedos, error ) - call radiator_copy%set_asymmetry_factors( asymmetry_factors, error ) - ASSERT( error%is_success() ) - - optical_depths(:,:) = 0.0 - single_scattering_albedos(:,:) = 0.0 - asymmetry_factors(:,:,:) = 0.0 - - call radiator%get_optical_depths( optical_depths, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( optical_depths(1,1), 90.0 ) - ASSERT_EQ( optical_depths(2,1), 80.0 ) - ASSERT_EQ( optical_depths(3,1), 70.0 ) - ASSERT_EQ( optical_depths(1,2), 75.0 ) - ASSERT_EQ( optical_depths(2,2), 85.0 ) - ASSERT_EQ( optical_depths(3,2), 95.0 ) - - call radiator%get_single_scattering_albedos( single_scattering_albedos, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( single_scattering_albedos(1,1), 900.0 ) - ASSERT_EQ( single_scattering_albedos(2,1), 800.0 ) - ASSERT_EQ( single_scattering_albedos(3,1), 700.0 ) - ASSERT_EQ( single_scattering_albedos(1,2), 750.0 ) - ASSERT_EQ( single_scattering_albedos(2,2), 850.0 ) - ASSERT_EQ( single_scattering_albedos(3,2), 950.0 ) - - call radiator%get_asymmetry_factors( asymmetry_factors, error ) - ASSERT( error%is_success() ) - ASSERT_EQ( asymmetry_factors(1,1,1), 9.0 ) - ASSERT_EQ( asymmetry_factors(2,1,1), 8.0 ) - ASSERT_EQ( asymmetry_factors(3,1,1), 7.0 ) - ASSERT_EQ( asymmetry_factors(1,2,1), 5.0 ) - ASSERT_EQ( asymmetry_factors(2,2,1), 4.0 ) - ASSERT_EQ( asymmetry_factors(3,2,1), 3.0 ) + optical_depths(2,:,:) = 0.0 + single_scattering_albedos(2,:,:) = 0.0 + asymmetry_factors(2,:,:,:) = 0.0 + + call radiator_copy%get_optical_depths( optical_depths(2,:,:), error ) + ASSERT( error%is_success() ) + ASSERT_EQ( optical_depths(2,1,1), 30.0 ) + ASSERT_EQ( optical_depths(2,2,1), 20.0 ) + ASSERT_EQ( optical_depths(2,3,1), 10.0 ) + ASSERT_EQ( optical_depths(2,1,2), 70.0 ) + ASSERT_EQ( optical_depths(2,2,2), 80.0 ) + ASSERT_EQ( optical_depths(2,3,2), 90.0 ) + + call radiator_copy%get_single_scattering_albedos( single_scattering_albedos(2,:,:), error ) + ASSERT( error%is_success() ) + ASSERT_EQ( single_scattering_albedos(2,1,1), 300.0 ) + ASSERT_EQ( single_scattering_albedos(2,2,1), 200.0 ) + ASSERT_EQ( single_scattering_albedos(2,3,1), 100.0 ) + ASSERT_EQ( single_scattering_albedos(2,1,2), 700.0 ) + ASSERT_EQ( single_scattering_albedos(2,2,2), 800.0 ) + ASSERT_EQ( single_scattering_albedos(2,3,2), 900.0 ) + + call radiator_copy%get_asymmetry_factors( asymmetry_factors(2,:,:,:), error ) + ASSERT( error%is_success() ) + ASSERT_EQ( asymmetry_factors(2,1,1,1), 3.0 ) + ASSERT_EQ( asymmetry_factors(2,2,1,1), 2.0 ) + ASSERT_EQ( asymmetry_factors(2,3,1,1), 1.0 ) + ASSERT_EQ( asymmetry_factors(2,1,2,1), 7.0 ) + ASSERT_EQ( asymmetry_factors(2,2,2,1), 8.0 ) + ASSERT_EQ( asymmetry_factors(2,3,2,1), 9.0 ) + + optical_depths(2,:,1) = (/ 90.0, 80.0, 70.0 /) + optical_depths(2,:,2) = (/ 75.0, 85.0, 95.0 /) + single_scattering_albedos(2,:,1) = (/ 900.0, 800.0, 700.0 /) + single_scattering_albedos(2,:,2) = (/ 750.0, 850.0, 950.0 /) + asymmetry_factors(2,:,1,1) = (/ 9.0, 8.0, 7.0 /) + asymmetry_factors(2,:,2,1) = (/ 5.0, 4.0, 3.0 /) + + call radiator_copy%set_optical_depths( optical_depths(2,:,:), error ) + call radiator_copy%set_single_scattering_albedos( single_scattering_albedos(2,:,:), error ) + call radiator_copy%set_asymmetry_factors( asymmetry_factors(2,:,:,:), error ) + ASSERT( error%is_success() ) + + optical_depths(:,:,:) = 0.0 + single_scattering_albedos(:,:,:) = 0.0 + asymmetry_factors(:,:,:,:) = 0.0 + + call radiator%get_optical_depths( optical_depths(2,:,:), error ) + ASSERT( error%is_success() ) + ASSERT_EQ( optical_depths(2,1,1), 90.0 ) + ASSERT_EQ( optical_depths(2,2,1), 80.0 ) + ASSERT_EQ( optical_depths(2,3,1), 70.0 ) + ASSERT_EQ( optical_depths(2,1,2), 75.0 ) + ASSERT_EQ( optical_depths(2,2,2), 85.0 ) + ASSERT_EQ( optical_depths(2,3,2), 95.0 ) + + call radiator%get_single_scattering_albedos( single_scattering_albedos(2,:,:), error ) + ASSERT( error%is_success() ) + ASSERT_EQ( single_scattering_albedos(2,1,1), 900.0 ) + ASSERT_EQ( single_scattering_albedos(2,2,1), 800.0 ) + ASSERT_EQ( single_scattering_albedos(2,3,1), 700.0 ) + ASSERT_EQ( single_scattering_albedos(2,1,2), 750.0 ) + ASSERT_EQ( single_scattering_albedos(2,2,2), 850.0 ) + ASSERT_EQ( single_scattering_albedos(2,3,2), 950.0 ) + + call radiator%get_asymmetry_factors( asymmetry_factors(2,:,:,:), error ) + ASSERT( error%is_success() ) + ASSERT_EQ( asymmetry_factors(2,1,1,1), 9.0 ) + ASSERT_EQ( asymmetry_factors(2,2,1,1), 8.0 ) + ASSERT_EQ( asymmetry_factors(2,3,1,1), 7.0 ) + ASSERT_EQ( asymmetry_factors(2,1,2,1), 5.0 ) + ASSERT_EQ( asymmetry_factors(2,2,2,1), 4.0 ) + ASSERT_EQ( asymmetry_factors(2,3,2,1), 3.0 ) deallocate( grid ) deallocate( grids ) diff --git a/fortran/tuvx/grid.F90 b/fortran/tuvx/grid.F90 index db9b9563..2311ff08 100644 --- a/fortran/tuvx/grid.F90 +++ b/fortran/tuvx/grid.F90 @@ -157,7 +157,7 @@ integer function number_of_sections(this, error) result( n_sections ) use musica_util, only: error_t, error_t_c ! Arguments - class(grid_t), intent(inout) :: this + class(grid_t), intent(in) :: this type(error_t), intent(inout) :: error ! Local variables @@ -175,9 +175,9 @@ subroutine set_edges(this, edges, error) 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 + class(grid_t), intent(inout) :: this + real(dk), target, contiguous, intent(in) :: edges(:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -197,9 +197,9 @@ subroutine get_edges(this, edges, error) 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 + class(grid_t), intent(in) :: this + real(dk), target, contiguous, intent(out) :: edges(:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -219,9 +219,9 @@ subroutine set_midpoints(this, midpoints, error) 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 + class(grid_t), intent(inout) :: this + real(dk), target, contiguous, intent(in) :: midpoints(:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -241,9 +241,9 @@ subroutine get_midpoints(this, midpoints, error) 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 + class(grid_t), intent(in) :: this + real(dk), target, contiguous, intent(out) :: midpoints(:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c diff --git a/fortran/tuvx/profile.F90 b/fortran/tuvx/profile.F90 index 757a08fc..15bf6bb3 100644 --- a/fortran/tuvx/profile.F90 +++ b/fortran/tuvx/profile.F90 @@ -205,9 +205,9 @@ subroutine set_edge_values(this, edge_values, error) 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 + class(profile_t), intent(inout) :: this + real(dk), target, contiguous, intent(in) :: edge_values(:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -228,9 +228,9 @@ subroutine get_edge_values(this, edge_values, error) 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 + class(profile_t), intent(in) :: this + real(dk), target, contiguous, intent(out) :: edge_values(:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -251,9 +251,9 @@ subroutine set_midpoint_values(this, midpoint_values, error) 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 + class(profile_t), intent(inout) :: this + real(dk), target, contiguous, intent(in) :: midpoint_values(:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -274,9 +274,9 @@ subroutine get_midpoint_values(this, midpoint_values, error) 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 + class(profile_t), intent(in) :: this + real(dk), target, contiguous, intent(out) :: midpoint_values(:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -297,9 +297,9 @@ subroutine set_layer_densities(this, layer_densities, error) 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 + class(profile_t), intent(inout) :: this + real(dk), target, contiguous, intent(in) :: layer_densities(:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -320,9 +320,9 @@ subroutine get_layer_densities(this, layer_densities, error) 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 + class(profile_t), intent(in) :: this + real(dk), target, contiguous, intent(out) :: layer_densities(:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -383,7 +383,7 @@ function get_exo_layer_density(this, error) result(exo_layer_density) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(profile_t), intent(inout) :: this + class(profile_t), intent(in) :: this type(error_t), intent(inout) :: error ! Return value diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index 60a79ee6..9ebd0b27 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -182,9 +182,9 @@ subroutine set_optical_depths(this, optical_depths, error) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:), intent(in) :: optical_depths - type(error_t), intent(inout) :: error + class(radiator_t), intent(inout) :: this + real(dk), target, contiguous, intent(in) :: optical_depths(:,:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -207,9 +207,9 @@ subroutine get_optical_depths(this, optical_depths, error) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:), intent(in) :: optical_depths - type(error_t), intent(inout) :: error + class(radiator_t), intent(in) :: this + real(dk), target, contiguous, intent(out) :: optical_depths(:,:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -233,9 +233,9 @@ subroutine set_single_scattering_albedos(this, single_scattering_albedos, & use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos - type(error_t), intent(inout) :: error + class(radiator_t), intent(inout) :: this + real(dk), target, contiguous, intent(in) :: single_scattering_albedos(:,:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -260,9 +260,9 @@ subroutine get_single_scattering_albedos(this, single_scattering_albedos, & use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos - type(error_t), intent(inout) :: error + class(radiator_t), intent(in) :: this + real(dk), target, contiguous, intent(out) :: single_scattering_albedos(:,:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -286,9 +286,9 @@ subroutine set_asymmetry_factors(this, asymmetry_factors, error) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:,:), intent(in) :: asymmetry_factors - type(error_t), intent(inout) :: error + class(radiator_t), intent(inout) :: this + real(dk), target, contiguous, intent(in) :: asymmetry_factors(:,:,:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -313,9 +313,9 @@ subroutine get_asymmetry_factors(this, asymmetry_factors, error) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this - real(dk), target, dimension(:,:,:), intent(in) :: asymmetry_factors - type(error_t), intent(inout) :: error + class(radiator_t), intent(in) :: this + real(dk), target, contiguous, intent(out) :: asymmetry_factors(:,:,:) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c diff --git a/fortran/tuvx/tuvx.F90 b/fortran/tuvx/tuvx.F90 index d5c2ca2f..d17a5126 100644 --- a/fortran/tuvx/tuvx.F90 +++ b/fortran/tuvx/tuvx.F90 @@ -285,12 +285,12 @@ subroutine run(this, solar_zenith_angle, earth_sun_distance, & use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(tuvx_t), intent(inout) :: this - real(kind=dk), intent(in) :: solar_zenith_angle ! radians - real(kind=dk), intent(in) :: earth_sun_distance ! AU - real(kind=dk), target, intent(inout) :: photolysis_rate_constants(:,:) ! s-1 (layer, reaction) - real(kind=dk), target, intent(inout) :: heating_rates(:,:) ! K s-1 (layer, reaction) - type(error_t), intent(inout) :: error + class(tuvx_t), intent(inout) :: this + real(kind=dk), intent(in) :: solar_zenith_angle ! radians + real(kind=dk), intent(in) :: earth_sun_distance ! AU + real(kind=dk), target, contiguous, intent(inout) :: photolysis_rate_constants(:,:) ! s-1 (layer, reaction) + real(kind=dk), target, contiguous, intent(inout) :: heating_rates(:,:) ! K s-1 (layer, reaction) + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c diff --git a/fortran/util.F90 b/fortran/util.F90 index 14f97a5b..fda31594 100644 --- a/fortran/util.F90 +++ b/fortran/util.F90 @@ -747,9 +747,9 @@ subroutine copy_data( this, source, target ) use iso_c_binding, only: c_loc - class(index_mappings_t), intent(inout) :: this - real(kind=musica_dk), target, intent(in) :: source(:) - real(kind=musica_dk), target, intent(in) :: target(:) + class(index_mappings_t), intent(inout) :: this + real(kind=musica_dk), target, contiguous, intent(in) :: source(:) + real(kind=musica_dk), target, contiguous, intent(in) :: target(:) call copy_data_c( this%mappings_c_, c_loc( source ), c_loc( target ) )