From 52ea1b943285b74979ec4e9d436f4a76d09a63a1 Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 14 Jul 2026 12:25:40 +0100 Subject: [PATCH 01/22] Spawn branch From af9e0af2cc419e38278f0471629d6b061d569c4c Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 14 Jul 2026 19:54:47 +0100 Subject: [PATCH 02/22] Converted atl_vorticity_advection into source code --- .../atlt_vorticity_advection_alg_mod.x90 | 170 ++++++++++++ .../source/driver/adjoint_test_driver_mod.f90 | 4 + .../adjoint/build/psyad_files_list_apps.txt | 1 - science/adjoint/build/psyad_vars.mk | 3 - .../atlt_vorticity_advection_alg_mod.patch | 162 ------------ .../atl_vorticity_advection_kernel_mod.patch | 63 ----- .../tl_vorticity_advection_kernel_mod.patch | 77 ------ .../atl_vorticity_advection_kernel_mod.F90 | 249 ++++++++++++++++++ 8 files changed, 423 insertions(+), 306 deletions(-) create mode 100644 applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 delete mode 100644 science/adjoint/patches/algorithm/atlt_vorticity_advection_alg_mod.patch delete mode 100644 science/adjoint/patches/kernel/atl_vorticity_advection_kernel_mod.patch delete mode 100644 science/adjoint/patches/kernel/tl_vorticity_advection_kernel_mod.patch create mode 100644 science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 diff --git a/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 new file mode 100644 index 0000000000..7aab8c7067 --- /dev/null +++ b/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 @@ -0,0 +1,170 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> @brief Module containing adjoint test for atl_vorticity_advection_kernel +module atlt_vorticity_advection_alg_mod + + use config_mod, only : config_type + use field_mod, only : field_type + use function_space_mod, only : function_space_type + use mesh_mod, only : mesh_type + use function_space_collection_mod, only : function_space_collection + use fs_continuity_mod, only : W1, W2, W3 + use constants_mod, only : i_def, r_def, EPS + use quadrature_rule_gaussian_mod, only : quadrature_rule_gaussian_type + use quadrature_xyoz_mod, only : quadrature_xyoz_type + use log_mod, only : log_event, & + log_scratch_space, & + LOG_LEVEL_ERROR, & + LOG_LEVEL_INFO, & + LOG_LEVEL_DEBUG + + + implicit none + public + + contains + !============================================================================= + !> @brief Adjoint test for atl_vorticity_advection. + !> @details Passes if adjoint is transpose of tangent linear. + !> Determined by testing the equality of inner products and , + !> where M is the tangent linear and A is the adjoint. + !> @param[in] config Application namelist configuration object + !> @param[in] mesh Mesh object + !> @param[in] chi Coordinate field + !> @param[in] panel_id The panel id + subroutine atlt_vorticity_advection_alg(config, mesh, chi, panel_id) + + use tl_vorticity_advection_kernel_mod, only : tl_vorticity_advection_kernel_type + use atl_vorticity_advection_kernel_mod, only : atl_vorticity_advection_kernel_type + + implicit none + + ! Arguments + type(config_type), intent(in) :: config + type(mesh_type), pointer, intent(in) :: mesh + type(field_type), dimension(3), intent(in) :: chi + type(field_type), intent(in) :: panel_id + + ! Arguments for tl and adj calls + type(field_type) :: r_u + type(field_type) :: wind + type(field_type) :: vorticity + type(field_type) :: ls_wind + type(field_type) :: ls_vorticity + type(quadrature_xyoz_type) :: qr_xyoz + type(quadrature_rule_gaussian_type) :: quadrature_rule + + ! Copies of input fields used in inner products + type(field_type) :: r_u_input + type(field_type) :: wind_input + type(field_type) :: vorticity_input + + ! Variables for initialising fields + type(function_space_type), pointer :: vector_space_w1_ptr + type(function_space_type), pointer :: vector_space_w2_ptr + type(function_space_type), pointer :: vector_space_w3_ptr + integer(kind=i_def) :: element_order_h + integer(kind=i_def) :: element_order_v + + ! Inner products + real(kind=r_def) :: r_u_inner_prod + real(kind=r_def) :: wind_inner_prod + real(kind=r_def) :: vorticity_inner_prod + real(kind=r_def) :: r_u_sf + real(kind=r_def) :: wind_sf + real(kind=r_def) :: vorticity_sf + real(kind=r_def) :: inner1 + real(kind=r_def) :: r_u_r_u_input_inner_prod + real(kind=r_def) :: wind_wind_input_inner_prod + real(kind=r_def) :: vorticity_vorticity_input_inner_prod + real(kind=r_def) :: inner2 + + ! Test parameters and variables + real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def + real(kind=r_def) :: machine_tol + real(kind=r_def) :: relative_diff + + element_order_h = config%finite_element%element_order_h() + element_order_v = config%finite_element%element_order_v() + vector_space_w1_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W1) + vector_space_w2_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W2) + vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W3) + call r_u%initialise(vector_space=vector_space_w2_ptr, name='r_u') + call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') + call vorticity%initialise(vector_space=vector_space_w1_ptr, name='vorticity') + call ls_wind%initialise(vector_space=vector_space_w2_ptr, name='ls_wind') + call ls_vorticity%initialise(vector_space=vector_space_w1_ptr, name='ls_vorticity') + qr_xyoz = quadrature_xyoz_type(element_order_h + 3, element_order_h + 3, element_order_v + 3, quadrature_rule) + call r_u_input%initialise(vector_space=vector_space_w2_ptr, name='r_u_input') + call wind_input%initialise(vector_space=vector_space_w2_ptr, name='wind_input') + call vorticity_input%initialise(vector_space=vector_space_w1_ptr, name='vorticity_input') + r_u_inner_prod = 0.0_r_def + wind_inner_prod = 0.0_r_def + vorticity_inner_prod = 0.0_r_def + + ! Initialise arguments and call the tangent-linear kernel. + call invoke( setval_random(r_u), setval_x(r_u_input, r_u), & + setval_random(wind), setval_x(wind_input, wind), & + setval_random(vorticity), setval_x(vorticity_input, vorticity), & + setval_random(ls_wind), setval_random(ls_vorticity), & + tl_vorticity_advection_kernel_type(r_u, wind, vorticity, & + ls_wind, ls_vorticity, & + chi, panel_id, qr_xyoz), & + x_innerproduct_x(r_u_inner_prod, r_u), & + x_innerproduct_x(wind_inner_prod, wind), & + x_innerproduct_x(vorticity_inner_prod, vorticity) ) + + write( log_scratch_space, * ) "atlt_vorticity_advection inner products:" + call log_event( log_scratch_space, log_level_debug ) + write( log_scratch_space, * ) "r_u inner product = ", r_u_inner_prod + call log_event( log_scratch_space, log_level_debug ) + write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod + call log_event( log_scratch_space, log_level_debug ) + write( log_scratch_space, * ) "vorticity inner product = ", vorticity_inner_prod + call log_event( log_scratch_space, log_level_debug ) + + r_u_sf = 1.0_r_def / (r_u_inner_prod + EPS) + wind_sf = 1.0_r_def / (wind_inner_prod + EPS) + vorticity_sf = 1.0_r_def / (vorticity_inner_prod + EPS) + + inner1 = 0.0_r_def + inner1 = inner1 + r_u_inner_prod * r_u_sf + inner1 = inner1 + wind_inner_prod * wind_sf + inner1 = inner1 + vorticity_inner_prod * vorticity_sf + + r_u_r_u_input_inner_prod = 0.0_r_def + wind_wind_input_inner_prod = 0.0_r_def + vorticity_vorticity_input_inner_prod = 0.0_r_def + call invoke( inc_a_times_X( r_u_sf, r_u ), & + inc_a_times_X( wind_sf, wind ), & + inc_a_times_X( vorticity_sf, vorticity ), & + atl_vorticity_advection_kernel_type(r_u, wind, vorticity, & + ls_wind, ls_vorticity, & + chi, panel_id, qr_xyoz), & + x_innerproduct_y(r_u_r_u_input_inner_prod, r_u, r_u_input), & + x_innerproduct_y(wind_wind_input_inner_prod, wind, wind_input), & + x_innerproduct_y(vorticity_vorticity_input_inner_prod, & + vorticity, vorticity_input) ) + + inner2 = 0.0_r_def + inner2 = inner2 + r_u_r_u_input_inner_prod + inner2 = inner2 + wind_wind_input_inner_prod + inner2 = inner2 + vorticity_vorticity_input_inner_prod + + ! Test the inner-product values for equality, allowing for the precision of the active variables + machine_tol = spacing(max(abs(inner1), abs(inner2))) + relative_diff = abs(inner1 - inner2) / machine_tol + if (relative_diff < overall_tolerance) then + write(log_scratch_space, *) "PASSED tl_vorticity_advection_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_INFO) + else + write(log_scratch_space, *) "FAILED tl_vorticity_advection_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_ERROR) + end if + + end subroutine atlt_vorticity_advection_alg + +end module atlt_vorticity_advection_alg_mod diff --git a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 index f5ad2b2693..be42908655 100644 --- a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 +++ b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 @@ -77,6 +77,7 @@ subroutine run( modeldb ) use adjt_end_transport_step_alg_mod, only : adjt_build_up_flux_alg use atlt_end_transport_step_alg_mod, only : atlt_end_adv_step_alg, & atlt_end_con_step_alg + use atlt_vorticity_advection_alg_mod, only : atlt_vorticity_advection_alg ! ./transport/mol use atlt_reconstruct_w3_field_alg_mod, only : atlt_vert_w3_reconstruct_alg, & @@ -154,6 +155,9 @@ subroutine run( modeldb ) call log_event( "TESTING adjoint kernels", LOG_LEVEL_INFO ) + !./transport/common + call atlt_vorticity_advection_alg( modeldb%config, mesh, chi, panel_id ) + ! ./transport/mol call atlt_poly_adv_update_alg( mesh ) call atlt_poly1d_vert_w3_recon_alg( modeldb%config, mesh ) diff --git a/science/adjoint/build/psyad_files_list_apps.txt b/science/adjoint/build/psyad_files_list_apps.txt index b827b9818c..9a915936f6 100644 --- a/science/adjoint/build/psyad_files_list_apps.txt +++ b/science/adjoint/build/psyad_files_list_apps.txt @@ -1,5 +1,4 @@ science/linear/source/kernel/transport/mol/tl_poly1d_vert_adv_kernel_mod.F90 -science/linear/source/kernel/transport/common/tl_vorticity_advection_kernel_mod.F90 science/linear/source/kernel/linear_physics/stabilise_bl_u_kernel_mod.F90 science/linear/source/kernel/transport/mol/tl_horizontal_mass_flux_kernel_mod.F90 science/linear/source/kernel/transport/mol/tl_vertical_mass_flux_kernel_mod.F90 diff --git a/science/adjoint/build/psyad_vars.mk b/science/adjoint/build/psyad_vars.mk index ecc14b6a4f..c039809dcc 100644 --- a/science/adjoint/build/psyad_vars.mk +++ b/science/adjoint/build/psyad_vars.mk @@ -6,9 +6,6 @@ # Active variables all: export ACTIVE_tl_poly_advective_kernel_mod := advective dtdx dtdy v u tracer wind all: export ACTIVE_tl_poly1d_vert_adv_kernel_mod := advective wind dpdz tracer -all: export ACTIVE_tl_vorticity_advection_kernel_mod := r_u wind vorticity vorticity_at_quad \ - u_at_quad j_vorticity vorticity_term \ - res_dot_product cross_product1 cross_product2 mul2 all: export ACTIVE_stabilise_bl_u_kernel_mod := u_stabilised u_initial u_final all: export ACTIVE_apply_mixed_lu_operator_kernel_mod := wind theta exner lhs_u lhs_t all: export ACTIVE_apply_mixed_operator_kernel_mod := u_e t_col lhs_p lhs_w lhs_uv exner wind_w wind_uv diff --git a/science/adjoint/patches/algorithm/atlt_vorticity_advection_alg_mod.patch b/science/adjoint/patches/algorithm/atlt_vorticity_advection_alg_mod.patch deleted file mode 100644 index 0f040a9533..0000000000 --- a/science/adjoint/patches/algorithm/atlt_vorticity_advection_alg_mod.patch +++ /dev/null @@ -1,162 +0,0 @@ -@@ -9,14 +9,14 @@ - use mesh_mod, only : mesh_type - use function_space_collection_mod, only : function_space_collection - use tl_vorticity_advection_kernel_mod, only : tl_vorticity_advection_kernel_type -- use adj_vorticity_advection_kernel_mod, only : adj_vorticity_advection_kernel_type -+ use atl_vorticity_advection_kernel_mod, only : atl_vorticity_advection_kernel_type - use finite_element_config_mod, only : element_order_h, element_order_v - use fs_continuity_mod, only : w1, w2, w3, wchi - use quadrature_xyoz_mod, only : quadrature_xyoz_type - use constants_mod, only : i_def, r_def - use quadrature_rule_gaussian_mod, only : quadrature_rule_gaussian_type - use setop_random_kernel_mod, only : setop_random_kernel_type -- use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space -+ use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space, log_level_debug - real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def - type(mesh_type), pointer, intent(in) :: mesh - type(field_type), dimension(3), intent(in), optional :: chi -@@ -30,35 +30,25 @@ - type(field_type) :: vorticity - type(field_type) :: ls_wind - type(field_type) :: ls_vorticity -- type(field_type), dimension(3) :: chi_3 -- type(field_type) :: panel_id_1 - type(quadrature_xyoz_type) :: qr_xyoz - type(quadrature_rule_gaussian_type) :: quadrature_rule - type(field_type) :: r_u_input - type(field_type) :: wind_input - type(field_type) :: vorticity_input -- type(field_type) :: ls_wind_input -- type(field_type) :: ls_vorticity_input -- type(field_type), dimension(3) :: chi_3_input -- type(field_type) :: panel_id_1_input - real(kind=r_def) :: r_u_inner_prod - real(kind=r_def) :: wind_inner_prod - real(kind=r_def) :: vorticity_inner_prod -- real(kind=r_def) :: ls_wind_inner_prod -- real(kind=r_def) :: ls_vorticity_inner_prod -- real(kind=r_def), dimension(3) :: chi_3_inner_prod -- real(kind=r_def) :: panel_id_1_inner_prod -+ real(kind=r_def) :: r_u_sf -+ real(kind=r_def) :: wind_sf -+ real(kind=r_def) :: vorticity_sf - real(kind=r_def) :: inner1 - real(kind=r_def) :: r_u_r_u_input_inner_prod - real(kind=r_def) :: wind_wind_input_inner_prod - real(kind=r_def) :: vorticity_vorticity_input_inner_prod -- real(kind=r_def) :: ls_wind_ls_wind_input_inner_prod -- real(kind=r_def) :: ls_vorticity_ls_vorticity_input_inner_prod -- real(kind=r_def), dimension(3) :: chi_3_chi_3_input_inner_prod -- real(kind=r_def) :: panel_id_1_panel_id_1_input_inner_prod - real(kind=r_def) :: inner2 - real(kind=r_def) :: MachineTol - real(kind=r_def) :: relative_diff -+ real(kind=r_def), parameter :: eps = 1.0e-30_r_def - - vector_space_w1_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w1) - vector_space_w2_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w2) -@@ -69,81 +59,47 @@ - call vorticity%initialise(vector_space=vector_space_w1_ptr, name='vorticity') - call ls_wind%initialise(vector_space=vector_space_w2_ptr, name='ls_wind') - call ls_vorticity%initialise(vector_space=vector_space_w1_ptr, name='ls_vorticity') -- call chi_3(1_i_def)%initialise(vector_space=vector_space_wchi_ptr, name='chi_3') -- call chi_3(2_i_def)%initialise(vector_space=vector_space_wchi_ptr, name='chi_3') -- call chi_3(3_i_def)%initialise(vector_space=vector_space_wchi_ptr, name='chi_3') -- call panel_id_1%initialise(vector_space=vector_space_w3_ptr, name='panel_id_1') - qr_xyoz = quadrature_xyoz_type(element_order_h + 3, element_order_h + 3, element_order_v + 3, quadrature_rule) - call r_u_input%initialise(vector_space=vector_space_w2_ptr, name='r_u_input') - call wind_input%initialise(vector_space=vector_space_w2_ptr, name='wind_input') - call vorticity_input%initialise(vector_space=vector_space_w1_ptr, name='vorticity_input') -- call ls_wind_input%initialise(vector_space=vector_space_w2_ptr, name='ls_wind_input') -- call ls_vorticity_input%initialise(vector_space=vector_space_w1_ptr, name='ls_vorticity_input') -- call chi_3_input(1_i_def)%initialise(vector_space=vector_space_wchi_ptr, name='chi_3_input') -- call chi_3_input(2_i_def)%initialise(vector_space=vector_space_wchi_ptr, name='chi_3_input') -- call chi_3_input(3_i_def)%initialise(vector_space=vector_space_wchi_ptr, name='chi_3_input') -- call panel_id_1_input%initialise(vector_space=vector_space_w3_ptr, name='panel_id_1_input') - r_u_inner_prod = 0.0_r_def - wind_inner_prod = 0.0_r_def - vorticity_inner_prod = 0.0_r_def -- ls_wind_inner_prod = 0.0_r_def -- ls_vorticity_inner_prod = 0.0_r_def -- chi_3_inner_prod(1_i_def) = 0.0_r_def -- chi_3_inner_prod(2_i_def) = 0.0_r_def -- chi_3_inner_prod(3_i_def) = 0.0_r_def -- panel_id_1_inner_prod = 0.0_r_def -- - ! Initialise arguments and call the tangent-linear kernel. - call invoke(setval_random(r_u), setval_x(r_u_input, r_u), setval_random(wind), setval_x(wind_input, wind), & --&setval_random(vorticity), setval_x(vorticity_input, vorticity), setval_random(ls_wind), setval_x(ls_wind_input, ls_wind), & --&setval_random(ls_vorticity), setval_x(ls_vorticity_input, ls_vorticity), setval_random(chi_3(1_i_def)), & --&setval_x(chi_3_input(1_i_def), chi_3(1_i_def)), setval_random(chi_3(2_i_def)), setval_x(chi_3_input(2_i_def), chi_3(2_i_def)), & --&setval_random(chi_3(3_i_def)), setval_x(chi_3_input(3_i_def), chi_3(3_i_def)), setval_random(panel_id_1), & --&setval_x(panel_id_1_input, panel_id_1), tl_vorticity_advection_kernel_type(r_u, wind, vorticity, ls_wind, ls_vorticity, chi_3, & --&panel_id_1, qr_xyoz), x_innerproduct_x(r_u_inner_prod, r_u), x_innerproduct_x(wind_inner_prod, wind), & --&x_innerproduct_x(vorticity_inner_prod, vorticity), x_innerproduct_x(ls_wind_inner_prod, ls_wind), & --&x_innerproduct_x(ls_vorticity_inner_prod, ls_vorticity), x_innerproduct_x(chi_3_inner_prod(1_i_def), chi_3(1_i_def)), & --&x_innerproduct_x(chi_3_inner_prod(2_i_def), chi_3(2_i_def)), x_innerproduct_x(chi_3_inner_prod(3_i_def), chi_3(3_i_def)), & --&x_innerproduct_x(panel_id_1_inner_prod, panel_id_1)) -+&setval_random(vorticity), setval_x(vorticity_input, vorticity), setval_random(ls_wind), & -+&setval_random(ls_vorticity), tl_vorticity_advection_kernel_type(r_u, wind, vorticity, ls_wind, ls_vorticity, chi, & -+&panel_id, qr_xyoz), x_innerproduct_x(r_u_inner_prod, r_u), x_innerproduct_x(wind_inner_prod, wind), & -+&x_innerproduct_x(vorticity_inner_prod, vorticity)) -+ write( log_scratch_space, * ) "atlt_vorticity_advection inner products:" -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "r_u inner product = ", r_u_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "vorticity inner product = ", vorticity_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ r_u_sf = 1.0_r_def / (r_u_inner_prod + eps) -+ wind_sf = 1.0_r_def / (wind_inner_prod + eps) -+ vorticity_sf = 1.0_r_def / (vorticity_inner_prod + eps) - inner1 = 0.0_r_def -- inner1 = inner1 + r_u_inner_prod -- inner1 = inner1 + wind_inner_prod -- inner1 = inner1 + vorticity_inner_prod -- inner1 = inner1 + ls_wind_inner_prod -- inner1 = inner1 + ls_vorticity_inner_prod -- inner1 = inner1 + chi_3_inner_prod(1_i_def) -- inner1 = inner1 + chi_3_inner_prod(2_i_def) -- inner1 = inner1 + chi_3_inner_prod(3_i_def) -- inner1 = inner1 + panel_id_1_inner_prod -+ inner1 = inner1 + r_u_inner_prod * r_u_sf -+ inner1 = inner1 + wind_inner_prod * wind_sf -+ inner1 = inner1 + vorticity_inner_prod * vorticity_sf -+ call invoke( inc_a_times_X( r_u_sf, r_u ), & -+ inc_a_times_X( wind_sf, wind ), & -+ inc_a_times_X( vorticity_sf, vorticity ) ) - r_u_r_u_input_inner_prod = 0.0_r_def - wind_wind_input_inner_prod = 0.0_r_def - vorticity_vorticity_input_inner_prod = 0.0_r_def -- ls_wind_ls_wind_input_inner_prod = 0.0_r_def -- ls_vorticity_ls_vorticity_input_inner_prod = 0.0_r_def -- chi_3_chi_3_input_inner_prod(1_i_def) = 0.0_r_def -- chi_3_chi_3_input_inner_prod(2_i_def) = 0.0_r_def -- chi_3_chi_3_input_inner_prod(3_i_def) = 0.0_r_def -- panel_id_1_panel_id_1_input_inner_prod = 0.0_r_def -- call invoke(adj_vorticity_advection_kernel_type(r_u, wind, vorticity, ls_wind, ls_vorticity, chi_3, panel_id_1, qr_xyoz), & -+ call invoke(atl_vorticity_advection_kernel_type(r_u, wind, vorticity, ls_wind, ls_vorticity, chi, panel_id, qr_xyoz), & - &x_innerproduct_y(r_u_r_u_input_inner_prod, r_u, r_u_input), x_innerproduct_y(wind_wind_input_inner_prod, wind, wind_input), & --&x_innerproduct_y(vorticity_vorticity_input_inner_prod, vorticity, vorticity_input), & --&x_innerproduct_y(ls_wind_ls_wind_input_inner_prod, ls_wind, ls_wind_input), & --&x_innerproduct_y(ls_vorticity_ls_vorticity_input_inner_prod, ls_vorticity, ls_vorticity_input), & --&x_innerproduct_y(chi_3_chi_3_input_inner_prod(1_i_def), chi_3(1_i_def), chi_3_input(1_i_def)), & --&x_innerproduct_y(chi_3_chi_3_input_inner_prod(2_i_def), chi_3(2_i_def), chi_3_input(2_i_def)), & --&x_innerproduct_y(chi_3_chi_3_input_inner_prod(3_i_def), chi_3(3_i_def), chi_3_input(3_i_def)), & --&x_innerproduct_y(panel_id_1_panel_id_1_input_inner_prod, panel_id_1, panel_id_1_input)) -+&x_innerproduct_y(vorticity_vorticity_input_inner_prod, vorticity, vorticity_input)) - inner2 = 0.0_r_def - inner2 = inner2 + r_u_r_u_input_inner_prod - inner2 = inner2 + wind_wind_input_inner_prod - inner2 = inner2 + vorticity_vorticity_input_inner_prod -- inner2 = inner2 + ls_wind_ls_wind_input_inner_prod -- inner2 = inner2 + ls_vorticity_ls_vorticity_input_inner_prod -- inner2 = inner2 + chi_3_chi_3_input_inner_prod(1_i_def) -- inner2 = inner2 + chi_3_chi_3_input_inner_prod(2_i_def) -- inner2 = inner2 + chi_3_chi_3_input_inner_prod(3_i_def) -- inner2 = inner2 + panel_id_1_panel_id_1_input_inner_prod -- - ! Test the inner-product values for equality, allowing for the precision of the active variables - MachineTol = SPACING(MAX(ABS(inner1), ABS(inner2))) - relative_diff = ABS(inner1 - inner2) / MachineTol diff --git a/science/adjoint/patches/kernel/atl_vorticity_advection_kernel_mod.patch b/science/adjoint/patches/kernel/atl_vorticity_advection_kernel_mod.patch deleted file mode 100644 index 20441d4ed7..0000000000 --- a/science/adjoint/patches/kernel/atl_vorticity_advection_kernel_mod.patch +++ /dev/null @@ -1,63 +0,0 @@ -@@ -1,37 +1,37 @@ --module adj_vorticity_advection_kernel_mod -+module atl_vorticity_advection_kernel_mod - use kernel_mod, only : kernel_type - use argument_mod, only : any_discontinuous_space_3, any_space_9, arg_type, cell_column, func_type, gh_basis, gh_diff_basis, & - &gh_field, gh_inc, gh_quadrature_xyoz, gh_read, gh_real - use constants_mod, only : i_def, r_def -- use fs_continuity_mod, only : w1, w2, wchi -+ use fs_continuity_mod, only : w1, w2 - use cross_product_mod, only : cross_product - use base_mesh_config_mod, only : geometry, topology - use finite_element_config_mod, only : coord_system - use planet_config_mod, only : scaled_radius - implicit none -- type, public, extends(kernel_type) :: adj_vorticity_advection_kernel_type -+ type, public, extends(kernel_type) :: atl_vorticity_advection_kernel_type - type(ARG_TYPE) :: META_ARGS(7) = (/ & - arg_type(gh_field, gh_real, gh_read, w2), & - arg_type(gh_field, gh_real, gh_inc, w2), & - arg_type(gh_field, gh_real, gh_inc, w1), & - arg_type(gh_field, gh_real, gh_read, w2), & - arg_type(gh_field, gh_real, gh_read, w1), & -- arg_type(gh_field*3, gh_real, gh_read, wchi), & -+ arg_type(gh_field*3, gh_real, gh_read, any_space_9), & - arg_type(gh_field, gh_real, gh_read, any_discontinuous_space_3)/) - type(FUNC_TYPE) :: META_FUNCS(3) = (/ & - func_type(w2, gh_basis), & - func_type(w1, gh_basis), & -- func_type(wchi, gh_basis, gh_diff_basis)/) -+ func_type(any_space_9, gh_basis, gh_diff_basis)/) - INTEGER :: GH_SHAPE = gh_quadrature_xyoz - INTEGER :: OPERATES_ON = cell_column - CONTAINS -- PROCEDURE, NOPASS :: adj_vorticity_advection_code --END TYPE adj_vorticity_advection_kernel_type -+ PROCEDURE, NOPASS :: atl_vorticity_advection_code -+END TYPE atl_vorticity_advection_kernel_type - - public - - contains -- subroutine adj_vorticity_advection_code(nlayers, r_u, wind, vorticity, ls_wind, ls_vorticity, chi_1, chi_2, chi_3, panel_id, & -+ subroutine atl_vorticity_advection_code(nlayers, r_u, wind, vorticity, ls_wind, ls_vorticity, chi_1, chi_2, chi_3, panel_id, & - &ndf_w2, undf_w2, map_w2, w2_basis, ndf_w1, undf_w1, map_w1, w1_basis, ndf_chi, undf_chi, map_chi, chi_basis, chi_diff_basis, & - &ndf_pid, undf_pid, map_pid, nqp_h, nqp_v, wqp_h, wqp_v) - use sci_coordinate_jacobian_mod, only : pointwise_coordinate_jacobian, pointwise_coordinate_jacobian_inverse -@@ -89,7 +89,6 @@ - real(kind=r_def), dimension(3) :: mul2 - real(kind=r_def), dimension(3) :: cross_product1 - real(kind=r_def), dimension(3) :: cross_product2 -- integer :: i - real(kind=r_def) :: res_dot_product - integer :: idx - integer :: idx_1 -@@ -210,6 +209,6 @@ - enddo - enddo - -- end subroutine adj_vorticity_advection_code -+ end subroutine atl_vorticity_advection_code - --end module adj_vorticity_advection_kernel_mod -+end module atl_vorticity_advection_kernel_mod diff --git a/science/adjoint/patches/kernel/tl_vorticity_advection_kernel_mod.patch b/science/adjoint/patches/kernel/tl_vorticity_advection_kernel_mod.patch deleted file mode 100644 index 1de1337304..0000000000 --- a/science/adjoint/patches/kernel/tl_vorticity_advection_kernel_mod.patch +++ /dev/null @@ -1,77 +0,0 @@ -@@ -20,7 +20,7 @@ - GH_BASIS, GH_DIFF_BASIS, & - CELL_COLUMN, GH_QUADRATURE_XYoZ - use constants_mod, only: r_def, i_def --use fs_continuity_mod, only: W1, W2 -+use fs_continuity_mod, only: W1, W2, Wchi - use cross_product_mod, only: cross_product - - implicit none -@@ -37,13 +37,13 @@ - arg_type(GH_FIELD, GH_REAL, GH_READ, W1), & - arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & - arg_type(GH_FIELD, GH_REAL, GH_READ, W1), & -- arg_type(GH_FIELD*3, GH_REAL, GH_READ, ANY_SPACE_9), & -- arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3) & -+ arg_type(GH_FIELD*3, GH_REAL, GH_READ, WChi), & -+ arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3) & - /) - type(func_type) :: meta_funcs(3) = (/ & - func_type(W2, GH_BASIS), & - func_type(W1, GH_BASIS), & -- func_type(ANY_SPACE_9, GH_BASIS, GH_DIFF_BASIS) & -+ func_type(WChi, GH_BASIS, GH_DIFF_BASIS) & - /) - integer :: operates_on = CELL_COLUMN - integer :: gh_shape = GH_QUADRATURE_XYoZ -@@ -162,6 +162,11 @@ - j_vorticity, j_ls_vorticity, & - vorticity_term - -+ real(kind=r_def), dimension(3,3) :: jac_inv_transpose -+ -+ real(kind=r_def), dimension(3) :: mul1, mul2, & -+ cross_product1, cross_product2 -+ - ipanel = int(panel_id(map_pid(1)), i_def) - - do k = 0, nlayers-1 -@@ -187,7 +192,8 @@ - ipanel, chi_basis(:,:,qp1,qp2), & - chi_diff_basis(:,:,qp1,qp2), jac, dj) - jac_inv = pointwise_coordinate_jacobian_inverse(jac, dj) -- jac = matmul(jac_inv,transpose(jac_inv)) -+ jac_inv_transpose = transpose(jac_inv) -+ jac = matmul(jac_inv,jac_inv_transpose) - - ! Linearisation state - ls_vorticity_at_quad(:) = 0.0_r_def -@@ -218,14 +224,22 @@ - end do - - ! Calculation -- j_ls_vorticity = wqp_h(qp1) * wqp_v(qp2) * & -- matmul( jac, ls_vorticity_at_quad ) -+ mul1 = matmul( jac, ls_vorticity_at_quad ) -+ j_ls_vorticity(:) = wqp_h(qp1) * wqp_v(qp2) * mul1(:) -+ -+ mul2 = matmul( jac, vorticity_at_quad ) -+ j_vorticity(:) = wqp_h(qp1) * wqp_v(qp2) * mul2(:) - -- j_vorticity = wqp_h(qp1) * wqp_v(qp2) * & -- matmul( jac, vorticity_at_quad ) -+ ! inlined cross_product -+ cross_product1(1) = j_ls_vorticity(2)*u_at_quad(3) - j_ls_vorticity(3)*u_at_quad(2) -+ cross_product1(2) = j_ls_vorticity(3)*u_at_quad(1) - j_ls_vorticity(1)*u_at_quad(3) -+ cross_product1(3) = j_ls_vorticity(1)*u_at_quad(2) - j_ls_vorticity(2)*u_at_quad(1) -+ ! inlined cross_product -+ cross_product2(1) = j_vorticity(2)*u_ls_at_quad(3) - j_vorticity(3)*u_ls_at_quad(2) -+ cross_product2(2) = j_vorticity(3)*u_ls_at_quad(1) - j_vorticity(1)*u_ls_at_quad(3) -+ cross_product2(3) = j_vorticity(1)*u_ls_at_quad(2) - j_vorticity(2)*u_ls_at_quad(1) - -- vorticity_term = cross_product( j_ls_vorticity, u_at_quad ) + & -- cross_product( j_vorticity, u_ls_at_quad ) -+ vorticity_term(:) = cross_product1(:) + cross_product2(:) - - do df = 1, ndf_w2 - r_u( map_w2(df) + k ) = r_u( map_w2(df) + k ) & diff --git a/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 b/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 new file mode 100644 index 0000000000..e4adbadba4 --- /dev/null +++ b/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 @@ -0,0 +1,249 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +! +!> @brief Adjoint to the vorticity advection component +!> of the rhs of the momentum equation. +module atl_vorticity_advection_kernel_mod +use kernel_mod, only: kernel_type +use argument_mod, only: arg_type, func_type, & + GH_FIELD, GH_REAL, & + GH_READ, GH_INC, & + ANY_SPACE_9, & + ANY_DISCONTINUOUS_SPACE_3, & + GH_BASIS, GH_DIFF_BASIS, & + CELL_COLUMN, GH_QUADRATURE_XYoZ +use constants_mod, only: r_def, i_def +use fs_continuity_mod, only: W1, W2, Wchi + +use base_mesh_config_mod, only: geometry, topology +use finite_element_config_mod, only: coord_system +use planet_config_mod, only: scaled_radius + +implicit none + +!------------------------------------------------------------------------------- +! Public types +!------------------------------------------------------------------------------- +!> The type declaration for the kernel. Contains the metadata needed by the Psy layer +type, public, extends(kernel_type) :: atl_vorticity_advection_kernel_type + private + type(arg_type) :: meta_args(7) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & + arg_type(GH_FIELD, GH_REAL, GH_INC, W2), & + arg_type(GH_FIELD, GH_REAL, GH_INC, W1), & + arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & + arg_type(GH_FIELD, GH_REAL, GH_READ, W1), & + arg_type(GH_FIELD*3, GH_REAL, GH_READ, WChi), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3) & + /) + type(func_type) :: meta_funcs(3) = (/ & + func_type(W2, GH_BASIS), & + func_type(W1, GH_BASIS), & + func_type(WChi, GH_BASIS, GH_DIFF_BASIS) & + /) + integer :: operates_on = CELL_COLUMN + integer :: gh_shape = GH_QUADRATURE_XYoZ +contains + procedure, nopass :: atl_vorticity_advection_code +end type + +!------------------------------------------------------------------------------- +! Contained functions/subroutines +!------------------------------------------------------------------------------- +public atl_vorticity_advection_code +contains + +!> @brief Compute the adjoint for vorticity advection. +!! @param[in] nlayers Number of layers +!! @param[in] r_u ACTIVE Change in right hand side of the mom equation +!! @param[inout] wind ACTIVE Change in advecting wind field +!! @param[inout] vorticity ACTIVE Change in vorticity field = curl(u) +!! @param[in] ls_wind Lin state advecting wind field +!! @param[in] ls_vorticity Lin state vorticity field = curl(ls_u) +!! @param[in] chi_1 1st (spherical) coordinate field in Wchi +!! @param[in] chi_2 2nd (spherical) coordinate field in Wchi +!! @param[in] chi_3 3rd (spherical) coordinate field in Wchi +!! @param[in] panel_id Field giving the ID for mesh panels. +!! @param[in] ndf_w2 Number of degrees of freedom per cell for w2 +!! @param[in] undf_w2 Number of unique degrees of freedom for w2 +!! @param[in] map_w2 Dofmap for the cell at the base of the column for w2 +!! @param[in] w2_basis Basis functions evaluated at quadrature points +!! @param[in] ndf_w1 Number of degrees of freedom per cell for w1 +!! @param[in] undf_w1 Number of unique degrees of freedom for w1 +!! @param[in] map_w1 Dofmap for the cell at the base of the column for w1 +!! @param[in] w1_basis Basis functions evaluated at gaussian quadrature points +!! @param[in] ndf_chi Number of degrees of freedom per cell for chi +!! @param[in] undf_chi Number of unique degrees of freedom for chi +!! @param[in] map_chi Dofmap for the cell at the base of the column for chi +!! @param[in] chi_basis Wchi basis functions evaluated at gaussian quadrature points. +!! @param[in] chi_diff_basis Derivatives of Wchi basis functions +!! evaluated at gaussian quadrature points +!! @param[in] ndf_pid Number of degrees of freedom per cell for panel_id +!! @param[in] undf_pid Number of unique degrees of freedom for panel_id +!! @param[in] map_pid Dofmap for the cell at the base of the column for panel_id +!! @param[in] nqp_h Number of quadrature points in the horizontal +!! @param[in] nqp_v Number of quadrature points in the vertical +!! @param[in] wqp_h Horizontal quadrature weights +!! @param[in] wqp_v Vertical quadrature weights +subroutine atl_vorticity_advection_code(nlayers, & + r_u, & + wind, & + vorticity, & + ls_wind, & + ls_vorticity, & + chi_1, & + chi_2, & + chi_3, & + panel_id, & + ndf_w2, & + undf_w2, & + map_w2, & + w2_basis, & + ndf_w1, & + undf_w1, & + map_w1, & + w1_basis, & + ndf_chi, & + undf_chi, & + map_chi, & + chi_basis, & + chi_diff_basis, & + ndf_pid, & + undf_pid, & + map_pid, & + nqp_h, & + nqp_v, & + wqp_h, & + wqp_v & + ) + + use sci_coordinate_jacobian_mod, only: pointwise_coordinate_jacobian, & + pointwise_coordinate_jacobian_inverse + implicit none + + ! Arguments + integer, intent(in) :: nlayers,nqp_h, nqp_v + integer, intent(in) :: ndf_chi, ndf_w1, ndf_w2, ndf_pid + integer, intent(in) :: undf_chi, undf_w1, undf_w2, undf_pid + integer, dimension(ndf_chi), intent(in) :: map_chi + integer, dimension(ndf_w1), intent(in) :: map_w1 + integer, dimension(ndf_w2), intent(in) :: map_w2 + integer, dimension(ndf_pid), intent(in) :: map_pid + + real(kind=r_def), dimension(3,ndf_w2,nqp_h,nqp_v), intent(in) :: w2_basis + real(kind=r_def), dimension(3,ndf_w1,nqp_h,nqp_v), intent(in) :: w1_basis + real(kind=r_def), dimension(1,ndf_chi,nqp_h,nqp_v), intent(in) :: chi_basis + real(kind=r_def), dimension(3,ndf_chi,nqp_h,nqp_v), intent(in) :: chi_diff_basis + + real(kind=r_def), dimension(undf_w2), intent(in) :: r_u + real(kind=r_def), dimension(undf_w2), intent(inout) :: wind + real(kind=r_def), dimension(undf_w1), intent(inout) :: vorticity + real(kind=r_def), dimension(undf_w2), intent(in) :: ls_wind + real(kind=r_def), dimension(undf_w1), intent(in) :: ls_vorticity + real(kind=r_def), dimension(undf_chi), intent(in) :: chi_1, chi_2, chi_3 + real(kind=r_def), dimension(undf_pid), intent(in) :: panel_id + + real(kind=r_def), dimension(nqp_h), intent(in) :: wqp_h + real(kind=r_def), dimension(nqp_v), intent(in) :: wqp_v + + ! Internal variables + integer(kind=i_def) :: df, k, loc, ipanel + integer(kind=r_def) :: qp1, qp2 + + real(kind=r_def), dimension(ndf_chi) :: chi_1_e, chi_2_e, chi_3_e + real(kind=r_def) :: dj + real(kind=r_def), dimension(3,3) :: jac, jac_inv + real(kind=r_def), dimension(3) :: vorticity_at_quad, u_at_quad, & + ls_vorticity_at_quad, u_ls_at_quad, & + j_vorticity, j_ls_vorticity, & + vorticity_term + + ipanel = int(panel_id(map_pid(1)), i_def) + + do k = 0, nlayers-1 + ! Extract element arrays of chi + do df = 1, ndf_chi + loc = map_chi(df) + k + chi_1_e(df) = chi_1( loc ) + chi_2_e(df) = chi_2( loc ) + chi_3_e(df) = chi_3( loc ) + end do + + ! The nonlinear term is: + ! v.( [(J^-1 * J^-T) * vorticity] cross u ) + ! The corresponding linear term is: + ! v.( ( [(J^-1 * J^-T) * ls_vorticity] cross u ) + ! + ( [(J^-1 * J^-T) * vorticity] cross u_ls ) ) + + do qp2 = 1, nqp_v + do qp1 = 1, nqp_h + + ! Constants + call pointwise_coordinate_jacobian(coord_system, geometry, & + topology, scaled_radius, & + ndf_chi, chi_1_e, chi_2_e, chi_3_e, & + ipanel, chi_basis(:,:,qp1,qp2), & + chi_diff_basis(:,:,qp1,qp2), jac, dj) + jac_inv = pointwise_coordinate_jacobian_inverse(jac, dj) + jac = matmul(jac_inv,transpose(jac_inv)) + + ! Linearisation state + ls_vorticity_at_quad(:) = 0.0_r_def + do df = 1, ndf_w1 + ls_vorticity_at_quad(:) = ls_vorticity_at_quad(:) & + + ls_vorticity( map_w1(df) + k ) & + * w1_basis(:,df,qp1,qp2) + end do + u_ls_at_quad(:) = 0.0_r_def + do df = 1, ndf_w2 + u_ls_at_quad(:) = u_ls_at_quad(:) & + + ls_wind( map_w2(df) + k ) & + * w2_basis(:,df,qp1,qp2) + end do + + j_ls_vorticity(:) = wqp_h(qp1) * wqp_v(qp2) * matmul( jac, ls_vorticity_at_quad ) + + ! Perturbation + vorticity_term(:) = 0.0_r_def + do df = ndf_w2, 1, -1 + vorticity_term(:) = vorticity_term(:) - w2_basis(:,df,qp1,qp2) * r_u( map_w2(df) + k ) + end do + + j_vorticity(:) = 0.0_r_def + u_at_quad(:) = 0.0_r_def + j_vorticity(1) = j_vorticity(1) + vorticity_term(3) * u_ls_at_quad(2) + j_vorticity(2) = j_vorticity(2) - vorticity_term(3) * u_ls_at_quad(1) + u_at_quad(2) = u_at_quad(2) + vorticity_term(3) * j_ls_vorticity(1) + u_at_quad(1) = u_at_quad(1) - vorticity_term(3) * j_ls_vorticity(2) + + j_vorticity(3) = j_vorticity(3) + vorticity_term(2) * u_ls_at_quad(1) + j_vorticity(1) = j_vorticity(1) - vorticity_term(2) * u_ls_at_quad(3) + u_at_quad(1) = u_at_quad(1) + vorticity_term(2) * j_ls_vorticity(3) + u_at_quad(3) = u_at_quad(3) - vorticity_term(2) * j_ls_vorticity(1) + + j_vorticity(2) = j_vorticity(2) + vorticity_term(1) * u_ls_at_quad(3) + j_vorticity(3) = j_vorticity(3) - vorticity_term(1) * u_ls_at_quad(2) + u_at_quad(3) = u_at_quad(3) + vorticity_term(1) * j_ls_vorticity(2) + u_at_quad(2) = u_at_quad(2) - vorticity_term(1) * j_ls_vorticity(3) + + vorticity_at_quad = wqp_h(qp1) * wqp_v(qp2) * matmul( transpose(jac), j_vorticity ) + + do df = ndf_w2, 1, -1 + wind( map_w2(df) + k ) = wind( map_w2(df) + k ) & + + dot_product( u_at_quad, w2_basis(:,df,qp1,qp2) ) + end do + + do df = ndf_w1, 1, -1 + vorticity( map_w1(df) + k ) = vorticity( map_w1(df) + k ) & + + dot_product( vorticity_at_quad, w1_basis(:,df,qp1,qp2) ) + end do + end do + end do + end do + +end subroutine atl_vorticity_advection_code + +end module atl_vorticity_advection_kernel_mod From f69c8a4da596052e9ff3d3fe97865d4283f2c411 Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Wed, 15 Jul 2026 14:32:14 +0100 Subject: [PATCH 03/22] Added source code for atl_poly1d_vert_adv --- .../atlt_vorticity_advection_alg_mod.x90 | 10 +- .../mol/atlt_poly1d_vert_adv_alg_mod.x90 | 240 ++++++++++++++++++ .../source/driver/adjoint_test_driver_mod.f90 | 2 + .../adjoint/build/psyad_files_list_apps.txt | 1 - science/adjoint/build/psyad_vars.mk | 1 - .../mol/atl_poly1d_vert_adv_kernel_mod.F90 | 205 +++++++++++++++ 6 files changed, 453 insertions(+), 6 deletions(-) create mode 100644 applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 create mode 100644 science/adjoint/source/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod.F90 diff --git a/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 index 7aab8c7067..acc96bdba0 100644 --- a/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 @@ -23,7 +23,8 @@ module atlt_vorticity_advection_alg_mod implicit none - public + + public :: atlt_vorticity_advection_alg contains !============================================================================= @@ -98,9 +99,10 @@ module atlt_vorticity_advection_alg_mod call ls_wind%initialise(vector_space=vector_space_w2_ptr, name='ls_wind') call ls_vorticity%initialise(vector_space=vector_space_w1_ptr, name='ls_vorticity') qr_xyoz = quadrature_xyoz_type(element_order_h + 3, element_order_h + 3, element_order_v + 3, quadrature_rule) - call r_u_input%initialise(vector_space=vector_space_w2_ptr, name='r_u_input') - call wind_input%initialise(vector_space=vector_space_w2_ptr, name='wind_input') - call vorticity_input%initialise(vector_space=vector_space_w1_ptr, name='vorticity_input') + + call r_u%copy_field_properties(r_u_input) + call wind%copy_field_properties(wind_input) + call vorticity%copy_field_properties(vorticity_input) r_u_inner_prod = 0.0_r_def wind_inner_prod = 0.0_r_def vorticity_inner_prod = 0.0_r_def diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 new file mode 100644 index 0000000000..3b5ea4153b --- /dev/null +++ b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 @@ -0,0 +1,240 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> @brief Module containing adjoint test for atl_poly1d_vert_adv_kernel +module atlt_poly1d_vert_adv_alg_mod + + use config_mod, only : config_type + use field_mod, only : field_type + use function_space_mod, only : function_space_type + use mesh_mod, only : mesh_type + use function_space_collection_mod, only : function_space_collection + use fs_continuity_mod, only : W2v, W3, Wtheta + use constants_mod, only : i_def, l_def, r_def, EPS + + use log_mod, only : log_event, & + log_scratch_space, & + LOG_LEVEL_ERROR, & + LOG_LEVEL_INFO, & + LOG_LEVEL_DEBUG + + implicit none + + private :: run_atlt_poly1d_vert_adv_alg + public :: atlt_poly1d_vert_adv_alg + + contains + !============================================================================= + !> @brief Adjoint test for atl_vorticity_advection. + !> @details Passes if adjoint is transpose of tangent linear. + !> Determined by testing the equality of inner products and , + !> where M is the tangent linear and A is the adjoint. + !> @param[in] config Application namelist configuration object + !> @param[in] mesh Mesh object + subroutine atlt_poly1d_vert_adv_alg(config, mesh) + + + + implicit none + + ! Arguments + type(config_type), intent(in) :: config + type(mesh_type), pointer, intent(in) :: mesh + + ! Passive arguments for tl and adj calls + type(field_type) :: ls_wind + type(field_type) :: ls_tracer + type(field_type) :: coeff + integer(kind=i_def) :: ndata + integer(kind=i_def) :: global_order + logical(kind=l_def) :: logspace + + ! Variables for initialising fields + type(function_space_type), pointer :: vector_space_w2v_ptr + type(function_space_type), pointer :: vector_space_w3_ptr + type(function_space_type), pointer :: vector_space_wtheta_ptr + integer(kind=i_def) :: element_order_h + integer(kind=i_def) :: element_order_v + + element_order_h = config%finite_element%element_order_h() + element_order_v = config%finite_element%element_order_v() + vector_space_w2v_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W2v) + vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W3) + vector_space_wtheta_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, Wtheta) + call ls_wind%initialise(vector_space=vector_space_w2v_ptr, name='ls_wind') + call ls_tracer%initialise(vector_space=vector_space_wtheta_ptr, name='ls_tracer') + call coeff%initialise(vector_space=vector_space_w3_ptr, name='coeff') + + call invoke( setval_random(ls_wind), setval_random(ls_tracer), setval_random(coeff) ) + + ndata = 0_i_def + global_order = 1_i_def + logspace = .false._l_def + call run_atlt_poly1d_vert_adv_alg(vector_space_w2v_ptr, & + vector_space_wtheta_ptr, & + ls_wind, & + ls_tracer, & + coeff, & + ndata, & + global_order, & + logspace) + + logspace = .true._l_def + call run_atlt_poly1d_vert_adv_alg(vector_space_w2v_ptr, & + vector_space_wtheta_ptr, & + ls_wind, & + ls_tracer, & + coeff, & + ndata, & + global_order, & + logspace) + + + + + + end subroutine atlt_poly1d_vert_adv_alg + + !============================================================================= + !> @brief Runs the adjoint test for atl_poly1d_vert_adv_kernel for a given set of parameters + !> @param[in] vector_space_w2v_ptr W2v function space pointer + !> @param[in] vector_space_wtheta_ptr Wtheta function space pointer + !> @param[in] ls_wind Lin state for wind field + !> @param[in] ls_tracer Lin state for tracer field to advect + !> @param[in] coeff Array of polynomial coefficients for interpolation + !> @param[in] ndata No. data points per dof location + !> @param[in] global_order Desired order of polynomial reconstruction + !> @param[in] logspace Boolean to control whether or not to perform + !! interpolation in log space + subroutine run_atlt_poly1d_vert_adv_alg(vector_space_w2v_ptr, & + vector_space_wtheta_ptr, & + ls_wind, & + ls_tracer, & + coeff, & + ndata, & + global_order, & + logspace) + + use tl_poly1d_vert_adv_kernel_mod, only : tl_poly1d_vert_adv_kernel_type + use atl_poly1d_vert_adv_kernel_mod, only : atl_poly1d_vert_adv_kernel_type + + implicit none + + ! Arguments + type(function_space_type), pointer, intent(in) :: vector_space_w2v_ptr + type(function_space_type), pointer, intent(in) :: vector_space_wtheta_ptr + type(field_type), intent(in) :: ls_wind + type(field_type), intent(in) :: ls_tracer + type(field_type), intent(in) :: coeff + integer(kind=i_def), intent(in) :: ndata + integer(kind=i_def), intent(in) :: global_order + logical(kind=l_def), intent(in) :: logspace + + ! Active arguments for tl and adj calls + type(field_type) :: advective + type(field_type) :: wind + type(field_type) :: tracer + + ! Copies of input fields used in inner products + type(field_type) :: advective_input + type(field_type) :: wind_input + type(field_type) :: tracer_input + + ! Inner products + real(kind=r_def) :: advective_inner_prod + real(kind=r_def) :: wind_inner_prod + real(kind=r_def) :: tracer_inner_prod + real(kind=r_def) :: advective_sf + real(kind=r_def) :: wind_sf + real(kind=r_def) :: tracer_sf + real(kind=r_def) :: inner1 + real(kind=r_def) :: advective_advective_input_inner_prod + real(kind=r_def) :: wind_wind_input_inner_prod + real(kind=r_def) :: tracer_tracer_input_inner_prod + real(kind=r_def) :: inner2 + + ! Test parameters and variables + real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def + real(kind=r_def) :: machine_tol + real(kind=r_def) :: relative_diff + + call advective%initialise(vector_space=vector_space_wtheta_ptr, name='advective') + call wind%initialise(vector_space=vector_space_w2v_ptr, name='wind') + call tracer%initialise(vector_space=vector_space_wtheta_ptr, name='tracer') + + call advective%copy_field_properties(advective_input) + call wind%copy_field_properties(wind_input) + call tracer%copy_field_properties(tracer_input) + + advective_inner_prod = 0.0_r_def + wind_inner_prod = 0.0_r_def + tracer_inner_prod = 0.0_r_def + + ! Initialise arguments and call the tangent-linear kernel. + call invoke( setval_random(advective), setval_x(advective_input, advective), & + setval_random(wind), setval_x(wind_input, wind), & + setval_random(tracer), setval_x(tracer_input, tracer), & + tl_poly1d_vert_adv_kernel_type(advective, wind, tracer, & + ls_wind, ls_tracer, coeff, & + ndata, global_order, logspace), & + x_innerproduct_x(advective_inner_prod, advective), & + x_innerproduct_x(wind_inner_prod, wind), & + x_innerproduct_x(tracer_inner_prod, tracer) ) + + write( log_scratch_space, * ) "atlt_poly1d_vert_adv inner products:" + call log_event( log_scratch_space, log_level_debug ) + write( log_scratch_space, * ) "advective inner product = ", advective_inner_prod + call log_event( log_scratch_space, log_level_debug ) + write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod + call log_event( log_scratch_space, log_level_debug ) + write( log_scratch_space, * ) "tracer inner product = ", tracer_inner_prod + call log_event( log_scratch_space, log_level_debug ) + + advective_sf = 1.0_r_def / (advective_inner_prod + EPS) + wind_sf = 1.0_r_def / (wind_inner_prod + EPS) + tracer_sf = 1.0_r_def / (tracer_inner_prod + EPS) + + inner1 = 0.0_r_def + inner1 = inner1 + advective_inner_prod * advective_sf + inner1 = inner1 + wind_inner_prod * wind_sf + inner1 = inner1 + tracer_inner_prod * tracer_sf + + + advective_advective_input_inner_prod = 0.0_r_def + wind_wind_input_inner_prod = 0.0_r_def + tracer_tracer_input_inner_prod = 0.0_r_def + call invoke( inc_a_times_X( advective_sf, advective ), & + inc_a_times_X( wind_sf, wind ), & + inc_a_times_X( tracer_sf, tracer ), & + atl_poly1d_vert_adv_kernel_type(advective, wind, tracer, & + ls_wind, ls_tracer, coeff, & + ndata, global_order, logspace), & + x_innerproduct_y(advective_advective_input_inner_prod, & + advective, advective_input), & + x_innerproduct_y(wind_wind_input_inner_prod, & + wind, wind_input), & + x_innerproduct_y(tracer_tracer_input_inner_prod, & + tracer, tracer_input) ) + inner2 = 0.0_r_def + inner2 = inner2 + advective_advective_input_inner_prod + inner2 = inner2 + wind_wind_input_inner_prod + inner2 = inner2 + tracer_tracer_input_inner_prod + + ! Test the inner-product values for equality, allowing for the precision of the active variables + machine_tol = spacing(max(abs(inner1), abs(inner2))) + relative_diff = abs(inner1 - inner2) / machine_tol + if (relative_diff < overall_tolerance) then + write(log_scratch_space, *) "PASSED tl_poly1d_vert_adv_kernel_type (logspace = ", & + logspace, "):", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_INFO) + else + write(log_scratch_space, *) "FAILED tl_poly1d_vert_adv_kernel_type (logspace = ", & + logspace, "):", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_ERROR) + end if + + end subroutine run_atlt_poly1d_vert_adv_alg + +end module atlt_poly1d_vert_adv_alg_mod diff --git a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 index be42908655..5d9d669f0f 100644 --- a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 +++ b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 @@ -90,6 +90,7 @@ subroutine run( modeldb ) use atlt_advective_and_flux_alg_mod, only : atlt_advective_and_flux_alg use atlt_mol_conservative_alg_mod, only : atlt_mol_conservative_alg use atlt_mol_advective_alg_mod, only : atlt_mol_advective_alg + use atlt_poly1d_vert_adv_alg_mod, only : atlt_poly1d_vert_adv_alg ! ./transport/control use atlt_transport_field_alg_mod, only : atlt_transport_field_alg @@ -162,6 +163,7 @@ subroutine run( modeldb ) call atlt_poly_adv_update_alg( mesh ) call atlt_poly1d_vert_w3_recon_alg( modeldb%config, mesh ) call atlt_w3h_advective_update_alg( mesh ) + call atlt_poly1d_vert_adv_alg( modeldb%config, mesh ) ! -- Lookup table solutions. call adjt_poly1d_recon_lookup_alg( modeldb%config, mesh, adj_trans_lookup_cache ) call adjt_poly2d_recon_lookup_alg( modeldb%config, mesh, Wtheta, adj_trans_lookup_cache ) diff --git a/science/adjoint/build/psyad_files_list_apps.txt b/science/adjoint/build/psyad_files_list_apps.txt index 9a915936f6..db42b40e56 100644 --- a/science/adjoint/build/psyad_files_list_apps.txt +++ b/science/adjoint/build/psyad_files_list_apps.txt @@ -1,4 +1,3 @@ -science/linear/source/kernel/transport/mol/tl_poly1d_vert_adv_kernel_mod.F90 science/linear/source/kernel/linear_physics/stabilise_bl_u_kernel_mod.F90 science/linear/source/kernel/transport/mol/tl_horizontal_mass_flux_kernel_mod.F90 science/linear/source/kernel/transport/mol/tl_vertical_mass_flux_kernel_mod.F90 diff --git a/science/adjoint/build/psyad_vars.mk b/science/adjoint/build/psyad_vars.mk index c039809dcc..63efe7c196 100644 --- a/science/adjoint/build/psyad_vars.mk +++ b/science/adjoint/build/psyad_vars.mk @@ -5,7 +5,6 @@ ############################################################################## # Active variables all: export ACTIVE_tl_poly_advective_kernel_mod := advective dtdx dtdy v u tracer wind -all: export ACTIVE_tl_poly1d_vert_adv_kernel_mod := advective wind dpdz tracer all: export ACTIVE_stabilise_bl_u_kernel_mod := u_stabilised u_initial u_final all: export ACTIVE_apply_mixed_lu_operator_kernel_mod := wind theta exner lhs_u lhs_t all: export ACTIVE_apply_mixed_operator_kernel_mod := u_e t_col lhs_p lhs_w lhs_uv exner wind_w wind_uv diff --git a/science/adjoint/source/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod.F90 new file mode 100644 index 0000000000..dbca2821b9 --- /dev/null +++ b/science/adjoint/source/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod.F90 @@ -0,0 +1,205 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- + +!> @brief Adjoint for computing vertical fluxes through fitting a +!! high order 1D upwind reconstruction. +module atl_poly1d_vert_adv_kernel_mod + + use argument_mod, only : arg_type, CELL_COLUMN, & + GH_FIELD, GH_SCALAR, & + GH_REAL, GH_INTEGER, & + GH_LOGICAL, & + GH_READWRITE, GH_READ, & + ANY_DISCONTINUOUS_SPACE_1 + use constants_mod, only : r_def, i_def, l_def, EPS + use fs_continuity_mod, only : W2v, Wtheta + use kernel_mod, only : kernel_type + + implicit none + + private + + !------------------------------------------------------------------------------- + ! Public types + !------------------------------------------------------------------------------- + !> The type declaration for the kernel. Contains the metadata needed by the PSy layer + type, public, extends(kernel_type) :: atl_poly1d_vert_adv_kernel_type + private + type(arg_type) :: meta_args(9) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_READ, Wtheta), & + arg_type(GH_FIELD, GH_REAL, GH_READWRITE, W2v), & + arg_type(GH_FIELD, GH_REAL, GH_READWRITE, Wtheta), & + arg_type(GH_FIELD, GH_REAL, GH_READ, W2v), & + arg_type(GH_FIELD, GH_REAL, GH_READ, Wtheta), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1), & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & + arg_type(GH_SCALAR, GH_LOGICAL, GH_READ) & + /) + integer :: operates_on = CELL_COLUMN + contains + procedure, nopass :: atl_poly1d_vert_adv_code + end type + + !------------------------------------------------------------------------------- + ! Contained functions/subroutines + !------------------------------------------------------------------------------- + public :: atl_poly1d_vert_adv_code + + contains + + !> @brief Computes the tangent linear for vertical fluxes for a tracer density. + !! @param[in] nlayers Number of layers + !! @param[in] advective ACTIVE Advective update to increment + !! @param[in,out] wind ACTIVE Change in wind field + !! @param[in,out] tracer ACTIVE Change in tracer field to advect + !! @param[in] ls_wind Lin state for wind field + !! @param[in] ls_tracer Lin state for tracer field to advect + !! @param[in] coeff Array of polynomial coefficients for interpolation + !! @param[in] ndata Number of data points per dof location + !! @param[in] global_order Desired order of polynomial reconstruction + !! @param[in] logspace If true then perform interpolation in log space + !! @param[in] ndf_wt Number of degrees of freedom per cell + !! @param[in] undf_wt Number of unique degrees of freedom for the tracer + !! field + !! @param[in] map_wt Cell dofmaps for the tracer space + !! @param[in] ndf_w2v Number of degrees of freedom per cell + !! @param[in] undf_w2v Number of unique degrees of freedom for the flux & + !! wind fields + !! @param[in] map_w2v Dofmap for the cell at the base of the column + !! @param[in] ndf_c Number of degrees of freedom per cell for the coeff + !! space + !! @param[in] undf_c Total number of degrees of freedom for the coeff space + !! @param[in] map_c Dofmap for the coeff space + subroutine atl_poly1d_vert_adv_code( nlayers, & + advective, & + wind, & + tracer, & + ls_wind, & + ls_tracer, & + coeff, & + ndata, & + global_order, & + logspace, & + ndf_wt, & + undf_wt, & + map_wt, & + ndf_w2v, & + undf_w2v, & + map_w2v, & + ndf_c, & + undf_c, & + map_c) + + implicit none + + ! Arguments + integer(kind=i_def), intent(in) :: nlayers + integer(kind=i_def), intent(in) :: ndf_wt + integer(kind=i_def), intent(in) :: undf_wt + integer(kind=i_def), intent(in) :: ndf_w2v + integer(kind=i_def), intent(in) :: undf_w2v + integer(kind=i_def), dimension(ndf_w2v), intent(in) :: map_w2v + integer(kind=i_def), dimension(ndf_wt), intent(in) :: map_wt + integer(kind=i_def), intent(in) :: ndf_c + integer(kind=i_def), intent(in) :: undf_c + integer(kind=i_def), dimension(ndf_c), intent(in) :: map_c + integer(kind=i_def), intent(in) :: ndata + integer(kind=i_def), intent(in) :: global_order + + real(kind=r_def), dimension(undf_wt), intent(in) :: advective + real(kind=r_def), dimension(undf_w2v), intent(inout) :: wind + real(kind=r_def), dimension(undf_wt), intent(inout) :: tracer + real(kind=r_def), dimension(undf_w2v), intent(in) :: ls_wind + real(kind=r_def), dimension(undf_wt), intent(in) :: ls_tracer + real(kind=r_def), dimension(undf_c), intent(in) :: coeff + + logical(kind=l_def), intent(in) :: logspace + + ! Internal variables + + integer(kind=i_def) :: k, kmin, kmax, ij, ik, p + integer(kind=i_def) :: vertical_order, use_upwind, upwind_offset, upwind + + integer(kind=i_def), dimension(global_order+1) :: stencil + + real(kind=r_def) :: dpdz, ls_dpdz, safe_ls_tracer + real(kind=r_def), dimension(0:nlayers) :: ls_log_tracer + + ij = map_wt(1) + + if ( logspace ) then + do k = 0, nlayers + ls_log_tracer(k) = log(max(EPS,abs(ls_tracer(ij+k)))) + end do + end if + + ! Ensure that we reduce the order if there are only a few layers + vertical_order = min(global_order, nlayers-1) + + ! If order is odd then we are using an upwind stencil -> use_upwind = 1 + ! For even orders it is zero + use_upwind = mod(vertical_order, 2_i_def) + + ! Compute dtracer/dz using precomputed weights + do k = nlayers - 1, 1, -1 + + ! Compute the stencil of points required + do p = 0, vertical_order + stencil(p+1) = k - floor(real(vertical_order,r_def)/2.0_r_def) + p + end do + + ! Adjust the stencil based upon the wind sign for upwind (odd order) + ! reconstructions only. + upwind = int(0.5_r_def*(1.0_r_def + sign(1.0_r_def,ls_wind(map_w2v(1)+k))),kind=i_def) + upwind_offset = use_upwind*upwind + stencil = stencil - upwind_offset + + ! Adjust stencil near boundaries to avoid going out of bounds + kmin = minval(stencil(1:vertical_order+1)) + if ( kmin < 0 ) stencil = stencil - kmin + kmax = maxval(stencil(1:vertical_order+1)) - nlayers + if ( kmax > 0 ) stencil = stencil - kmax + + ! Compute the derivative and the advective update + ls_dpdz = 0.0_r_def + safe_ls_tracer = 1.0_r_def + if ( logspace ) then + do p = 1, vertical_order + 1 + ik = p + upwind_offset*(global_order+1) + k*ndata + map_c(1) - 1 + ls_dpdz = ls_dpdz + coeff(ik)*ls_log_tracer(stencil(p)) + end do + safe_ls_tracer = sign(max(EPS,abs(ls_tracer(ij + k))), ls_tracer(ij + k)) + else + do p = 1, vertical_order + 1 + ik = p + upwind_offset*(global_order+1) + k*ndata + map_c(1) - 1 + ls_dpdz = ls_dpdz + coeff(ik)*ls_tracer(ij + stencil(p)) + end do + end if + + dpdz = ls_wind(map_w2v(1)+k) * advective(map_wt(1)+ k) + wind(map_w2v(1)+k) = wind(map_w2v(1)+k) + advective(map_wt(1)+ k) * ls_dpdz * safe_ls_tracer + + if ( logspace ) then + tracer(ij + k) = tracer(ij + k) + dpdz * ls_dpdz + dpdz = safe_ls_tracer * dpdz + do p = vertical_order + 1, 1, -1 + ik = p + upwind_offset*(global_order+1) + k*ndata + map_c(1) - 1 + tracer(ij + stencil(p)) = tracer(ij + stencil(p)) + coeff(ik) * dpdz / & + sign(max(EPS,abs(ls_tracer(ij + stencil(p)))), ls_tracer(ij + stencil(p))) + end do + + else + do p = vertical_order + 1, 1, -1 + ik = p + upwind_offset*(global_order+1) + k*ndata + map_c(1) - 1 + tracer(ij + stencil(p)) = tracer(ij + stencil(p)) + coeff(ik) * dpdz + end do + end if + end do ! k + + end subroutine atl_poly1d_vert_adv_code + +end module atl_poly1d_vert_adv_kernel_mod From d241356691a6c4e996bdd55d62f85629101d3817 Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Wed, 15 Jul 2026 15:03:06 +0100 Subject: [PATCH 04/22] Added source code for atl_horizontal_mass_flux. Removed patches from previous kernel. --- .../atlt_vorticity_advection_alg_mod.x90 | 8 +- .../atlt_transport_control_alg_mod.x90 | 3 +- .../mol/atlt_horizontal_mass_flux_alg_mod.x90 | 145 +++++++++++++ .../mol/atlt_poly1d_vert_adv_alg_mod.x90 | 13 +- .../source/driver/adjoint_test_driver_mod.f90 | 2 + .../adjoint/build/psyad_files_list_apps.txt | 1 - science/adjoint/build/psyad_vars.mk | 1 - .../atlt_horizontal_mass_flux_alg_mod.patch | 102 ---------- .../atlt_poly1d_vert_adv_alg_mod.patch | 135 ------------- .../atl_horizontal_mass_flux_kernel_mod.patch | 52 ----- .../atl_poly1d_vert_adv_kernel_mod.patch | 191 ------------------ .../tl_horizontal_mass_flux_kernel_mod.patch | 11 - .../tl_poly1d_vert_adv_kernel_mod.patch | 70 ------- .../atl_horizontal_mass_flux_kernel_mod.F90 | 115 +++++++++++ 14 files changed, 272 insertions(+), 577 deletions(-) create mode 100644 applications/adjoint_tests/source/algorithm/transport/mol/atlt_horizontal_mass_flux_alg_mod.x90 delete mode 100644 science/adjoint/patches/algorithm/atlt_horizontal_mass_flux_alg_mod.patch delete mode 100644 science/adjoint/patches/algorithm/atlt_poly1d_vert_adv_alg_mod.patch delete mode 100644 science/adjoint/patches/kernel/atl_horizontal_mass_flux_kernel_mod.patch delete mode 100644 science/adjoint/patches/kernel/atl_poly1d_vert_adv_kernel_mod.patch delete mode 100644 science/adjoint/patches/kernel/tl_horizontal_mass_flux_kernel_mod.patch delete mode 100644 science/adjoint/patches/kernel/tl_poly1d_vert_adv_kernel_mod.patch create mode 100644 science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 diff --git a/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 index acc96bdba0..ac657713f6 100644 --- a/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 @@ -120,13 +120,13 @@ module atlt_vorticity_advection_alg_mod x_innerproduct_x(vorticity_inner_prod, vorticity) ) write( log_scratch_space, * ) "atlt_vorticity_advection inner products:" - call log_event( log_scratch_space, log_level_debug ) + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) write( log_scratch_space, * ) "r_u inner product = ", r_u_inner_prod - call log_event( log_scratch_space, log_level_debug ) + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod - call log_event( log_scratch_space, log_level_debug ) + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) write( log_scratch_space, * ) "vorticity inner product = ", vorticity_inner_prod - call log_event( log_scratch_space, log_level_debug ) + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) r_u_sf = 1.0_r_def / (r_u_inner_prod + EPS) wind_sf = 1.0_r_def / (wind_inner_prod + EPS) diff --git a/applications/adjoint_tests/source/algorithm/transport/control/atlt_transport_control_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/control/atlt_transport_control_alg_mod.x90 index 894cb54b3a..47721ac9b9 100644 --- a/applications/adjoint_tests/source/algorithm/transport/control/atlt_transport_control_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/control/atlt_transport_control_alg_mod.x90 @@ -149,8 +149,7 @@ module atlt_transport_control_alg_mod implicit none ! Arguments - type(config_type), intent(in) :: config - + type(config_type), intent(in) :: config type(function_space_type), pointer, intent(in) :: vector_space_wtheta_ptr type(function_space_type), pointer, intent(in) :: vector_space_w2_ptr type(function_space_type), pointer, intent(in) :: vector_space_w3_ptr diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_horizontal_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_horizontal_mass_flux_alg_mod.x90 new file mode 100644 index 0000000000..30078a4996 --- /dev/null +++ b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_horizontal_mass_flux_alg_mod.x90 @@ -0,0 +1,145 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> @brief Module containing adjoint test for atl_horizontal_mass_flux_kernel +module atlt_horizontal_mass_flux_alg_mod + + use config_mod, only : config_type + use field_mod, only : field_type + use function_space_mod, only : function_space_type + use mesh_mod, only : mesh_type + use function_space_collection_mod, only : function_space_collection + use fs_continuity_mod, only : W2, W3 + use constants_mod, only : i_def, l_def, r_def, EPS + use log_mod, only : log_event, & + log_scratch_space, & + LOG_LEVEL_ERROR, & + LOG_LEVEL_INFO, & + LOG_LEVEL_DEBUG + + implicit none + + public + + contains + + !============================================================================= + !> @brief Adjoint test for atl_horizontal_mass_flux. + !> @details Passes if adjoint is transpose of tangent linear. + !> Determined by testing the equality of inner products and , + !> where M is the tangent linear and A is the adjoint. + !> @param[in] config Application namelist configuration object + !> @param[in] mesh Mesh object + subroutine atlt_horizontal_mass_flux_alg(config, mesh) + + use tl_horizontal_mass_flux_kernel_mod, only : tl_horizontal_mass_flux_kernel_type + use atl_horizontal_mass_flux_kernel_mod, only : atl_horizontal_mass_flux_kernel_type + + implicit none + + ! Arguments + type(config_type), intent(in) :: config + type(mesh_type), pointer, intent(in) :: mesh + + ! Arguments for tl and adj calls + type(field_type) :: mass_flux + type(field_type) :: ls_wind + type(field_type) :: wind + type(field_type) :: reconstruction + + ! Copies of input fields used in inner products + type(field_type) :: mass_flux_input + type(field_type) :: wind_input + + ! Variables for initialising fields + type(function_space_type), pointer :: vector_space_w2_ptr + type(function_space_type), pointer :: vector_space_w3_ptr + integer(kind=i_def) :: element_order_h + integer(kind=i_def) :: element_order_v + integer(kind=i_def), parameter :: ndata = 6 + + ! Inner products + real(kind=r_def) :: mass_flux_inner_prod + real(kind=r_def) :: wind_inner_prod + real(kind=r_def) :: mass_flux_sf + real(kind=r_def) :: wind_sf + real(kind=r_def) :: inner1 + real(kind=r_def) :: mass_flux_mass_flux_input_inner_prod + real(kind=r_def) :: wind_wind_input_inner_prod + real(kind=r_def) :: inner2 + + ! Test parameters and variables + real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def + real(kind=r_def) :: machine_tol + real(kind=r_def) :: relative_diff + + element_order_h = config%finite_element%element_order_h() + element_order_v = config%finite_element%element_order_v() + vector_space_w2_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W2) + vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W3, & + ndata, ndata_first = .false.) + call mass_flux%initialise(vector_space=vector_space_w2_ptr, name='mass_flux') + call ls_wind%initialise(vector_space=vector_space_w2_ptr, name='ls_wind') + call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') + call reconstruction%initialise(vector_space=vector_space_w3_ptr, name='reconstruction') + + call mass_flux%copy_field_properties(mass_flux_input) + call wind%copy_field_properties(wind_input) + mass_flux_inner_prod = 0.0_r_def + wind_inner_prod = 0.0_r_def + + ! Initialise arguments and call the tangent-linear kernel. + call invoke( setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), & + setval_random(ls_wind), & + setval_random(wind), setval_x(wind_input, wind), & + setval_random(reconstruction), & + tl_horizontal_mass_flux_kernel_type(mass_flux, ls_wind, & + wind, reconstruction), & + x_innerproduct_x(mass_flux_inner_prod, mass_flux), & + x_innerproduct_x(wind_inner_prod, wind) ) + + write( log_scratch_space, * ) "atlt_horizontal_mass_flux inner products:" + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "mass_flux inner product = ", mass_flux_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + + mass_flux_sf = 1.0_r_def / (mass_flux_inner_prod + EPS) + wind_sf = 1.0_r_def / (wind_inner_prod + EPS) + + inner1 = 0.0_r_def + inner1 = inner1 + mass_flux_inner_prod * mass_flux_sf + inner1 = inner1 + wind_inner_prod * wind_sf + + mass_flux_mass_flux_input_inner_prod = 0.0_r_def + wind_wind_input_inner_prod = 0.0_r_def + call invoke( inc_a_times_X( mass_flux_sf, mass_flux ), & + inc_a_times_X( wind_sf, wind ), & + atl_horizontal_mass_flux_kernel_type(mass_flux, ls_wind, & + wind, reconstruction), & + x_innerproduct_y(mass_flux_mass_flux_input_inner_prod, & + mass_flux, mass_flux_input), & + x_innerproduct_y(wind_wind_input_inner_prod, & + wind, wind_input) ) + + inner2 = 0.0_r_def + inner2 = inner2 + mass_flux_mass_flux_input_inner_prod + inner2 = inner2 + wind_wind_input_inner_prod + + ! Test the inner-product values for equality, allowing for the precision of the active variables + machine_tol = spacing(max(abs(inner1), abs(inner2))) + relative_diff = abs(inner1 - inner2) / machine_tol + if (relative_diff < overall_tolerance) then + write(log_scratch_space, *) "PASSED tl_horizontal_mass_flux_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_INFO) + else + write(log_scratch_space, *) "FAILED tl_horizontal_mass_flux_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_ERROR) + end if + + end subroutine atlt_horizontal_mass_flux_alg + +end module atlt_horizontal_mass_flux_alg_mod diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 index 3b5ea4153b..9301704d82 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 @@ -13,7 +13,6 @@ module atlt_poly1d_vert_adv_alg_mod use function_space_collection_mod, only : function_space_collection use fs_continuity_mod, only : W2v, W3, Wtheta use constants_mod, only : i_def, l_def, r_def, EPS - use log_mod, only : log_event, & log_scratch_space, & LOG_LEVEL_ERROR, & @@ -27,7 +26,7 @@ module atlt_poly1d_vert_adv_alg_mod contains !============================================================================= - !> @brief Adjoint test for atl_vorticity_advection. + !> @brief Adjoint test for atl_poly1d_vert_adv. !> @details Passes if adjoint is transpose of tangent linear. !> Determined by testing the equality of inner products and , !> where M is the tangent linear and A is the adjoint. @@ -35,8 +34,6 @@ module atlt_poly1d_vert_adv_alg_mod !> @param[in] mesh Mesh object subroutine atlt_poly1d_vert_adv_alg(config, mesh) - - implicit none ! Arguments @@ -184,13 +181,13 @@ module atlt_poly1d_vert_adv_alg_mod x_innerproduct_x(tracer_inner_prod, tracer) ) write( log_scratch_space, * ) "atlt_poly1d_vert_adv inner products:" - call log_event( log_scratch_space, log_level_debug ) + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) write( log_scratch_space, * ) "advective inner product = ", advective_inner_prod - call log_event( log_scratch_space, log_level_debug ) + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod - call log_event( log_scratch_space, log_level_debug ) + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) write( log_scratch_space, * ) "tracer inner product = ", tracer_inner_prod - call log_event( log_scratch_space, log_level_debug ) + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) advective_sf = 1.0_r_def / (advective_inner_prod + EPS) wind_sf = 1.0_r_def / (wind_inner_prod + EPS) diff --git a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 index 5d9d669f0f..90cd636161 100644 --- a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 +++ b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 @@ -91,6 +91,7 @@ subroutine run( modeldb ) use atlt_mol_conservative_alg_mod, only : atlt_mol_conservative_alg use atlt_mol_advective_alg_mod, only : atlt_mol_advective_alg use atlt_poly1d_vert_adv_alg_mod, only : atlt_poly1d_vert_adv_alg + use atlt_horizontal_mass_flux_alg_mod, only : atlt_horizontal_mass_flux_alg ! ./transport/control use atlt_transport_field_alg_mod, only : atlt_transport_field_alg @@ -164,6 +165,7 @@ subroutine run( modeldb ) call atlt_poly1d_vert_w3_recon_alg( modeldb%config, mesh ) call atlt_w3h_advective_update_alg( mesh ) call atlt_poly1d_vert_adv_alg( modeldb%config, mesh ) + call atlt_horizontal_mass_flux_alg( modeldb%config, mesh ) ! -- Lookup table solutions. call adjt_poly1d_recon_lookup_alg( modeldb%config, mesh, adj_trans_lookup_cache ) call adjt_poly2d_recon_lookup_alg( modeldb%config, mesh, Wtheta, adj_trans_lookup_cache ) diff --git a/science/adjoint/build/psyad_files_list_apps.txt b/science/adjoint/build/psyad_files_list_apps.txt index db42b40e56..b7acc90172 100644 --- a/science/adjoint/build/psyad_files_list_apps.txt +++ b/science/adjoint/build/psyad_files_list_apps.txt @@ -1,5 +1,4 @@ science/linear/source/kernel/linear_physics/stabilise_bl_u_kernel_mod.F90 -science/linear/source/kernel/transport/mol/tl_horizontal_mass_flux_kernel_mod.F90 science/linear/source/kernel/transport/mol/tl_vertical_mass_flux_kernel_mod.F90 science/linear/source/kernel/transport/mol/tl_w3v_advective_update_kernel_mod.F90 science/gungho/source/kernel/solver/apply_mixed_lu_operator_kernel_mod.F90 diff --git a/science/adjoint/build/psyad_vars.mk b/science/adjoint/build/psyad_vars.mk index 63efe7c196..420e7f47de 100644 --- a/science/adjoint/build/psyad_vars.mk +++ b/science/adjoint/build/psyad_vars.mk @@ -22,7 +22,6 @@ all: export ACTIVE_strong_curl_kernel_mod := xi res_dot_product cur all: export ACTIVE_sci_average_w2b_to_w2_kernel_mod := field_w2 field_w2_broken all: export ACTIVE_sci_extract_w_kernel_mod := velocity_w2v u_physics all: export ACTIVE_sci_combine_multidata_field_kernel_mod := field1_in field2_in field_out -all: export ACTIVE_tl_horizontal_mass_flux_kernel_mod := mass_flux wind all: export ACTIVE_tl_vertical_mass_flux_kernel_mod := mass_flux wind all: export ACTIVE_w3v_advective_update_kernel_mod := advective_increment tracer dtdz t_U t_D all: export ACTIVE_tl_w3v_advective_update_kernel_mod := advective_increment wind w diff --git a/science/adjoint/patches/algorithm/atlt_horizontal_mass_flux_alg_mod.patch b/science/adjoint/patches/algorithm/atlt_horizontal_mass_flux_alg_mod.patch deleted file mode 100644 index 3be8706bcf..0000000000 --- a/science/adjoint/patches/algorithm/atlt_horizontal_mass_flux_alg_mod.patch +++ /dev/null @@ -1,102 +0,0 @@ -@@ -9,12 +9,12 @@ - use mesh_mod, only : mesh_type - use function_space_collection_mod, only : function_space_collection - use tl_horizontal_mass_flux_kernel_mod, only : tl_horizontal_mass_flux_kernel_type -- use adj_horizontal_mass_flux_kernel_mod, only : adj_horizontal_mass_flux_kernel_type -+ use atl_horizontal_mass_flux_kernel_mod, only : atl_horizontal_mass_flux_kernel_type - use finite_element_config_mod, only : element_order_h, element_order_v - use fs_continuity_mod, only : w2, w3 - use constants_mod, only : i_def, r_def - use setop_random_kernel_mod, only : setop_random_kernel_type -- use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space -+ use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space, log_level_debug - real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def - type(mesh_type), pointer, intent(in) :: mesh - type(field_type), dimension(3), intent(in), optional :: chi -@@ -26,62 +26,57 @@ - type(field_type) :: wind - type(field_type) :: reconstruction - type(field_type) :: mass_flux_input -- type(field_type) :: ls_wind_input - type(field_type) :: wind_input -- type(field_type) :: reconstruction_input - real(kind=r_def) :: mass_flux_inner_prod -- real(kind=r_def) :: ls_wind_inner_prod - real(kind=r_def) :: wind_inner_prod -- real(kind=r_def) :: reconstruction_inner_prod -+ real(kind=r_def) :: mass_flux_sf -+ real(kind=r_def) :: wind_sf - real(kind=r_def) :: inner1 - real(kind=r_def) :: mass_flux_mass_flux_input_inner_prod -- real(kind=r_def) :: ls_wind_ls_wind_input_inner_prod - real(kind=r_def) :: wind_wind_input_inner_prod -- real(kind=r_def) :: reconstruction_reconstruction_input_inner_prod - real(kind=r_def) :: inner2 - real(kind=r_def) :: MachineTol - real(kind=r_def) :: relative_diff -+ real(kind=r_def), parameter :: eps = 1.0e-30_r_def - - vector_space_w2_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w2) -- vector_space_w3_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w3) -+ vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, w3, 6, ndata_first = .false.) - call mass_flux%initialise(vector_space=vector_space_w2_ptr, name='mass_flux') - call ls_wind%initialise(vector_space=vector_space_w2_ptr, name='ls_wind') - call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') - call reconstruction%initialise(vector_space=vector_space_w3_ptr, name='reconstruction') - call mass_flux_input%initialise(vector_space=vector_space_w2_ptr, name='mass_flux_input') -- call ls_wind_input%initialise(vector_space=vector_space_w2_ptr, name='ls_wind_input') - call wind_input%initialise(vector_space=vector_space_w2_ptr, name='wind_input') -- call reconstruction_input%initialise(vector_space=vector_space_w3_ptr, name='reconstruction_input') - mass_flux_inner_prod = 0.0_r_def -- ls_wind_inner_prod = 0.0_r_def - wind_inner_prod = 0.0_r_def -- reconstruction_inner_prod = 0.0_r_def -- - ! Initialise arguments and call the tangent-linear kernel. -- call invoke(setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), setval_random(ls_wind), setval_x(ls_wind_input, & --&ls_wind), setval_random(wind), setval_x(wind_input, wind), setval_random(reconstruction), setval_x(reconstruction_input, & --&reconstruction), tl_horizontal_mass_flux_kernel_type(mass_flux, ls_wind, wind, reconstruction), & --&x_innerproduct_x(mass_flux_inner_prod, mass_flux), x_innerproduct_x(ls_wind_inner_prod, ls_wind), & --&x_innerproduct_x(wind_inner_prod, wind), x_innerproduct_x(reconstruction_inner_prod, reconstruction)) -+ call invoke(setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), setval_random(ls_wind), & -+&setval_random(wind), setval_x(wind_input, wind), setval_random(reconstruction), & -+&tl_horizontal_mass_flux_kernel_type(mass_flux, ls_wind, wind, reconstruction), & -+&x_innerproduct_x(mass_flux_inner_prod, mass_flux), & -+&x_innerproduct_x(wind_inner_prod, wind)) -+ write( log_scratch_space, * ) "atlt_horizontal_mass_flux inner products:" -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "mass_flux inner product = ", mass_flux_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ mass_flux_sf = 1.0_r_def / (mass_flux_inner_prod + eps) -+ wind_sf = 1.0_r_def / (wind_inner_prod + eps) - inner1 = 0.0_r_def -- inner1 = inner1 + mass_flux_inner_prod -- inner1 = inner1 + ls_wind_inner_prod -- inner1 = inner1 + wind_inner_prod -- inner1 = inner1 + reconstruction_inner_prod -+ inner1 = inner1 + mass_flux_inner_prod * mass_flux_sf -+ inner1 = inner1 + wind_inner_prod * wind_sf -+ call invoke( inc_a_times_X( mass_flux_sf, mass_flux ), & -+ inc_a_times_X( wind_sf, wind ) ) - mass_flux_mass_flux_input_inner_prod = 0.0_r_def -- ls_wind_ls_wind_input_inner_prod = 0.0_r_def - wind_wind_input_inner_prod = 0.0_r_def -- reconstruction_reconstruction_input_inner_prod = 0.0_r_def -- call invoke(adj_horizontal_mass_flux_kernel_type(mass_flux, ls_wind, wind, reconstruction), & -+ call invoke(atl_horizontal_mass_flux_kernel_type(mass_flux, ls_wind, wind, reconstruction), & - &x_innerproduct_y(mass_flux_mass_flux_input_inner_prod, mass_flux, mass_flux_input), & --&x_innerproduct_y(ls_wind_ls_wind_input_inner_prod, ls_wind, ls_wind_input), x_innerproduct_y(wind_wind_input_inner_prod, wind, & --&wind_input), x_innerproduct_y(reconstruction_reconstruction_input_inner_prod, reconstruction, reconstruction_input)) -+&x_innerproduct_y(wind_wind_input_inner_prod, wind, & -+&wind_input)) - inner2 = 0.0_r_def - inner2 = inner2 + mass_flux_mass_flux_input_inner_prod -- inner2 = inner2 + ls_wind_ls_wind_input_inner_prod - inner2 = inner2 + wind_wind_input_inner_prod -- inner2 = inner2 + reconstruction_reconstruction_input_inner_prod -- - ! Test the inner-product values for equality, allowing for the precision of the active variables - MachineTol = SPACING(MAX(ABS(inner1), ABS(inner2))) - relative_diff = ABS(inner1 - inner2) / MachineTol diff --git a/science/adjoint/patches/algorithm/atlt_poly1d_vert_adv_alg_mod.patch b/science/adjoint/patches/algorithm/atlt_poly1d_vert_adv_alg_mod.patch deleted file mode 100644 index efa07c3ccf..0000000000 --- a/science/adjoint/patches/algorithm/atlt_poly1d_vert_adv_alg_mod.patch +++ /dev/null @@ -1,135 +0,0 @@ -@@ -9,12 +9,12 @@ - use mesh_mod, only : mesh_type - use function_space_collection_mod, only : function_space_collection - use tl_poly1d_vert_adv_kernel_mod, only : tl_poly1d_vert_adv_kernel_type -- use adj_poly1d_vert_adv_kernel_mod, only : adj_poly1d_vert_adv_kernel_type -+ use atl_poly1d_vert_adv_kernel_mod, only : atl_poly1d_vert_adv_kernel_type - use finite_element_config_mod, only : element_order_h, element_order_v - use fs_continuity_mod, only : w2v, w3, wtheta - use constants_mod, only : i_def, l_def, r_def - use setop_random_kernel_mod, only : setop_random_kernel_type -- use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space -+ use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space, log_level_debug - real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def - type(mesh_type), pointer, intent(in) :: mesh - type(field_type), dimension(3), intent(in), optional :: chi -@@ -31,31 +31,23 @@ - integer(kind=i_def) :: ndata - integer(kind=i_def) :: global_order - logical(kind=l_def) :: logspace -- integer(kind=i_def) :: ndata_input -- integer(kind=i_def) :: global_order_input -- logical(kind=l_def) :: logspace_input - type(field_type) :: advective_input - type(field_type) :: wind_input - type(field_type) :: tracer_input -- type(field_type) :: ls_wind_input -- type(field_type) :: ls_tracer_input -- type(field_type) :: coeff_input - real(kind=r_def) :: advective_inner_prod - real(kind=r_def) :: wind_inner_prod - real(kind=r_def) :: tracer_inner_prod -- real(kind=r_def) :: ls_wind_inner_prod -- real(kind=r_def) :: ls_tracer_inner_prod -- real(kind=r_def) :: coeff_inner_prod -+ real(kind=r_def) :: advective_sf -+ real(kind=r_def) :: wind_sf -+ real(kind=r_def) :: tracer_sf - real(kind=r_def) :: inner1 - real(kind=r_def) :: advective_advective_input_inner_prod - real(kind=r_def) :: wind_wind_input_inner_prod - real(kind=r_def) :: tracer_tracer_input_inner_prod -- real(kind=r_def) :: ls_wind_ls_wind_input_inner_prod -- real(kind=r_def) :: ls_tracer_ls_tracer_input_inner_prod -- real(kind=r_def) :: coeff_coeff_input_inner_prod - real(kind=r_def) :: inner2 - real(kind=r_def) :: MachineTol - real(kind=r_def) :: relative_diff -+ real(kind=r_def), parameter :: eps = 1.0e-30_r_def - - vector_space_w2v_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w2v) - vector_space_w3_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w3) -@@ -69,61 +61,47 @@ - call advective_input%initialise(vector_space=vector_space_wtheta_ptr, name='advective_input') - call wind_input%initialise(vector_space=vector_space_w2v_ptr, name='wind_input') - call tracer_input%initialise(vector_space=vector_space_wtheta_ptr, name='tracer_input') -- call ls_wind_input%initialise(vector_space=vector_space_w2v_ptr, name='ls_wind_input') -- call ls_tracer_input%initialise(vector_space=vector_space_wtheta_ptr, name='ls_tracer_input') -- call coeff_input%initialise(vector_space=vector_space_w3_ptr, name='coeff_input') -- ndata = 1_i_def -- ndata_input = ndata -+ ndata = 0_i_def - global_order = 1_i_def -- global_order_input = global_order - logspace = .false._l_def -- logspace_input = logspace - advective_inner_prod = 0.0_r_def - wind_inner_prod = 0.0_r_def - tracer_inner_prod = 0.0_r_def -- ls_wind_inner_prod = 0.0_r_def -- ls_tracer_inner_prod = 0.0_r_def -- coeff_inner_prod = 0.0_r_def -- - ! Initialise arguments and call the tangent-linear kernel. - call invoke(setval_random(advective), setval_x(advective_input, advective), setval_random(wind), setval_x(wind_input, wind), & --&setval_random(tracer), setval_x(tracer_input, tracer), setval_random(ls_wind), setval_x(ls_wind_input, ls_wind), & --&setval_random(ls_tracer), setval_x(ls_tracer_input, ls_tracer), setval_random(coeff), setval_x(coeff_input, coeff), & -+&setval_random(tracer), setval_x(tracer_input, tracer), setval_random(ls_wind), setval_random(ls_tracer), setval_random(coeff), & - &tl_poly1d_vert_adv_kernel_type(advective, wind, tracer, ls_wind, ls_tracer, coeff, ndata, global_order, logspace), & - &x_innerproduct_x(advective_inner_prod, advective), x_innerproduct_x(wind_inner_prod, wind), x_innerproduct_x(tracer_inner_prod, & --&tracer), x_innerproduct_x(ls_wind_inner_prod, ls_wind), x_innerproduct_x(ls_tracer_inner_prod, ls_tracer), & --&x_innerproduct_x(coeff_inner_prod, coeff)) -+&tracer)) -+ write( log_scratch_space, * ) "atlt_poly1d_vert_adv inner products:" -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "advective inner product = ", advective_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "tracer inner product = ", tracer_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ advective_sf = 1.0_r_def / (advective_inner_prod + eps) -+ wind_sf = 1.0_r_def / (wind_inner_prod + eps) -+ tracer_sf = 1.0_r_def / (tracer_inner_prod + eps) - inner1 = 0.0_r_def -- inner1 = inner1 + ndata * ndata -- inner1 = inner1 + global_order * global_order -- inner1 = inner1 + advective_inner_prod -- inner1 = inner1 + wind_inner_prod -- inner1 = inner1 + tracer_inner_prod -- inner1 = inner1 + ls_wind_inner_prod -- inner1 = inner1 + ls_tracer_inner_prod -- inner1 = inner1 + coeff_inner_prod -+ inner1 = inner1 + advective_inner_prod * advective_sf -+ inner1 = inner1 + wind_inner_prod * wind_sf -+ inner1 = inner1 + tracer_inner_prod * tracer_sf -+ call invoke( inc_a_times_X( advective_sf, advective ), & -+ inc_a_times_X( wind_sf, wind ), & -+ inc_a_times_X( tracer_sf, tracer ) ) - advective_advective_input_inner_prod = 0.0_r_def - wind_wind_input_inner_prod = 0.0_r_def - tracer_tracer_input_inner_prod = 0.0_r_def -- ls_wind_ls_wind_input_inner_prod = 0.0_r_def -- ls_tracer_ls_tracer_input_inner_prod = 0.0_r_def -- coeff_coeff_input_inner_prod = 0.0_r_def -- call invoke(adj_poly1d_vert_adv_kernel_type(advective, wind, tracer, ls_wind, ls_tracer, coeff, ndata, global_order, & -+ call invoke(atl_poly1d_vert_adv_kernel_type(advective, wind, tracer, ls_wind, ls_tracer, coeff, ndata, global_order, & - &logspace), x_innerproduct_y(advective_advective_input_inner_prod, advective, advective_input), & - &x_innerproduct_y(wind_wind_input_inner_prod, wind, wind_input), x_innerproduct_y(tracer_tracer_input_inner_prod, tracer, & --&tracer_input), x_innerproduct_y(ls_wind_ls_wind_input_inner_prod, ls_wind, ls_wind_input), & --&x_innerproduct_y(ls_tracer_ls_tracer_input_inner_prod, ls_tracer, ls_tracer_input), & --&x_innerproduct_y(coeff_coeff_input_inner_prod, coeff, coeff_input)) -+&tracer_input)) - inner2 = 0.0_r_def -- inner2 = inner2 + ndata * ndata_input -- inner2 = inner2 + global_order * global_order_input - inner2 = inner2 + advective_advective_input_inner_prod - inner2 = inner2 + wind_wind_input_inner_prod - inner2 = inner2 + tracer_tracer_input_inner_prod -- inner2 = inner2 + ls_wind_ls_wind_input_inner_prod -- inner2 = inner2 + ls_tracer_ls_tracer_input_inner_prod -- inner2 = inner2 + coeff_coeff_input_inner_prod -- - ! Test the inner-product values for equality, allowing for the precision of the active variables - MachineTol = SPACING(MAX(ABS(inner1), ABS(inner2))) - relative_diff = ABS(inner1 - inner2) / MachineTol diff --git a/science/adjoint/patches/kernel/atl_horizontal_mass_flux_kernel_mod.patch b/science/adjoint/patches/kernel/atl_horizontal_mass_flux_kernel_mod.patch deleted file mode 100644 index aa04ceb40a..0000000000 --- a/science/adjoint/patches/kernel/atl_horizontal_mass_flux_kernel_mod.patch +++ /dev/null @@ -1,52 +0,0 @@ -@@ -1,9 +1,9 @@ --module adj_horizontal_mass_flux_kernel_mod -+module atl_horizontal_mass_flux_kernel_mod - use argument_mod, only : any_discontinuous_space_1, any_w2, arg_type, cell_column, func_type, gh_field, gh_inc, gh_read, gh_real - use constants_mod, only : i_def, r_def - use kernel_mod, only : kernel_type - implicit none -- type, public, extends(kernel_type) :: adj_horizontal_mass_flux_kernel_type -+ type, public, extends(kernel_type) :: atl_horizontal_mass_flux_kernel_type - type(ARG_TYPE) :: META_ARGS(4) = (/ & - arg_type(gh_field, gh_real, gh_read, any_w2), & - arg_type(gh_field, gh_real, gh_read, any_w2), & -@@ -11,15 +11,15 @@ - arg_type(gh_field, gh_real, gh_read, any_discontinuous_space_1)/) - INTEGER :: OPERATES_ON = cell_column - CONTAINS -- PROCEDURE, NOPASS :: adj_horizontal_mass_flux_code --END TYPE adj_horizontal_mass_flux_kernel_type -+ PROCEDURE, NOPASS :: atl_horizontal_mass_flux_code -+END TYPE atl_horizontal_mass_flux_kernel_type - - private - -- public :: adj_horizontal_mass_flux_code -+ public :: atl_horizontal_mass_flux_code - - contains -- subroutine adj_horizontal_mass_flux_code(nlayers, mass_flux, ls_wind, wind, reconstruction, ndf_w2, undf_w2, map_w2, ndf_md, & -+ subroutine atl_horizontal_mass_flux_code(nlayers, mass_flux, ls_wind, wind, reconstruction, ndf_w2, undf_w2, map_w2, ndf_md, & - &undf_md, map_md) - integer(kind=i_def), parameter :: nfaces = 4 - integer(kind=i_def), intent(in) :: nlayers -@@ -39,9 +39,7 @@ - real(kind=r_def) :: direction - real(kind=r_def), dimension(nfaces) :: v_dot_n - -- v_dot_n(:) = 1.0_r_def -- v_dot_n(1) = -1.00000000000000 -- v_dot_n(nfaces) = -1.00000000000000 -+ v_dot_n = (/ -1.0_r_def, 1.0_r_def, 1.0_r_def, -1.0_r_def /) - do df = nfaces, 1, -1 - do k = nlayers - 1, 0, -1 - direction = ls_wind(k + map_w2(df)) * v_dot_n(df) -@@ -52,6 +50,6 @@ - enddo - enddo - -- end subroutine adj_horizontal_mass_flux_code -+ end subroutine atl_horizontal_mass_flux_code - --end module adj_horizontal_mass_flux_kernel_mod -+end module atl_horizontal_mass_flux_kernel_mod diff --git a/science/adjoint/patches/kernel/atl_poly1d_vert_adv_kernel_mod.patch b/science/adjoint/patches/kernel/atl_poly1d_vert_adv_kernel_mod.patch deleted file mode 100644 index b7726a709f..0000000000 --- a/science/adjoint/patches/kernel/atl_poly1d_vert_adv_kernel_mod.patch +++ /dev/null @@ -1,191 +0,0 @@ -@@ -1,11 +1,11 @@ --module adj_poly1d_vert_adv_kernel_mod -+module atl_poly1d_vert_adv_kernel_mod - use argument_mod, only : any_discontinuous_space_1, arg_type, cell_column, gh_field, gh_integer, gh_logical, gh_read, & - &gh_readwrite, gh_real, gh_scalar -- use constants_mod, only : i_def, l_def, r_def -+ use constants_mod, only : i_def, l_def, r_def, eps - use fs_continuity_mod, only : w2v, wtheta - use kernel_mod, only : kernel_type - implicit none -- type, public, extends(kernel_type) :: adj_poly1d_vert_adv_kernel_type -+ type, public, extends(kernel_type) :: atl_poly1d_vert_adv_kernel_type - type(ARG_TYPE) :: META_ARGS(9) = (/ & - arg_type(gh_field, gh_real, gh_read, wtheta), & - arg_type(gh_field, gh_real, gh_readwrite, w2v), & -@@ -18,15 +18,15 @@ - arg_type(gh_scalar, gh_logical, gh_read)/) - INTEGER :: OPERATES_ON = cell_column - CONTAINS -- PROCEDURE, NOPASS :: adj_poly1d_vert_adv_code --END TYPE adj_poly1d_vert_adv_kernel_type -+ PROCEDURE, NOPASS :: atl_poly1d_vert_adv_code -+END TYPE atl_poly1d_vert_adv_kernel_type - - private - -- public :: adj_poly1d_vert_adv_code -+ public :: atl_poly1d_vert_adv_code - - contains -- subroutine adj_poly1d_vert_adv_code(nlayers, advective, wind, tracer, ls_wind, ls_tracer, coeff, ndata, global_order, logspace, & -+ subroutine atl_poly1d_vert_adv_code(nlayers, advective, wind, tracer, ls_wind, ls_tracer, coeff, ndata, global_order, logspace, & - &ndf_wt, undf_wt, map_wt, ndf_w2v, undf_w2v, map_w2v, ndf_c, undf_c, map_c) - integer(kind=i_def), intent(in) :: nlayers - integer(kind=i_def), intent(in) :: ndf_wt -@@ -61,75 +61,96 @@ - real(kind=r_def) :: dpdz - real(kind=r_def) :: ls_dpdz - real(kind=r_def) :: safe_ls_tracer -- real(kind=r_def) :: eps - real(kind=r_def), dimension(0:nlayers) :: ls_log_tracer -- real(kind=r_def) :: tmp1 -- real(kind=r_def) :: tmp2 -- integer(kind=i_def) :: i -- integer(kind=i_def) :: itmp3 - -- dpdz = 0.0_r_def - ij = map_wt(1) -- if (logspace) then -- do k = 0, nlayers, 1 -- ls_log_tracer(k) = LOG(MAX(eps, ABS(ls_tracer(ij + k)))) -- enddo -+ -+ ! For logspace the nonlinear term is: -+ ! dp_{j}/dz = p_j * sum_i a_i * log( p_i) -+ ! The tl term is then: -+ ! dp_{j}/dz = ls_p_j * sum_i a_i * p_i / ls_p_i ! -+ ! + p_j * sum_i a_i * log( ls_p_i ) -+ -+ ! Compute log of tracer. This code should only be used for a positive -+ ! quantity, but adding in the abs ensures no errors are thrown -+ ! if negative numbers are passed through in redundant calculations -+ ! in the halos -+ if ( logspace ) then -+ do k = 0, nlayers -+ ls_log_tracer(k) = log(max(EPS,abs(ls_tracer(ij+k)))) -+ end do - end if -- vertical_order = MIN(global_order, nlayers - 1) -- use_upwind = MOD(vertical_order, 2) -+ -+ ! Ensure that we reduce the order if there are only a few layers -+ vertical_order = min(global_order, nlayers-1) -+ -+ ! If order is odd then we are using an upwind stencil -> use_upwind = 1 -+ ! For even orders it is zero -+ use_upwind = mod(vertical_order, 2_i_def) -+ -+ ! Compute dtracer/dz using precomputed weights - do k = nlayers - 1, 1, -1 -- do p = 0, vertical_order, 1 -- tmp1 = REAL(vertical_order, kind=r_def) -- tmp2 = 0.5 * tmp1 -- itmp3 = FLOOR(tmp2) -- stencil(p + 1) = -itmp3 + k + p -- enddo -- upwind = INT(0.5 * SIGN(1.0, ls_wind(k + map_w2v(1))) + 0.5, kind=i_def) -- upwind_offset = upwind * use_upwind -- stencil(:) = -upwind_offset + stencil(:) -- kmin = stencil(1) -- do i = 2, vertical_order + 1, 1 -- if (stencil(i) < kmin) then -- kmin = stencil(i) -- end if -- enddo -- if (kmin < 0) then -- stencil(:) = -kmin + stencil(:) -- end if -- kmax = stencil(1) -- do i = 2, vertical_order + 1, 1 -- if (stencil(i) > kmax) then -- kmax = stencil(i) -- end if -- enddo -- kmax = kmax - nlayers -- if (kmax > 0) then -- stencil(:) = -kmax + stencil(:) -- end if -+ -+ ! Compute the stencil of points required -+ do p = 0, vertical_order -+ stencil(p+1) = k - floor(real(vertical_order,r_def)/2.0_r_def) + p -+ end do -+ -+ ! Adjust the stencil based upon the wind sign for upwind (odd order) -+ ! reconstructions only. -+ ! if wind > 0 -> upwind_offset = 1 -+ ! if wind < 0 -> upwind_offset = 0 -+ upwind = int(0.5_r_def*(1.0_r_def + sign(1.0_r_def,ls_wind(map_w2v(1)+k))),kind=i_def) -+ upwind_offset = use_upwind*upwind -+ stencil = stencil - upwind_offset -+ -+ ! Adjust stencil near boundaries to avoid going out of bounds -+ kmin = minval(stencil(1:vertical_order+1)) -+ if ( kmin < 0 ) stencil = stencil - kmin -+ kmax = maxval(stencil(1:vertical_order+1)) - nlayers -+ if ( kmax > 0 ) stencil = stencil - kmax -+ -+ ! Compute the derivative and the advective update -+ dpdz = 0.0_r_def - ls_dpdz = 0.0_r_def -- dpdz = dpdz + advective(map_wt(1) + k) * ls_wind(k + map_w2v(1)) -- wind(k + map_w2v(1)) = wind(k + map_w2v(1)) + ls_dpdz * advective(map_wt(1) + k) -- if (logspace) then -- safe_ls_tracer = SIGN(MAX(eps, ABS(ls_tracer(ij + k))), ls_tracer(ij + k)) -- ls_dpdz = ls_dpdz * safe_ls_tracer -- tracer(ij + k) = tracer(ij + k) + ls_dpdz * dpdz -- dpdz = dpdz * safe_ls_tracer -+ safe_ls_tracer = 1.0_r_def -+ if ( logspace ) then -+ ! dp/dz = p * d(log(p))/dz -+ do p = 1, vertical_order + 1 -+ ik = p + upwind_offset*(global_order+1) + k*ndata + map_c(1) - 1 -+ ls_dpdz = ls_dpdz + coeff(ik)*ls_log_tracer(stencil(p)) -+ end do -+ safe_ls_tracer = sign(max(EPS,abs(ls_tracer(ij + k))), ls_tracer(ij + k)) -+ else -+ do p = 1, vertical_order + 1 -+ ik = p + upwind_offset*(global_order+1) + k*ndata + map_c(1) - 1 -+ ls_dpdz = ls_dpdz + coeff(ik)*ls_tracer(ij + stencil(p)) -+ end do -+ end if -+ -+ dpdz = dpdz + ls_wind(map_w2v(1)+k) * advective(map_wt(1)+ k) -+ wind(map_w2v(1)+k) = wind(map_w2v(1)+k) + advective(map_wt(1)+ k) * ls_dpdz * safe_ls_tracer -+ -+ if ( logspace ) then -+ ! dp/dz = p * d(log(p))/dz -+ tracer(ij + k) = tracer(ij + k) + dpdz * ls_dpdz -+ dpdz = safe_ls_tracer * dpdz - do p = vertical_order + 1, 1, -1 -- ik = global_order * upwind_offset + k * ndata + p + upwind_offset + map_c(1) - 1 -- ls_dpdz = ls_dpdz + coeff(ik) * ls_log_tracer(stencil(p)) -- tracer(ij + stencil(p)) = tracer(ij + stencil(p)) + coeff(ik) * dpdz / SIGN(MAX(eps, ABS(ls_tracer(ij + stencil(p)))), & --&ls_tracer(ij + stencil(p))) -- enddo -+ ik = p + upwind_offset*(global_order+1) + k*ndata + map_c(1) - 1 -+ tracer(ij + stencil(p)) = tracer(ij + stencil(p)) + coeff(ik) * dpdz / & -+ ! This is a safe version of ls_tracer -+ sign(max(EPS,abs(ls_tracer(ij + stencil(p)))), ls_tracer(ij + stencil(p))) -+ end do -+ - else - do p = vertical_order + 1, 1, -1 -- ik = global_order * upwind_offset + k * ndata + p + upwind_offset + map_c(1) - 1 -- ls_dpdz = ls_dpdz + coeff(ik) * ls_tracer(ij + stencil(p)) -+ ik = p + upwind_offset*(global_order+1) + k*ndata + map_c(1) - 1 - tracer(ij + stencil(p)) = tracer(ij + stencil(p)) + coeff(ik) * dpdz -- enddo -+ end do - end if -- dpdz = 0.0 -- enddo -+ dpdz = 0.0_r_def -+ end do - -- end subroutine adj_poly1d_vert_adv_code -+ end subroutine atl_poly1d_vert_adv_code - --end module adj_poly1d_vert_adv_kernel_mod -+end module atl_poly1d_vert_adv_kernel_mod diff --git a/science/adjoint/patches/kernel/tl_horizontal_mass_flux_kernel_mod.patch b/science/adjoint/patches/kernel/tl_horizontal_mass_flux_kernel_mod.patch deleted file mode 100644 index 44dc4d27e2..0000000000 --- a/science/adjoint/patches/kernel/tl_horizontal_mass_flux_kernel_mod.patch +++ /dev/null @@ -1,11 +0,0 @@ -@@ -103,7 +103,9 @@ - - ! Implied direction of outward normals dotted with basis functions. - ! If u*u_dot_n > 0 then this is the upwind cell -- v_dot_n = (/ -1.0_r_def, 1.0_r_def, 1.0_r_def, -1.0_r_def /) -+ v_dot_n = 1.0_r_def -+ v_dot_n(1) = -1.0_r_def -+ v_dot_n(nfaces) = -1.0_r_def - - ! Horizontal Flux - ! Reconstruction is stored on a layer first multidata field diff --git a/science/adjoint/patches/kernel/tl_poly1d_vert_adv_kernel_mod.patch b/science/adjoint/patches/kernel/tl_poly1d_vert_adv_kernel_mod.patch deleted file mode 100644 index 2dbbe4174c..0000000000 --- a/science/adjoint/patches/kernel/tl_poly1d_vert_adv_kernel_mod.patch +++ /dev/null @@ -1,70 +0,0 @@ -@@ -14,7 +14,7 @@ - GH_LOGICAL, & - GH_READWRITE, GH_READ, & - ANY_DISCONTINUOUS_SPACE_1 --use constants_mod, only : r_def, i_def, l_def, EPS -+use constants_mod, only : r_def, i_def, l_def - use fs_continuity_mod, only : W2v, Wtheta - use kernel_mod, only : kernel_type - -@@ -126,9 +126,12 @@ - - integer(kind=i_def), dimension(global_order+1) :: stencil - -- real(kind=r_def) :: dpdz, ls_dpdz, safe_ls_tracer -+ real(kind=r_def) :: dpdz, ls_dpdz, safe_ls_tracer, EPS - real(kind=r_def), dimension(0:nlayers) :: ls_log_tracer - -+ real(kind=r_def) :: tmp1, tmp2 -+ integer(kind=i_def) :: i, itmp3 -+ - ij = map_wt(1) - - ! For logspace the nonlinear term is: -@@ -159,7 +162,10 @@ - - ! Compute the stencil of points required - do p = 0, vertical_order -- stencil(p+1) = k - floor(real(vertical_order,r_def)/2.0_r_def) + p -+ tmp1 = real(vertical_order,r_def) -+ tmp2 = tmp1/2.0_r_def -+ itmp3 = floor(tmp2) -+ stencil(p+1) = k - itmp3 + p - end do - - ! Adjust the stencil based upon the wind sign for upwind (odd order) -@@ -171,9 +177,21 @@ - stencil = stencil - upwind_offset - - ! Adjust stencil near boundaries to avoid going out of bounds -- kmin = minval(stencil(1:vertical_order+1)) -+ kmin = stencil(1) -+ do i = 2, vertical_order+1 -+ if (stencil(i) < kmin) then -+ kmin = stencil(i) -+ end if -+ end do - if ( kmin < 0 ) stencil = stencil - kmin -- kmax = maxval(stencil(1:vertical_order+1)) - nlayers -+ -+ kmax = stencil(1) -+ do i = 2, vertical_order+1 -+ if (stencil(i) > kmax) then -+ kmax = stencil(i) -+ end if -+ end do -+ kmax = kmax - nlayers - if ( kmax > 0 ) stencil = stencil - kmax - - ! Compute the derivative and the advective update -@@ -184,8 +202,8 @@ - do p = 1, vertical_order + 1 - ik = p + upwind_offset*(global_order+1) + k*ndata + map_c(1) - 1 - dpdz = dpdz + coeff(ik)*tracer(ij + stencil(p)) / & -- ! This is a safe version of ls_tracer -- sign(max(EPS,abs(ls_tracer(ij + stencil(p)))), ls_tracer(ij + stencil(p))) -+ ! This is a safe version of ls_tracer -+ sign(max(EPS,abs(ls_tracer(ij + stencil(p)))), ls_tracer(ij + stencil(p))) - ls_dpdz = ls_dpdz + coeff(ik)*ls_log_tracer(stencil(p)) - end do - ! Need to use same safe ls_tracer here diff --git a/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 new file mode 100644 index 0000000000..c82496bb7f --- /dev/null +++ b/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 @@ -0,0 +1,115 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + +!> @brief Kernel which computes adjoint horizontal mass flux of a density by a wind +!! field. +module atl_horizontal_mass_flux_kernel_mod + + use argument_mod, only : arg_type, func_type, & + GH_FIELD, & + GH_REAL, & + GH_INC, GH_READ, & + CELL_COLUMN, & + ANY_DISCONTINUOUS_SPACE_1, & + ANY_W2 + use constants_mod, only : r_def, i_def + use kernel_mod, only : kernel_type + + implicit none + + private + + !------------------------------------------------------------------------------- + ! Public types + !------------------------------------------------------------------------------- + !> The type declaration for the kernel. Contains the metadata needed by the PSy layer + type, public, extends(kernel_type) :: atl_horizontal_mass_flux_kernel_type + private + type(arg_type) :: meta_args(4) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_INC, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1) & + /) + integer :: operates_on = CELL_COLUMN + contains + procedure, nopass :: atl_horizontal_mass_flux_code + end type + + !------------------------------------------------------------------------------- + ! Contained functions/subroutines + !------------------------------------------------------------------------------- + public :: atl_horizontal_mass_flux_code + + contains + + !> @brief Computes the adjoint horizontal mass flux of a density by a wind + !> @param[in] nlayers Number of layers + !> @param[in] mass_flux Upwind mass flux to be computed + !> @param[in] ls_wind Linear wind field + !> @param[in,out] wind Perturbation wind field + !> @param[in] reconstruction Density field computed on cell edges + !> @param[in] ndf_w2 Number of degrees of freedom per cell for the wind and flux fields + !> @param[in] undf_w2 Number of unique degrees of freedom for the wind and flux fields + !> @param[in] map_w2 Dofmap for the cell at the base of the column for the wind and flux fields + !> @param[in] ndf_md Number of degrees of freedom per cell for the multidata density field + !> @param[in] undf_md Number of unique degrees of freedom for the multidata density field + !> @param[in] map_md Dofmap for the cell at the base of the column for the multidata density field + subroutine atl_horizontal_mass_flux_code( nlayers, & + mass_flux, & + ls_wind, & + wind, & + reconstruction, & + ndf_w2, & + undf_w2, & + map_w2, & + ndf_md, & + undf_md, & + map_md ) + + implicit none + + ! Arguments + integer(kind=i_def), intent(in) :: nlayers + integer(kind=i_def), intent(in) :: ndf_md + integer(kind=i_def), intent(in) :: undf_md + integer(kind=i_def), dimension(ndf_md), intent(in) :: map_md + integer(kind=i_def), intent(in) :: ndf_w2 + integer(kind=i_def), intent(in) :: undf_w2 + integer(kind=i_def), dimension(ndf_w2), intent(in) :: map_w2 + + real(kind=r_def), dimension(undf_md), intent(in) :: reconstruction + real(kind=r_def), dimension(undf_w2), intent(inout) :: wind + real(kind=r_def), dimension(undf_w2), intent(in) :: ls_wind + real(kind=r_def), dimension(undf_w2), intent(in) :: mass_flux + + ! Internal variables + integer(kind=i_def) :: k, df, ijp + integer(kind=i_def), parameter :: nfaces = 4 + real(kind=r_def) :: direction + real(kind=r_def), dimension(nfaces) :: v_dot_n + + ! Implied direction of outward normals dotted with basis functions. + ! If u*u_dot_n > 0 then this is the upwind cell + v_dot_n = (/ -1.0_r_def, 1.0_r_def, 1.0_r_def, -1.0_r_def /) + + do df = nfaces, 1, -1 + do k = nlayers - 1, 0, -1 + direction = ls_wind(map_w2(df) + k)*v_dot_n(df) + if ( direction > 0.0_r_def ) then + ! Take value on edge from this column + ijp = map_md(1) + (df-1)*nlayers + wind(map_w2(df) + k) = wind(map_w2(df) + k) + & + reconstruction(ijp + k) * mass_flux(map_w2(df) + k) + end if + end do + end do + + end subroutine atl_horizontal_mass_flux_code + +end module atl_horizontal_mass_flux_kernel_mod From e1c9373bf0fa24ee869d31e59c0171d23513fafc Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Thu, 16 Jul 2026 13:47:22 +0100 Subject: [PATCH 05/22] Added source code for atl_vertical_mass_flux --- .../mol/atlt_vertical_mass_flux_alg_mod.x90 | 145 ++++++++++++++++++ .../source/driver/adjoint_test_driver_mod.f90 | 2 + .../adjoint/build/psyad_files_list_apps.txt | 1 - science/adjoint/build/psyad_vars.mk | 1 - .../atlt_vertical_mass_flux_alg_mod.patch | 102 ------------ .../atl_vertical_mass_flux_kernel_mod.patch | 61 -------- .../mol/atl_vertical_mass_flux_kernel_mod.F90 | 125 +++++++++++++++ 7 files changed, 272 insertions(+), 165 deletions(-) create mode 100644 applications/adjoint_tests/source/algorithm/transport/mol/atlt_vertical_mass_flux_alg_mod.x90 delete mode 100644 science/adjoint/patches/algorithm/atlt_vertical_mass_flux_alg_mod.patch delete mode 100644 science/adjoint/patches/kernel/atl_vertical_mass_flux_kernel_mod.patch create mode 100644 science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_vertical_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_vertical_mass_flux_alg_mod.x90 new file mode 100644 index 0000000000..3b0119cada --- /dev/null +++ b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_vertical_mass_flux_alg_mod.x90 @@ -0,0 +1,145 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> @brief Module containing adjoint test for atl_vertical_mass_flux_kernel +module atlt_vertical_mass_flux_alg_mod + + use config_mod, only : config_type + use field_mod, only : field_type + use function_space_mod, only : function_space_type + use mesh_mod, only : mesh_type + use function_space_collection_mod, only : function_space_collection + use fs_continuity_mod, only : W2, W3 + use constants_mod, only : i_def, l_def, r_def, EPS + use log_mod, only : log_event, & + log_scratch_space, & + LOG_LEVEL_ERROR, & + LOG_LEVEL_INFO, & + LOG_LEVEL_DEBUG + + implicit none + + public + + contains + + !============================================================================= + !> @brief Adjoint test for atl_vertical_mass_flux. + !> @details Passes if adjoint is transpose of tangent linear. + !> Determined by testing the equality of inner products and , + !> where M is the tangent linear and A is the adjoint. + !> @param[in] config Application namelist configuration object + !> @param[in] mesh Mesh object + subroutine atlt_vertical_mass_flux_alg(config, mesh) + + use tl_vertical_mass_flux_kernel_mod, only : tl_vertical_mass_flux_kernel_type + use atl_vertical_mass_flux_kernel_mod, only : atl_vertical_mass_flux_kernel_type + + implicit none + + ! Arguments + type(config_type), intent(in) :: config + type(mesh_type), pointer, intent(in) :: mesh + + ! Arguments for tl and adj calls + type(field_type) :: mass_flux + type(field_type) :: ls_wind + type(field_type) :: wind + type(field_type) :: reconstruction + + ! Copies of input fields used in inner products + type(field_type) :: mass_flux_input + type(field_type) :: wind_input + + ! Variables for initialising fields + type(function_space_type), pointer :: vector_space_w2_ptr + type(function_space_type), pointer :: vector_space_w3_ptr + integer(kind=i_def) :: element_order_h + integer(kind=i_def) :: element_order_v + integer(kind=i_def), parameter :: ndata = 6 + + ! Inner products + real(kind=r_def) :: mass_flux_inner_prod + real(kind=r_def) :: wind_inner_prod + real(kind=r_def) :: mass_flux_sf + real(kind=r_def) :: wind_sf + real(kind=r_def) :: inner1 + real(kind=r_def) :: mass_flux_mass_flux_input_inner_prod + real(kind=r_def) :: wind_wind_input_inner_prod + real(kind=r_def) :: inner2 + + ! Test parameters and variables + real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def + real(kind=r_def) :: machine_tol + real(kind=r_def) :: relative_diff + + element_order_h = config%finite_element%element_order_h() + element_order_v = config%finite_element%element_order_v() + vector_space_w2_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W2) + vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W3, & + ndata, ndata_first = .false.) + call mass_flux%initialise(vector_space=vector_space_w2_ptr, name='mass_flux') + call ls_wind%initialise(vector_space=vector_space_w2_ptr, name='ls_wind') + call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') + call reconstruction%initialise(vector_space=vector_space_w3_ptr, name='reconstruction') + + call mass_flux%copy_field_properties(mass_flux_input) + call wind%copy_field_properties(wind_input) + mass_flux_inner_prod = 0.0_r_def + wind_inner_prod = 0.0_r_def + + ! Initialise arguments and call the tangent-linear kernel. + call invoke( setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), & + setval_random(ls_wind), & + setval_random(wind), setval_x(wind_input, wind), & + setval_random(reconstruction), & + tl_vertical_mass_flux_kernel_type(mass_flux, ls_wind, & + wind, reconstruction), & + x_innerproduct_x(mass_flux_inner_prod, mass_flux), & + x_innerproduct_x(wind_inner_prod, wind) ) + + write( log_scratch_space, * ) "atlt_vertical_mass_flux inner products:" + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "mass_flux inner product = ", mass_flux_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + + mass_flux_sf = 1.0_r_def / (mass_flux_inner_prod + EPS) + wind_sf = 1.0_r_def / (wind_inner_prod + EPS) + + inner1 = 0.0_r_def + inner1 = inner1 + mass_flux_inner_prod * mass_flux_sf + inner1 = inner1 + wind_inner_prod * wind_sf + + mass_flux_mass_flux_input_inner_prod = 0.0_r_def + wind_wind_input_inner_prod = 0.0_r_def + call invoke( inc_a_times_X( mass_flux_sf, mass_flux ), & + inc_a_times_X( wind_sf, wind ), & + atl_vertical_mass_flux_kernel_type(mass_flux, ls_wind, & + wind, reconstruction), & + x_innerproduct_y(mass_flux_mass_flux_input_inner_prod, & + mass_flux, mass_flux_input), & + x_innerproduct_y(wind_wind_input_inner_prod, & + wind, wind_input) ) + + inner2 = 0.0_r_def + inner2 = inner2 + mass_flux_mass_flux_input_inner_prod + inner2 = inner2 + wind_wind_input_inner_prod + + ! Test the inner-product values for equality, allowing for the precision of the active variables + machine_tol = spacing(max(abs(inner1), abs(inner2))) + relative_diff = abs(inner1 - inner2) / machine_tol + if (relative_diff < overall_tolerance) then + write(log_scratch_space, *) "PASSED tl_vertical_mass_flux_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_INFO) + else + write(log_scratch_space, *) "FAILED tl_vertical_mass_flux_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_ERROR) + end if + + end subroutine atlt_vertical_mass_flux_alg + +end module atlt_vertical_mass_flux_alg_mod diff --git a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 index 90cd636161..54854c86bf 100644 --- a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 +++ b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 @@ -92,6 +92,7 @@ subroutine run( modeldb ) use atlt_mol_advective_alg_mod, only : atlt_mol_advective_alg use atlt_poly1d_vert_adv_alg_mod, only : atlt_poly1d_vert_adv_alg use atlt_horizontal_mass_flux_alg_mod, only : atlt_horizontal_mass_flux_alg + use atlt_vertical_mass_flux_alg_mod, only : atlt_vertical_mass_flux_alg ! ./transport/control use atlt_transport_field_alg_mod, only : atlt_transport_field_alg @@ -166,6 +167,7 @@ subroutine run( modeldb ) call atlt_w3h_advective_update_alg( mesh ) call atlt_poly1d_vert_adv_alg( modeldb%config, mesh ) call atlt_horizontal_mass_flux_alg( modeldb%config, mesh ) + call atlt_vertical_mass_flux_alg( modeldb%config, mesh ) ! -- Lookup table solutions. call adjt_poly1d_recon_lookup_alg( modeldb%config, mesh, adj_trans_lookup_cache ) call adjt_poly2d_recon_lookup_alg( modeldb%config, mesh, Wtheta, adj_trans_lookup_cache ) diff --git a/science/adjoint/build/psyad_files_list_apps.txt b/science/adjoint/build/psyad_files_list_apps.txt index b7acc90172..a9eda3c3e2 100644 --- a/science/adjoint/build/psyad_files_list_apps.txt +++ b/science/adjoint/build/psyad_files_list_apps.txt @@ -1,5 +1,4 @@ science/linear/source/kernel/linear_physics/stabilise_bl_u_kernel_mod.F90 -science/linear/source/kernel/transport/mol/tl_vertical_mass_flux_kernel_mod.F90 science/linear/source/kernel/transport/mol/tl_w3v_advective_update_kernel_mod.F90 science/gungho/source/kernel/solver/apply_mixed_lu_operator_kernel_mod.F90 science/gungho/source/kernel/solver/apply_mixed_operator_kernel_mod.F90 diff --git a/science/adjoint/build/psyad_vars.mk b/science/adjoint/build/psyad_vars.mk index 420e7f47de..6f556c6387 100644 --- a/science/adjoint/build/psyad_vars.mk +++ b/science/adjoint/build/psyad_vars.mk @@ -22,7 +22,6 @@ all: export ACTIVE_strong_curl_kernel_mod := xi res_dot_product cur all: export ACTIVE_sci_average_w2b_to_w2_kernel_mod := field_w2 field_w2_broken all: export ACTIVE_sci_extract_w_kernel_mod := velocity_w2v u_physics all: export ACTIVE_sci_combine_multidata_field_kernel_mod := field1_in field2_in field_out -all: export ACTIVE_tl_vertical_mass_flux_kernel_mod := mass_flux wind all: export ACTIVE_w3v_advective_update_kernel_mod := advective_increment tracer dtdz t_U t_D all: export ACTIVE_tl_w3v_advective_update_kernel_mod := advective_increment wind w all: export ACTIVE_horizontal_mass_flux_kernel_mod := mass_flux reconstruction diff --git a/science/adjoint/patches/algorithm/atlt_vertical_mass_flux_alg_mod.patch b/science/adjoint/patches/algorithm/atlt_vertical_mass_flux_alg_mod.patch deleted file mode 100644 index b651141443..0000000000 --- a/science/adjoint/patches/algorithm/atlt_vertical_mass_flux_alg_mod.patch +++ /dev/null @@ -1,102 +0,0 @@ -@@ -9,12 +9,12 @@ - use mesh_mod, only : mesh_type - use function_space_collection_mod, only : function_space_collection - use tl_vertical_mass_flux_kernel_mod, only : tl_vertical_mass_flux_kernel_type -- use adj_vertical_mass_flux_kernel_mod, only : adj_vertical_mass_flux_kernel_type -+ use atl_vertical_mass_flux_kernel_mod, only : atl_vertical_mass_flux_kernel_type - use finite_element_config_mod, only : element_order_h, element_order_v - use fs_continuity_mod, only : w2, w3 - use constants_mod, only : i_def, r_def - use setop_random_kernel_mod, only : setop_random_kernel_type -- use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space -+ use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space, log_level_debug - real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def - type(mesh_type), pointer, intent(in) :: mesh - type(field_type), dimension(3), intent(in), optional :: chi -@@ -26,62 +26,57 @@ - type(field_type) :: wind - type(field_type) :: reconstruction - type(field_type) :: mass_flux_input -- type(field_type) :: ls_wind_input - type(field_type) :: wind_input -- type(field_type) :: reconstruction_input - real(kind=r_def) :: mass_flux_inner_prod -- real(kind=r_def) :: ls_wind_inner_prod - real(kind=r_def) :: wind_inner_prod -- real(kind=r_def) :: reconstruction_inner_prod -+ real(kind=r_def) :: mass_flux_sf -+ real(kind=r_def) :: wind_sf - real(kind=r_def) :: inner1 - real(kind=r_def) :: mass_flux_mass_flux_input_inner_prod -- real(kind=r_def) :: ls_wind_ls_wind_input_inner_prod - real(kind=r_def) :: wind_wind_input_inner_prod -- real(kind=r_def) :: reconstruction_reconstruction_input_inner_prod - real(kind=r_def) :: inner2 - real(kind=r_def) :: MachineTol - real(kind=r_def) :: relative_diff -+ real(kind=r_def), parameter :: eps = 1.0e-30_r_def - - vector_space_w2_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w2) -- vector_space_w3_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w3) -+ vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, w3, 6, ndata_first = .false.) - call mass_flux%initialise(vector_space=vector_space_w2_ptr, name='mass_flux') - call ls_wind%initialise(vector_space=vector_space_w2_ptr, name='ls_wind') - call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') - call reconstruction%initialise(vector_space=vector_space_w3_ptr, name='reconstruction') - call mass_flux_input%initialise(vector_space=vector_space_w2_ptr, name='mass_flux_input') -- call ls_wind_input%initialise(vector_space=vector_space_w2_ptr, name='ls_wind_input') - call wind_input%initialise(vector_space=vector_space_w2_ptr, name='wind_input') -- call reconstruction_input%initialise(vector_space=vector_space_w3_ptr, name='reconstruction_input') - mass_flux_inner_prod = 0.0_r_def -- ls_wind_inner_prod = 0.0_r_def - wind_inner_prod = 0.0_r_def -- reconstruction_inner_prod = 0.0_r_def -- - ! Initialise arguments and call the tangent-linear kernel. -- call invoke(setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), setval_random(ls_wind), setval_x(ls_wind_input, & --&ls_wind), setval_random(wind), setval_x(wind_input, wind), setval_random(reconstruction), setval_x(reconstruction_input, & --&reconstruction), tl_vertical_mass_flux_kernel_type(mass_flux, ls_wind, wind, reconstruction), & --&x_innerproduct_x(mass_flux_inner_prod, mass_flux), x_innerproduct_x(ls_wind_inner_prod, ls_wind), & --&x_innerproduct_x(wind_inner_prod, wind), x_innerproduct_x(reconstruction_inner_prod, reconstruction)) -+ call invoke(setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), setval_random(ls_wind), & -+&setval_random(wind), setval_x(wind_input, wind), setval_random(reconstruction), & -+&tl_vertical_mass_flux_kernel_type(mass_flux, ls_wind, wind, reconstruction), & -+&x_innerproduct_x(mass_flux_inner_prod, mass_flux), & -+&x_innerproduct_x(wind_inner_prod, wind)) -+ write( log_scratch_space, * ) "atlt_vertical_mass_flux inner products:" -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "mass_flux inner product = ", mass_flux_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ mass_flux_sf = 1.0_r_def / (mass_flux_inner_prod + eps) -+ wind_sf = 1.0_r_def / (wind_inner_prod + eps) - inner1 = 0.0_r_def -- inner1 = inner1 + mass_flux_inner_prod -- inner1 = inner1 + ls_wind_inner_prod -- inner1 = inner1 + wind_inner_prod -- inner1 = inner1 + reconstruction_inner_prod -+ inner1 = inner1 + mass_flux_inner_prod * mass_flux_sf -+ inner1 = inner1 + wind_inner_prod * wind_sf -+ call invoke( inc_a_times_X( mass_flux_sf, mass_flux ), & -+ inc_a_times_X( wind_sf, wind ) ) - mass_flux_mass_flux_input_inner_prod = 0.0_r_def -- ls_wind_ls_wind_input_inner_prod = 0.0_r_def - wind_wind_input_inner_prod = 0.0_r_def -- reconstruction_reconstruction_input_inner_prod = 0.0_r_def -- call invoke(adj_vertical_mass_flux_kernel_type(mass_flux, ls_wind, wind, reconstruction), & -+ call invoke(atl_vertical_mass_flux_kernel_type(mass_flux, ls_wind, wind, reconstruction), & - &x_innerproduct_y(mass_flux_mass_flux_input_inner_prod, mass_flux, mass_flux_input), & --&x_innerproduct_y(ls_wind_ls_wind_input_inner_prod, ls_wind, ls_wind_input), x_innerproduct_y(wind_wind_input_inner_prod, wind, & --&wind_input), x_innerproduct_y(reconstruction_reconstruction_input_inner_prod, reconstruction, reconstruction_input)) -+&x_innerproduct_y(wind_wind_input_inner_prod, wind, & -+&wind_input)) - inner2 = 0.0_r_def - inner2 = inner2 + mass_flux_mass_flux_input_inner_prod -- inner2 = inner2 + ls_wind_ls_wind_input_inner_prod - inner2 = inner2 + wind_wind_input_inner_prod -- inner2 = inner2 + reconstruction_reconstruction_input_inner_prod -- - ! Test the inner-product values for equality, allowing for the precision of the active variables - MachineTol = SPACING(MAX(ABS(inner1), ABS(inner2))) - relative_diff = ABS(inner1 - inner2) / MachineTol diff --git a/science/adjoint/patches/kernel/atl_vertical_mass_flux_kernel_mod.patch b/science/adjoint/patches/kernel/atl_vertical_mass_flux_kernel_mod.patch deleted file mode 100644 index 18fc68b04f..0000000000 --- a/science/adjoint/patches/kernel/atl_vertical_mass_flux_kernel_mod.patch +++ /dev/null @@ -1,61 +0,0 @@ -@@ -1,26 +1,26 @@ --module adj_vertical_mass_flux_kernel_mod -+module atl_vertical_mass_flux_kernel_mod - use argument_mod, only : any_discontinuous_space_1, any_w2, arg_type, cell_column, func_type, gh_field, gh_inc, gh_read, & --&gh_real, gh_write -+&gh_real, gh_readinc - use constants_mod, only : i_def, l_def, r_def - use kernel_mod, only : kernel_type - implicit none -- type, public, extends(kernel_type) :: adj_vertical_mass_flux_kernel_type -+ type, public, extends(kernel_type) :: atl_vertical_mass_flux_kernel_type - type(ARG_TYPE) :: META_ARGS(4) = (/ & -- arg_type(gh_field, gh_real, gh_write, any_w2), & -+ arg_type(gh_field, gh_real, gh_readinc, any_w2), & - arg_type(gh_field, gh_real, gh_read, any_w2), & - arg_type(gh_field, gh_real, gh_inc, any_w2), & - arg_type(gh_field, gh_real, gh_read, any_discontinuous_space_1)/) - INTEGER :: OPERATES_ON = cell_column - CONTAINS -- PROCEDURE, NOPASS :: adj_vertical_mass_flux_code --END TYPE adj_vertical_mass_flux_kernel_type -+ PROCEDURE, NOPASS :: atl_vertical_mass_flux_code -+END TYPE atl_vertical_mass_flux_kernel_type - - private - -- public :: adj_vertical_mass_flux_code -+ public :: atl_vertical_mass_flux_code - - contains -- subroutine adj_vertical_mass_flux_code(nlayers, mass_flux, ls_wind, wind, reconstruction, ndf_w2, undf_w2, map_w2, ndf_md, & -+ subroutine atl_vertical_mass_flux_code(nlayers, mass_flux, ls_wind, wind, reconstruction, ndf_w2, undf_w2, map_w2, ndf_md, & - &undf_md, map_md) - integer(kind=i_def), intent(in) :: nlayers - integer(kind=i_def), intent(in) :: ndf_md -@@ -47,18 +47,18 @@ - df = 5 - offset = 4 * nlayers - end if -- mass_flux(map_w2(df) + nlayers) = 0.0 -+ mass_flux(map_w2(df) + nlayers) = 0.0_r_def - do k = nlayers - 1, 1, -1 - ijp2 = k + nlayers + offset + map_md(1) - 1 - ijp1 = k + offset + map_md(1) -- wgt = 0.5 - SIGN(0.5, ls_wind(k + map_w2(df))) -+ wgt = 0.5_r_def - SIGN(0.5_r_def, ls_wind(k + map_w2(df))) - wind(k + map_w2(df)) = wind(k + map_w2(df)) + wgt * reconstruction(ijp1) * mass_flux(map_w2(df) + k) - wind(k + map_w2(df)) = wind(k + map_w2(df)) - wgt * reconstruction(ijp2) * mass_flux(map_w2(df) + k) -- wind(k + map_w2(df)) = wind(k + map_w2(df)) + 1.0 * reconstruction(ijp2) * mass_flux(map_w2(df) + k) -- mass_flux(map_w2(df) + k) = 0.0 -+ wind(k + map_w2(df)) = wind(k + map_w2(df)) + 1.0_r_def * reconstruction(ijp2) * mass_flux(map_w2(df) + k) -+ mass_flux(map_w2(df) + k) = 0.0_r_def - enddo -- mass_flux(map_w2(df)) = 0.0 -+ mass_flux(map_w2(df)) = 0.0_r_def - -- end subroutine adj_vertical_mass_flux_code -+ end subroutine atl_vertical_mass_flux_code - --end module adj_vertical_mass_flux_kernel_mod -+end module atl_vertical_mass_flux_kernel_mod diff --git a/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 new file mode 100644 index 0000000000..bda3189be1 --- /dev/null +++ b/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 @@ -0,0 +1,125 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + +!> @brief Kernel which computes adjoint vertical mass flux using an +!! upwind reconstruction of a field on cell edges. +module atl_vertical_mass_flux_kernel_mod + +use argument_mod, only : arg_type, func_type, & + GH_FIELD, GH_REAL, & + GH_READINC, GH_READ, & + GH_INC, & + CELL_COLUMN, & + ANY_DISCONTINUOUS_SPACE_1, & + ANY_W2 +use constants_mod, only : r_def, i_def, l_def +use kernel_mod, only : kernel_type + +implicit none + +private + +!------------------------------------------------------------------------------- +! Public types +!------------------------------------------------------------------------------- +!> The type declaration for the kernel. Contains the metadata needed by the PSy layer +type, public, extends(kernel_type) :: atl_vertical_mass_flux_kernel_type + private + type(arg_type) :: meta_args(4) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_READINC, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_INC, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1) & + /) + integer :: operates_on = CELL_COLUMN +contains + procedure, nopass :: atl_vertical_mass_flux_code +end type + +!------------------------------------------------------------------------------- +! Contained functions/subroutines +!------------------------------------------------------------------------------- +public :: atl_vertical_mass_flux_code + +contains + +!> @brief Computes the vertical mass flux: wind*reconstruction. +!> @param[in] nlayers Number of layers +!> @param[in,out] mass_flux Vertical mass flux +!> @param[in] ls_wind Linear wind field +!> @param[in,out] wind Perturbation wind field +!> @param[in] reconstruction Tracer field reconstructed on cell edges +!> @param[in] ndf_w2 Number of degrees of freedom per cell +!> @param[in] undf_w2 Number of unique degrees of freedom for the wind field +!> @param[in] map_w2 Dofmap for the cell at the base of the column +!> @param[in] ndf_md Number of degrees of freedom per cell +!> @param[in] undf_md Number of unique degrees of freedom for the +!! reconstructed field +!> @param[in] map_md Dofmap for the cell at the base of the column +subroutine atl_vertical_mass_flux_code( nlayers, & + mass_flux, & + ls_wind, & + wind, & + reconstruction, & + ndf_w2, & + undf_w2, & + map_w2, & + ndf_md, & + undf_md, & + map_md ) + + implicit none + + ! Arguments + integer(kind=i_def), intent(in) :: nlayers + integer(kind=i_def), intent(in) :: ndf_md + integer(kind=i_def), intent(in) :: undf_md + integer(kind=i_def), dimension(ndf_md), intent(in) :: map_md + integer(kind=i_def), intent(in) :: ndf_w2 + integer(kind=i_def), intent(in) :: undf_w2 + integer(kind=i_def), dimension(ndf_w2), intent(in) :: map_w2 + + real(kind=r_def), dimension(undf_md), intent(in) :: reconstruction + real(kind=r_def), dimension(undf_w2), intent(inout) :: wind + real(kind=r_def), dimension(undf_w2), intent(in) :: ls_wind + real(kind=r_def), dimension(undf_w2), intent(inout) :: mass_flux + + ! Internal variables + integer(kind=i_def) :: k, df, ijp1, ijp2, offset + real(kind=r_def) :: wgt + + ! df of dof on face + if ( ndf_w2 == 2 ) then + ! W2v space, reconstruction has ndata=2 + df = 1 + offset = 0 + else + ! W2 space, reconstruction has ndata=6 + df = 5 + offset = 4*nlayers + end if + + mass_flux( map_w2(df) + nlayers ) = 0.0_r_def + do k = nlayers - 1, 1, -1 + ! Value from bottom face of cell above edge + ijp2 = map_md(1) + offset + nlayers + k-1 + ! Take value from top face of cell below edge + ijp1 = map_md(1) + offset + k + + wgt = (0.5_r_def - sign(0.5_r_def, ls_wind(map_w2(df)+k))) + wind(k + map_w2(df)) = wind(k + map_w2(df)) & + + mass_flux(map_w2(df) + k)*( & + wgt*reconstruction(ijp1) & + + (1.0_r_def-wgt)*reconstruction(ijp2)) + + end do + mass_flux( map_w2(df) ) = 0.0_r_def + +end subroutine atl_vertical_mass_flux_code + +end module atl_vertical_mass_flux_kernel_mod From 498afdeade47ec1b429384514dd1fc8c14504704 Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Thu, 16 Jul 2026 15:52:43 +0100 Subject: [PATCH 06/22] Added source code for adj_horizontal_mass_flux and adj_vertical_mass_flux --- .../mol/adjt_horizontal_mass_flux_alg_mod.x90 | 140 ++++++++++++++++++ .../mol/adjt_vertical_mass_flux_alg_mod.x90 | 140 ++++++++++++++++++ .../source/driver/adjoint_test_driver_mod.f90 | 4 + .../adjoint/build/psyad_files_list_apps.txt | 2 - science/adjoint/build/psyad_vars.mk | 2 - .../adjt_horizontal_mass_flux_alg_mod.patch | 91 ------------ .../adjt_vertical_mass_flux_alg_mod.patch | 89 ----------- .../adj_horizontal_mass_flux_kernel_mod.patch | 11 -- .../adj_vertical_mass_flux_kernel_mod.patch | 38 ----- .../horizontal_mass_flux_kernel_mod.patch | 11 -- .../adj_horizontal_mass_flux_kernel_mod.F90 | 112 ++++++++++++++ .../mol/adj_vertical_mass_flux_kernel_mod.F90 | 123 +++++++++++++++ 12 files changed, 519 insertions(+), 244 deletions(-) create mode 100644 applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 create mode 100644 applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 delete mode 100644 science/adjoint/patches/algorithm/adjt_horizontal_mass_flux_alg_mod.patch delete mode 100644 science/adjoint/patches/algorithm/adjt_vertical_mass_flux_alg_mod.patch delete mode 100644 science/adjoint/patches/kernel/adj_horizontal_mass_flux_kernel_mod.patch delete mode 100644 science/adjoint/patches/kernel/adj_vertical_mass_flux_kernel_mod.patch delete mode 100644 science/adjoint/patches/kernel/horizontal_mass_flux_kernel_mod.patch create mode 100644 science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 create mode 100644 science/adjoint/source/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod.F90 diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 new file mode 100644 index 0000000000..33b4ede366 --- /dev/null +++ b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 @@ -0,0 +1,140 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> @brief Module containing adjoint test for adj_horizontal_mass_flux_kernel +module adjt_horizontal_mass_flux_alg_mod + + use config_mod, only : config_type + use r_tran_field_mod, only : r_tran_field_type + use function_space_mod, only : function_space_type + use mesh_mod, only : mesh_type + use function_space_collection_mod, only : function_space_collection + use fs_continuity_mod, only : W2, W3 + use constants_mod, only : i_def, r_def, r_tran, EPS + use log_mod, only : log_event, & + log_scratch_space, & + LOG_LEVEL_ERROR, & + LOG_LEVEL_INFO, & + LOG_LEVEL_DEBUG + + implicit none + + public + + contains + + !============================================================================= + !> @brief Adjoint test for adj_horizontal_mass_flux. + !> @details Passes if adjoint is transpose of tangent linear. + !> Determined by testing the equality of inner products and , + !> where M is the tangent linear and A is the adjoint. + !> @param[in] config Application namelist configuration object + !> @param[in] mesh Mesh object + subroutine adjt_horizontal_mass_flux_alg(config, mesh) + + use horizontal_mass_flux_kernel_mod, only : horizontal_mass_flux_kernel_type + use adj_horizontal_mass_flux_kernel_mod, only : adj_horizontal_mass_flux_kernel_type + + implicit none + + ! Arguments + type(config_type), intent(in) :: config + type(mesh_type), pointer, intent(in) :: mesh + + ! Arguments for tl and adj calls + type(r_tran_field_type) :: mass_flux + type(r_tran_field_type) :: wind + type(r_tran_field_type) :: reconstruction + + ! Copies of input fields used in inner products + type(r_tran_field_type) :: mass_flux_input + type(r_tran_field_type) :: reconstruction_input + + ! Variables for initialising fields + type(function_space_type), pointer :: vector_space_w2_ptr + type(function_space_type), pointer :: vector_space_w3_ptr + integer(kind=i_def) :: element_order_h + integer(kind=i_def) :: element_order_v + integer(kind=i_def), parameter :: ndata = 6 + + ! Inner products + real(kind=r_def) :: mass_flux_inner_prod + real(kind=r_def) :: reconstruction_inner_prod + real(kind=r_tran) :: mass_flux_sf + real(kind=r_tran) :: reconstruction_sf + real(kind=r_tran) :: inner1 + real(kind=r_def) :: mass_flux_mass_flux_input_inner_prod + real(kind=r_def) :: reconstruction_reconstruction_input_inner_prod + real(kind=r_tran) :: inner2 + + ! Test parameters and variables + real(kind=r_tran), parameter :: overall_tolerance = 1500.0_r_tran + real(kind=r_tran) :: machine_tol + real(kind=r_tran) :: relative_diff + + element_order_h = config%finite_element%element_order_h() + element_order_v = config%finite_element%element_order_v() + vector_space_w2_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W2) + vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W3, & + ndata, ndata_first = .false.) + call mass_flux%initialise(vector_space=vector_space_w2_ptr, name='mass_flux') + call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') + call reconstruction%initialise(vector_space=vector_space_w3_ptr, name='reconstruction') + + call mass_flux%copy_field_properties(mass_flux_input) + call reconstruction%copy_field_properties(reconstruction_input) + mass_flux_inner_prod = 0.0_r_def + reconstruction_inner_prod = 0.0_r_def + + ! Initialise arguments and call the tangent-linear kernel. + call invoke( setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), & + setval_random(wind), & + setval_random(reconstruction), setval_x(reconstruction_input, reconstruction), & + horizontal_mass_flux_kernel_type(mass_flux, wind, reconstruction), & + x_innerproduct_x(mass_flux_inner_prod, mass_flux), & + x_innerproduct_x(reconstruction_inner_prod, reconstruction) ) + + write( log_scratch_space, * ) "adjt_horizontal_mass_flux inner products:" + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "mass_flux inner product = ", mass_flux_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "reconstruction inner product = ", reconstruction_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + + mass_flux_sf = 1.0_r_tran / ( real(mass_flux_inner_prod, kind=r_tran) + EPS ) + reconstruction_sf = 1.0_r_tran / ( real(reconstruction_inner_prod, kind=r_tran) + EPS ) + + inner1 = 0.0_r_tran + inner1 = inner1 + real(mass_flux_inner_prod, kind=r_tran) * mass_flux_sf + inner1 = inner1 + real(reconstruction_inner_prod, kind=r_tran) * reconstruction_sf + + mass_flux_mass_flux_input_inner_prod = 0.0_r_def + reconstruction_reconstruction_input_inner_prod = 0.0_r_def + call invoke( inc_a_times_X(mass_flux_sf, mass_flux), & + inc_a_times_X(reconstruction_sf, reconstruction), & + adj_horizontal_mass_flux_kernel_type(mass_flux, wind, reconstruction), & + x_innerproduct_y(mass_flux_mass_flux_input_inner_prod, & + mass_flux, mass_flux_input), & + x_innerproduct_y(reconstruction_reconstruction_input_inner_prod, & + reconstruction, reconstruction_input) ) + + inner2 = 0.0_r_tran + inner2 = inner2 + real(mass_flux_mass_flux_input_inner_prod, kind=r_tran) + inner2 = inner2 + real(reconstruction_reconstruction_input_inner_prod, kind=r_tran) + + ! Test the inner-product values for equality, allowing for the precision of the active variables + machine_tol = spacing(max(abs(inner1), abs(inner2))) + relative_diff = abs(inner1 - inner2) / machine_tol + if (relative_diff < overall_tolerance) then + write(log_scratch_space, *) "PASSED horizontal_mass_flux_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_INFO) + else + write(log_scratch_space, *) "FAILED horizontal_mass_flux_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_ERROR) + end if + + end subroutine adjt_horizontal_mass_flux_alg + +end module adjt_horizontal_mass_flux_alg_mod diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 new file mode 100644 index 0000000000..a8c80243f7 --- /dev/null +++ b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 @@ -0,0 +1,140 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> @brief Module containing adjoint test for adj_vertical_mass_flux_kernel +module adjt_vertical_mass_flux_alg_mod + + use config_mod, only : config_type + use r_tran_field_mod, only : r_tran_field_type + use function_space_mod, only : function_space_type + use mesh_mod, only : mesh_type + use function_space_collection_mod, only : function_space_collection + use fs_continuity_mod, only : W2, W3 + use constants_mod, only : i_def, r_def, r_tran, EPS + use log_mod, only : log_event, & + log_scratch_space, & + LOG_LEVEL_ERROR, & + LOG_LEVEL_INFO, & + LOG_LEVEL_DEBUG + + implicit none + + public + + contains + + !============================================================================= + !> @brief Adjoint test for adj_vertical_mass_flux. + !> @details Passes if adjoint is transpose of tangent linear. + !> Determined by testing the equality of inner products and , + !> where M is the tangent linear and A is the adjoint. + !> @param[in] config Application namelist configuration object + !> @param[in] mesh Mesh object + subroutine adjt_vertical_mass_flux_alg(config, mesh) + + use vertical_mass_flux_kernel_mod, only : vertical_mass_flux_kernel_type + use adj_vertical_mass_flux_kernel_mod, only : adj_vertical_mass_flux_kernel_type + + implicit none + + ! Arguments + type(config_type), intent(in) :: config + type(mesh_type), pointer, intent(in) :: mesh + + ! Arguments for tl and adj calls + type(r_tran_field_type) :: mass_flux + type(r_tran_field_type) :: wind + type(r_tran_field_type) :: reconstruction + + ! Copies of input fields used in inner products + type(r_tran_field_type) :: mass_flux_input + type(r_tran_field_type) :: reconstruction_input + + ! Variables for initialising fields + type(function_space_type), pointer :: vector_space_w2_ptr + type(function_space_type), pointer :: vector_space_w3_ptr + integer(kind=i_def) :: element_order_h + integer(kind=i_def) :: element_order_v + integer(kind=i_def), parameter :: ndata = 6 + + ! Inner products + real(kind=r_def) :: mass_flux_inner_prod + real(kind=r_def) :: reconstruction_inner_prod + real(kind=r_tran) :: mass_flux_sf + real(kind=r_tran) :: reconstruction_sf + real(kind=r_tran) :: inner1 + real(kind=r_def) :: mass_flux_mass_flux_input_inner_prod + real(kind=r_def) :: reconstruction_reconstruction_input_inner_prod + real(kind=r_tran) :: inner2 + + ! Test parameters and variables + real(kind=r_tran), parameter :: overall_tolerance = 1500.0_r_tran + real(kind=r_tran) :: machine_tol + real(kind=r_tran) :: relative_diff + + element_order_h = config%finite_element%element_order_h() + element_order_v = config%finite_element%element_order_v() + vector_space_w2_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W2) + vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W3, & + ndata, ndata_first = .false.) + call mass_flux%initialise(vector_space=vector_space_w2_ptr, name='mass_flux') + call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') + call reconstruction%initialise(vector_space=vector_space_w3_ptr, name='reconstruction') + + call mass_flux%copy_field_properties(mass_flux_input) + call reconstruction%copy_field_properties(reconstruction_input) + mass_flux_inner_prod = 0.0_r_def + reconstruction_inner_prod = 0.0_r_def + + ! Initialise arguments and call the tangent-linear kernel. + call invoke( setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), & + setval_random(wind), & + setval_random(reconstruction), setval_x(reconstruction_input, reconstruction), & + vertical_mass_flux_kernel_type(mass_flux, wind, reconstruction), & + x_innerproduct_x(mass_flux_inner_prod, mass_flux), & + x_innerproduct_x(reconstruction_inner_prod, reconstruction) ) + + write( log_scratch_space, * ) "adjt_vertical_mass_flux inner products:" + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "mass_flux inner product = ", mass_flux_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "reconstruction inner product = ", reconstruction_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + + mass_flux_sf = 1.0_r_tran / ( real(mass_flux_inner_prod, kind=r_tran) + EPS ) + reconstruction_sf = 1.0_r_tran / ( real(reconstruction_inner_prod, kind=r_tran) + EPS ) + + inner1 = 0.0_r_tran + inner1 = inner1 + real(mass_flux_inner_prod, kind=r_tran) * mass_flux_sf + inner1 = inner1 + real(reconstruction_inner_prod, kind=r_tran) * reconstruction_sf + + mass_flux_mass_flux_input_inner_prod = 0.0_r_def + reconstruction_reconstruction_input_inner_prod = 0.0_r_def + call invoke( inc_a_times_X(mass_flux_sf, mass_flux), & + inc_a_times_X(reconstruction_sf, reconstruction), & + adj_vertical_mass_flux_kernel_type(mass_flux, wind, reconstruction), & + x_innerproduct_y(mass_flux_mass_flux_input_inner_prod, & + mass_flux, mass_flux_input), & + x_innerproduct_y(reconstruction_reconstruction_input_inner_prod, & + reconstruction, reconstruction_input) ) + + inner2 = 0.0_r_tran + inner2 = inner2 + real(mass_flux_mass_flux_input_inner_prod, kind=r_tran) + inner2 = inner2 + real(reconstruction_reconstruction_input_inner_prod, kind=r_tran) + + ! Test the inner-product values for equality, allowing for the precision of the active variables + machine_tol = spacing(max(abs(inner1), abs(inner2))) + relative_diff = abs(inner1 - inner2) / machine_tol + if (relative_diff < overall_tolerance) then + write(log_scratch_space, *) "PASSED vertical_mass_flux_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_INFO) + else + write(log_scratch_space, *) "FAILED vertical_mass_flux_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_ERROR) + end if + + end subroutine adjt_vertical_mass_flux_alg + +end module adjt_vertical_mass_flux_alg_mod diff --git a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 index 54854c86bf..dc73aadb15 100644 --- a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 +++ b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 @@ -93,6 +93,8 @@ subroutine run( modeldb ) use atlt_poly1d_vert_adv_alg_mod, only : atlt_poly1d_vert_adv_alg use atlt_horizontal_mass_flux_alg_mod, only : atlt_horizontal_mass_flux_alg use atlt_vertical_mass_flux_alg_mod, only : atlt_vertical_mass_flux_alg + use adjt_horizontal_mass_flux_alg_mod, only : adjt_horizontal_mass_flux_alg + use adjt_vertical_mass_flux_alg_mod, only : adjt_vertical_mass_flux_alg ! ./transport/control use atlt_transport_field_alg_mod, only : atlt_transport_field_alg @@ -168,6 +170,8 @@ subroutine run( modeldb ) call atlt_poly1d_vert_adv_alg( modeldb%config, mesh ) call atlt_horizontal_mass_flux_alg( modeldb%config, mesh ) call atlt_vertical_mass_flux_alg( modeldb%config, mesh ) + call adjt_horizontal_mass_flux_alg( modeldb%config, mesh ) + call adjt_vertical_mass_flux_alg( modeldb%config, mesh ) ! -- Lookup table solutions. call adjt_poly1d_recon_lookup_alg( modeldb%config, mesh, adj_trans_lookup_cache ) call adjt_poly2d_recon_lookup_alg( modeldb%config, mesh, Wtheta, adj_trans_lookup_cache ) diff --git a/science/adjoint/build/psyad_files_list_apps.txt b/science/adjoint/build/psyad_files_list_apps.txt index a9eda3c3e2..d6bcaabaad 100644 --- a/science/adjoint/build/psyad_files_list_apps.txt +++ b/science/adjoint/build/psyad_files_list_apps.txt @@ -4,6 +4,4 @@ science/gungho/source/kernel/solver/apply_mixed_lu_operator_kernel_mod.F90 science/gungho/source/kernel/solver/apply_mixed_operator_kernel_mod.F90 science/gungho/source/kernel/solver/opt_apply_variable_hx_kernel_mod.F90 science/gungho/source/kernel/solver/apply_elim_mixed_lp_operator_kernel_mod.F90 -science/gungho/source/kernel/transport/mol/horizontal_mass_flux_kernel_mod.F90 -science/gungho/source/kernel/transport/mol/vertical_mass_flux_kernel_mod.F90 science/gungho/source/kernel/transport/mol/w3v_advective_update_kernel_mod.F90 diff --git a/science/adjoint/build/psyad_vars.mk b/science/adjoint/build/psyad_vars.mk index 6f556c6387..d05a57ec95 100644 --- a/science/adjoint/build/psyad_vars.mk +++ b/science/adjoint/build/psyad_vars.mk @@ -24,5 +24,3 @@ all: export ACTIVE_sci_extract_w_kernel_mod := velocity_w2v u_physic all: export ACTIVE_sci_combine_multidata_field_kernel_mod := field1_in field2_in field_out all: export ACTIVE_w3v_advective_update_kernel_mod := advective_increment tracer dtdz t_U t_D all: export ACTIVE_tl_w3v_advective_update_kernel_mod := advective_increment wind w -all: export ACTIVE_horizontal_mass_flux_kernel_mod := mass_flux reconstruction -all: export ACTIVE_vertical_mass_flux_kernel_mod := mass_flux reconstruction diff --git a/science/adjoint/patches/algorithm/adjt_horizontal_mass_flux_alg_mod.patch b/science/adjoint/patches/algorithm/adjt_horizontal_mass_flux_alg_mod.patch deleted file mode 100644 index b37b090b93..0000000000 --- a/science/adjoint/patches/algorithm/adjt_horizontal_mass_flux_alg_mod.patch +++ /dev/null @@ -1,91 +0,0 @@ -@@ -12,10 +12,10 @@ - use adj_horizontal_mass_flux_kernel_mod, only : adj_horizontal_mass_flux_kernel_type - use finite_element_config_mod, only : element_order_h, element_order_v - use fs_continuity_mod, only : w2, w3 -- use constants_mod, only : i_def, r_def -+ use constants_mod, only : i_def, r_def, r_tran - use setop_random_kernel_mod, only : setop_random_kernel_type -- use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space -- real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def -+ use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space, log_level_debug -+ real(kind=r_tran), parameter :: overall_tolerance = 1500.0_r_tran - type(mesh_type), pointer, intent(in) :: mesh - type(field_type), dimension(3), intent(in), optional :: chi - type(field_type), intent(in), optional :: panel_id -@@ -25,51 +25,54 @@ - type(field_type) :: wind - type(field_type) :: reconstruction - type(field_type) :: mass_flux_input -- type(field_type) :: wind_input - type(field_type) :: reconstruction_input - real(kind=r_def) :: mass_flux_inner_prod -- real(kind=r_def) :: wind_inner_prod - real(kind=r_def) :: reconstruction_inner_prod -- real(kind=r_def) :: inner1 -+ real(kind=r_def) :: mass_flux_sf -+ real(kind=r_def) :: reconstruction_sf -+ real(kind=r_tran) :: inner1 - real(kind=r_def) :: mass_flux_mass_flux_input_inner_prod -- real(kind=r_def) :: wind_wind_input_inner_prod - real(kind=r_def) :: reconstruction_reconstruction_input_inner_prod -- real(kind=r_def) :: inner2 -+ real(kind=r_tran) :: inner2 - real(kind=r_def) :: MachineTol - real(kind=r_def) :: relative_diff -+ real(kind=r_def), parameter :: eps = 1.0e-30_r_def - - vector_space_w2_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w2) -- vector_space_w3_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w3) -+ vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, w3, 6, ndata_first = .false.) - call mass_flux%initialise(vector_space=vector_space_w2_ptr, name='mass_flux') - call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') - call reconstruction%initialise(vector_space=vector_space_w3_ptr, name='reconstruction') - call mass_flux_input%initialise(vector_space=vector_space_w2_ptr, name='mass_flux_input') -- call wind_input%initialise(vector_space=vector_space_w2_ptr, name='wind_input') - call reconstruction_input%initialise(vector_space=vector_space_w3_ptr, name='reconstruction_input') - mass_flux_inner_prod = 0.0_r_def -- wind_inner_prod = 0.0_r_def - reconstruction_inner_prod = 0.0_r_def -- - ! Initialise arguments and call the tangent-linear kernel. -- call invoke(setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), setval_random(wind), setval_x(wind_input, wind), & -+ call invoke(setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), setval_random(wind), & - &setval_random(reconstruction), setval_x(reconstruction_input, reconstruction), horizontal_mass_flux_kernel_type(mass_flux, wind, & --&reconstruction), x_innerproduct_x(mass_flux_inner_prod, mass_flux), x_innerproduct_x(wind_inner_prod, wind), & -+&reconstruction), x_innerproduct_x(mass_flux_inner_prod, mass_flux), & - &x_innerproduct_x(reconstruction_inner_prod, reconstruction)) -+ write( log_scratch_space, * ) "adjt_horizontal_mass_flux inner products:" -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "mass_flux inner product = ", mass_flux_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "reconstruction inner product = ", reconstruction_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ mass_flux_sf = 1.0_r_def / (mass_flux_inner_prod + eps) -+ reconstruction_sf = 1.0_r_def / (reconstruction_inner_prod + eps) - inner1 = 0.0_r_def -- inner1 = inner1 + mass_flux_inner_prod -- inner1 = inner1 + wind_inner_prod -- inner1 = inner1 + reconstruction_inner_prod -+ inner1 = inner1 + real(mass_flux_inner_prod * mass_flux_sf, r_tran) -+ inner1 = inner1 + real(reconstruction_inner_prod * reconstruction_sf, r_tran) -+ call invoke( inc_a_times_X( mass_flux_sf, mass_flux ), & -+ inc_a_times_X( reconstruction_sf, reconstruction ) ) - mass_flux_mass_flux_input_inner_prod = 0.0_r_def -- wind_wind_input_inner_prod = 0.0_r_def - reconstruction_reconstruction_input_inner_prod = 0.0_r_def - call invoke(adj_horizontal_mass_flux_kernel_type(mass_flux, wind, reconstruction), & --&x_innerproduct_y(mass_flux_mass_flux_input_inner_prod, mass_flux, mass_flux_input), x_innerproduct_y(wind_wind_input_inner_prod, & --&wind, wind_input), x_innerproduct_y(reconstruction_reconstruction_input_inner_prod, reconstruction, reconstruction_input)) -- inner2 = 0.0_r_def -- inner2 = inner2 + mass_flux_mass_flux_input_inner_prod -- inner2 = inner2 + wind_wind_input_inner_prod -- inner2 = inner2 + reconstruction_reconstruction_input_inner_prod -- -+&x_innerproduct_y(mass_flux_mass_flux_input_inner_prod, mass_flux, mass_flux_input), & -+&x_innerproduct_y(reconstruction_reconstruction_input_inner_prod, reconstruction, reconstruction_input)) -+ inner2 = 0.0_r_tran -+ inner2 = inner2 + real(mass_flux_mass_flux_input_inner_prod, r_tran) -+ inner2 = inner2 + real(reconstruction_reconstruction_input_inner_prod, r_tran) - ! Test the inner-product values for equality, allowing for the precision of the active variables - MachineTol = SPACING(MAX(ABS(inner1), ABS(inner2))) - relative_diff = ABS(inner1 - inner2) / MachineTol diff --git a/science/adjoint/patches/algorithm/adjt_vertical_mass_flux_alg_mod.patch b/science/adjoint/patches/algorithm/adjt_vertical_mass_flux_alg_mod.patch deleted file mode 100644 index c1e8ce2a8d..0000000000 --- a/science/adjoint/patches/algorithm/adjt_vertical_mass_flux_alg_mod.patch +++ /dev/null @@ -1,89 +0,0 @@ -@@ -12,9 +12,9 @@ - use adj_vertical_mass_flux_kernel_mod, only : adj_vertical_mass_flux_kernel_type - use finite_element_config_mod, only : element_order_h, element_order_v - use fs_continuity_mod, only : w2, w3 -- use constants_mod, only : i_def, r_def -+ use constants_mod, only : i_def, r_def, r_tran - use setop_random_kernel_mod, only : setop_random_kernel_type -- use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space -+ use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space, log_level_debug - real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def - type(mesh_type), pointer, intent(in) :: mesh - type(field_type), dimension(3), intent(in), optional :: chi -@@ -25,51 +25,54 @@ - type(field_type) :: wind - type(field_type) :: reconstruction - type(field_type) :: mass_flux_input -- type(field_type) :: wind_input - type(field_type) :: reconstruction_input - real(kind=r_def) :: mass_flux_inner_prod -- real(kind=r_def) :: wind_inner_prod - real(kind=r_def) :: reconstruction_inner_prod -- real(kind=r_def) :: inner1 -+ real(kind=r_def) :: mass_flux_sf -+ real(kind=r_def) :: reconstruction_sf -+ real(kind=r_tran) :: inner1 - real(kind=r_def) :: mass_flux_mass_flux_input_inner_prod -- real(kind=r_def) :: wind_wind_input_inner_prod - real(kind=r_def) :: reconstruction_reconstruction_input_inner_prod -- real(kind=r_def) :: inner2 -+ real(kind=r_tran) :: inner2 - real(kind=r_def) :: MachineTol - real(kind=r_def) :: relative_diff -+ real(kind=r_def), parameter :: eps = 1.0e-30_r_def - - vector_space_w2_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w2) -- vector_space_w3_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w3) -+ vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, w3, 6, ndata_first = .false.) - call mass_flux%initialise(vector_space=vector_space_w2_ptr, name='mass_flux') - call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') - call reconstruction%initialise(vector_space=vector_space_w3_ptr, name='reconstruction') - call mass_flux_input%initialise(vector_space=vector_space_w2_ptr, name='mass_flux_input') -- call wind_input%initialise(vector_space=vector_space_w2_ptr, name='wind_input') - call reconstruction_input%initialise(vector_space=vector_space_w3_ptr, name='reconstruction_input') - mass_flux_inner_prod = 0.0_r_def -- wind_inner_prod = 0.0_r_def - reconstruction_inner_prod = 0.0_r_def -- - ! Initialise arguments and call the tangent-linear kernel. -- call invoke(setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), setval_random(wind), setval_x(wind_input, wind), & -+ call invoke(setval_random(mass_flux), setval_x(mass_flux_input, mass_flux), setval_random(wind), & - &setval_random(reconstruction), setval_x(reconstruction_input, reconstruction), vertical_mass_flux_kernel_type(mass_flux, wind, & --&reconstruction), x_innerproduct_x(mass_flux_inner_prod, mass_flux), x_innerproduct_x(wind_inner_prod, wind), & -+&reconstruction), x_innerproduct_x(mass_flux_inner_prod, mass_flux), & - &x_innerproduct_x(reconstruction_inner_prod, reconstruction)) -+ write( log_scratch_space, * ) "adjt_vertical_mass_flux inner products:" -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "mass_flux inner product = ", mass_flux_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "reconstruction inner product = ", reconstruction_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ mass_flux_sf = 1.0_r_def / (mass_flux_inner_prod + eps) -+ reconstruction_sf = 1.0_r_def / (reconstruction_inner_prod + eps) - inner1 = 0.0_r_def -- inner1 = inner1 + mass_flux_inner_prod -- inner1 = inner1 + wind_inner_prod -- inner1 = inner1 + reconstruction_inner_prod -+ inner1 = inner1 + real(mass_flux_inner_prod * mass_flux_sf, r_tran) -+ inner1 = inner1 + real(reconstruction_inner_prod * reconstruction_sf, r_tran) -+ call invoke( inc_a_times_X( mass_flux_sf, mass_flux ), & -+ inc_a_times_X( reconstruction_sf, reconstruction ) ) - mass_flux_mass_flux_input_inner_prod = 0.0_r_def -- wind_wind_input_inner_prod = 0.0_r_def - reconstruction_reconstruction_input_inner_prod = 0.0_r_def - call invoke(adj_vertical_mass_flux_kernel_type(mass_flux, wind, reconstruction), & --&x_innerproduct_y(mass_flux_mass_flux_input_inner_prod, mass_flux, mass_flux_input), x_innerproduct_y(wind_wind_input_inner_prod, & --&wind, wind_input), x_innerproduct_y(reconstruction_reconstruction_input_inner_prod, reconstruction, reconstruction_input)) -- inner2 = 0.0_r_def -- inner2 = inner2 + mass_flux_mass_flux_input_inner_prod -- inner2 = inner2 + wind_wind_input_inner_prod -- inner2 = inner2 + reconstruction_reconstruction_input_inner_prod -- -+&x_innerproduct_y(mass_flux_mass_flux_input_inner_prod, mass_flux, mass_flux_input), & -+&x_innerproduct_y(reconstruction_reconstruction_input_inner_prod, reconstruction, reconstruction_input)) -+ inner2 = 0.0_r_tran -+ inner2 = inner2 + real(mass_flux_mass_flux_input_inner_prod, r_tran) -+ inner2 = inner2 + real(reconstruction_reconstruction_input_inner_prod, r_tran) - ! Test the inner-product values for equality, allowing for the precision of the active variables - MachineTol = SPACING(MAX(ABS(inner1), ABS(inner2))) - relative_diff = ABS(inner1 - inner2) / MachineTol diff --git a/science/adjoint/patches/kernel/adj_horizontal_mass_flux_kernel_mod.patch b/science/adjoint/patches/kernel/adj_horizontal_mass_flux_kernel_mod.patch deleted file mode 100644 index 4139690256..0000000000 --- a/science/adjoint/patches/kernel/adj_horizontal_mass_flux_kernel_mod.patch +++ /dev/null @@ -1,11 +0,0 @@ -@@ -38,9 +38,7 @@ - real(kind=r_tran) :: direction - real(kind=r_tran), dimension(nfaces) :: v_dot_n - -- v_dot_n(:) = 1.0_r_tran -- v_dot_n(1) = -1.00000000000000 -- v_dot_n(nfaces) = -1.00000000000000 -+ v_dot_n = (/ -1.0_r_tran, 1.0_r_tran, 1.0_r_tran, -1.0_r_tran /) - do df = nfaces, 1, -1 - do k = nlayers - 1, 0, -1 - direction = v_dot_n(df) * wind(k + map_w2(df)) diff --git a/science/adjoint/patches/kernel/adj_vertical_mass_flux_kernel_mod.patch b/science/adjoint/patches/kernel/adj_vertical_mass_flux_kernel_mod.patch deleted file mode 100644 index 8233ecfc7e..0000000000 --- a/science/adjoint/patches/kernel/adj_vertical_mass_flux_kernel_mod.patch +++ /dev/null @@ -1,38 +0,0 @@ -@@ -1,12 +1,12 @@ - module adj_vertical_mass_flux_kernel_mod - use argument_mod, only : any_discontinuous_space_1, any_w2, arg_type, cell_column, func_type, gh_field, gh_read, gh_readwrite, & --&gh_real, gh_write -+&gh_real, gh_readinc - use constants_mod, only : i_def, l_def, r_tran - use kernel_mod, only : kernel_type - implicit none - type, public, extends(kernel_type) :: adj_vertical_mass_flux_kernel_type - type(ARG_TYPE) :: META_ARGS(3) = (/ & -- arg_type(gh_field, gh_real, gh_write, any_w2), & -+ arg_type(gh_field, gh_real, gh_readinc, any_w2), & - arg_type(gh_field, gh_real, gh_read, any_w2), & - arg_type(gh_field, gh_real, gh_readwrite, any_discontinuous_space_1)/) - INTEGER :: OPERATES_ON = cell_column -@@ -44,17 +44,17 @@ - df = 5 - offset = 4 * nlayers - end if -- mass_flux(map_w2(df) + nlayers) = 0.0 -+ mass_flux(map_w2(df) + nlayers) = 0.0_r_tran - do k = nlayers - 1, 1, -1 - ijp2 = k + nlayers + offset + map_md(1) - 1 - ijp1 = k + offset + map_md(1) -- wgt = 0.5 - SIGN(0.5, wind(k + map_w2(df))) -+ wgt = 0.5_r_tran - SIGN(0.5_r_tran, wind(k + map_w2(df))) - reconstruction(ijp1) = reconstruction(ijp1) + wgt * mass_flux(map_w2(df) + k) * wind(k + map_w2(df)) - reconstruction(ijp2) = reconstruction(ijp2) - wgt * mass_flux(map_w2(df) + k) * wind(k + map_w2(df)) -- reconstruction(ijp2) = reconstruction(ijp2) + 1.0 * mass_flux(map_w2(df) + k) * wind(k + map_w2(df)) -- mass_flux(map_w2(df) + k) = 0.0 -+ reconstruction(ijp2) = reconstruction(ijp2) + mass_flux(map_w2(df) + k) * wind(k + map_w2(df)) -+ mass_flux(map_w2(df) + k) = 0.0_r_tran - enddo -- mass_flux(map_w2(df)) = 0.0 -+ mass_flux(map_w2(df)) = 0.0_r_tran - - end subroutine adj_vertical_mass_flux_code - diff --git a/science/adjoint/patches/kernel/horizontal_mass_flux_kernel_mod.patch b/science/adjoint/patches/kernel/horizontal_mass_flux_kernel_mod.patch deleted file mode 100644 index b165a9f73a..0000000000 --- a/science/adjoint/patches/kernel/horizontal_mass_flux_kernel_mod.patch +++ /dev/null @@ -1,11 +0,0 @@ -@@ -98,7 +98,9 @@ - - ! Implied direction of outward normals dotted with basis functions. - ! If u*u_dot_n > 0 then this is the upwind cell -- v_dot_n = (/ -1.0_r_tran, 1.0_r_tran, 1.0_r_tran, -1.0_r_tran /) -+ v_dot_n = 1.0_r_tran -+ v_dot_n(1) = -1.0_r_tran -+ v_dot_n(nfaces) = -1.0_r_tran - - ! Horizontal Flux - ! Reconstruction is stored on a layer first multidata field diff --git a/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 new file mode 100644 index 0000000000..4c3d573313 --- /dev/null +++ b/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 @@ -0,0 +1,112 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + +!> @brief Kernel which computes adjoint horizontal mass flux of a density by a wind +!! field +module adj_horizontal_mass_flux_kernel_mod + + use argument_mod, only : arg_type, func_type, & + GH_FIELD, & + GH_REAL, GH_READWRITE, & + GH_READ, & + CELL_COLUMN, & + ANY_DISCONTINUOUS_SPACE_1, & + ANY_W2 + use constants_mod, only : r_tran, i_def + use kernel_mod, only : kernel_type + + implicit none + + private + + !------------------------------------------------------------------------------- + ! Public types + !------------------------------------------------------------------------------- + !> The type declaration for the kernel. Contains the metadata needed by the PSy layer + type, public, extends(kernel_type) :: adj_horizontal_mass_flux_kernel_type + private + type(arg_type) :: meta_args(3) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_READWRITE, ANY_DISCONTINUOUS_SPACE_1) & + /) + integer :: operates_on = CELL_COLUMN + contains + procedure, nopass :: adj_horizontal_mass_flux_code + end type + + !------------------------------------------------------------------------------- + ! Contained functions/subroutines + !------------------------------------------------------------------------------- + public :: adj_horizontal_mass_flux_code + + contains + + !> @brief Computes the adjoint horizontal mass flux of a density by a wind + !> @param[in] nlayers Number of layers + !> @param[in,out] mass_flux Upwind mass flux to be computed + !> @param[in] wind Wind field + !> @param[in] reconstruction Density field computed on cell edges + !> @param[in] ndf_w2 Number of degrees of freedom per cell for the wind and flux fields + !> @param[in] undf_w2 Number of unique degrees of freedom for the wind and flux fields + !> @param[in] map_w2 Dofmap for the cell at the base of the column for the wind and flux fields + !> @param[in] ndf_md Number of degrees of freedom per cell for the multidata density field + !> @param[in] undf_md Number of unique degrees of freedom for the multidata density field + !> @param[in] map_md Dofmap for the cell at the base of the column for the multidata density field + subroutine adj_horizontal_mass_flux_code( nlayers, & + mass_flux, & + wind, & + reconstruction, & + ndf_w2, & + undf_w2, & + map_w2, & + ndf_md, & + undf_md, & + map_md ) + + implicit none + + ! Arguments + integer(kind=i_def), intent(in) :: nlayers + integer(kind=i_def), intent(in) :: ndf_md + integer(kind=i_def), intent(in) :: undf_md + integer(kind=i_def), dimension(ndf_md), intent(in) :: map_md + integer(kind=i_def), intent(in) :: ndf_w2 + integer(kind=i_def), intent(in) :: undf_w2 + integer(kind=i_def), dimension(ndf_w2), intent(in) :: map_w2 + + real(kind=r_tran), dimension(undf_md), intent(inout) :: reconstruction + real(kind=r_tran), dimension(undf_w2), intent(in) :: wind + real(kind=r_tran), dimension(undf_w2), intent(in) :: mass_flux + + ! Internal variables + integer(kind=i_def) :: k, df, ijp + integer(kind=i_def), parameter :: nfaces = 4 + real(kind=r_tran) :: direction + real(kind=r_tran), dimension(nfaces) :: v_dot_n + + ! Implied direction of outward normals dotted with basis functions. + ! If u*u_dot_n > 0 then this is the upwind cell + v_dot_n = (/ -1.0_r_tran, 1.0_r_tran, 1.0_r_tran, -1.0_r_tran /) + + do df = nfaces, 1, -1 + do k = nlayers - 1, 0, -1 + direction = wind(map_w2(df) + k)*v_dot_n(df) + if ( direction > 0.0_r_tran ) then + ! Take value on edge from this column + ijp = map_md(1) + (df-1)*nlayers + reconstruction(ijp + k) = reconstruction(ijp + k) & + + mass_flux(map_w2(df) + k)*wind(map_w2(df)+k) + + end if + end do + end do + + end subroutine adj_horizontal_mass_flux_code + +end module adj_horizontal_mass_flux_kernel_mod diff --git a/science/adjoint/source/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod.F90 new file mode 100644 index 0000000000..8b6cc52102 --- /dev/null +++ b/science/adjoint/source/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod.F90 @@ -0,0 +1,123 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + +!> @brief Kernel which computes adjoint vertical mass flux using an +!! upwind reconstruction of a field on cell edges +module adj_vertical_mass_flux_kernel_mod + + use argument_mod, only : arg_type, func_type, & + GH_FIELD, GH_REAL, & + GH_READINC, GH_READWRITE, & + GH_READ, & + CELL_COLUMN, & + ANY_DISCONTINUOUS_SPACE_1, & + ANY_W2 + use constants_mod, only : r_tran, i_def, l_def + use kernel_mod, only : kernel_type + + implicit none + + private + + !------------------------------------------------------------------------------- + ! Public types + !------------------------------------------------------------------------------- + !> The type declaration for the kernel. Contains the metadata needed by the PSy layer + type, public, extends(kernel_type) :: adj_vertical_mass_flux_kernel_type + private + type(arg_type) :: meta_args(3) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_READINC, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_READWRITE, ANY_DISCONTINUOUS_SPACE_1) & + /) + integer :: operates_on = CELL_COLUMN + contains + procedure, nopass :: adj_vertical_mass_flux_code + end type + + !------------------------------------------------------------------------------- + ! Contained functions/subroutines + !------------------------------------------------------------------------------- + public :: adj_vertical_mass_flux_code + + contains + + !> @brief Computes the adjoint vertical mass flux. + !> @param[in] nlayers Number of layers + !> @param[in,out] mass_flux Vertical mass flux + !> @param[in] wind Wind field + !> @param[in,out] reconstruction Tracer field reconstructed on cell edges + !> @param[in] ndf_w2 Number of degrees of freedom per cell + !> @param[in] undf_w2 Number of unique degrees of freedom for the wind field + !> @param[in] map_w2 Dofmap for the cell at the base of the column + !> @param[in] ndf_md Number of degrees of freedom per cell + !> @param[in] undf_md Number of unique degrees of freedom for the + !! reconstructed field + !> @param[in] map_md Dofmap for the cell at the base of the column + subroutine adj_vertical_mass_flux_code( nlayers, & + mass_flux, & + wind, & + reconstruction, & + ndf_w2, & + undf_w2, & + map_w2, & + ndf_md, & + undf_md, & + map_md ) + + implicit none + + ! Arguments + integer(kind=i_def), intent(in) :: nlayers + integer(kind=i_def), intent(in) :: ndf_md + integer(kind=i_def), intent(in) :: undf_md + integer(kind=i_def), dimension(ndf_md), intent(in) :: map_md + integer(kind=i_def), intent(in) :: ndf_w2 + integer(kind=i_def), intent(in) :: undf_w2 + integer(kind=i_def), dimension(ndf_w2), intent(in) :: map_w2 + + real(kind=r_tran), dimension(undf_md), intent(inout) :: reconstruction + real(kind=r_tran), dimension(undf_w2), intent(in) :: wind + real(kind=r_tran), dimension(undf_w2), intent(inout) :: mass_flux + + ! Internal variables + integer(kind=i_def) :: k, df, ijp1, ijp2, offset + real(kind=r_tran) :: wgt + + ! df of dof on face + if ( ndf_w2 == 2 ) then + ! W2v space, reconstruction has ndata=2 + df = 1 + offset = 0 + else + ! W2 space, reconstruction has ndata=6 + df = 5 + offset = 4*nlayers + end if + + mass_flux( map_w2(df) + nlayers ) = 0.0_r_tran + do k = nlayers - 1, 1, -1 + ! Value from bottom face of cell above edge + ijp2 = map_md(1) + offset + nlayers + k-1 + ! Take value from top face of cell below edge + ijp1 = map_md(1) + offset + k + + wgt = (0.5_r_tran - sign(0.5_r_tran, wind(map_w2(df)+k))) + + reconstruction(ijp1) = reconstruction(ijp1) & + + wind(map_w2(df)+k)*wgt*mass_flux(map_w2(df) + k) + reconstruction(ijp2) = reconstruction(ijp2) & + + wind(map_w2(df)+k)*(1.0_r_tran-wgt)*mass_flux(map_w2(df) + k) + mass_flux(map_w2(df) + k) = 0.0_r_tran + + end do + mass_flux( map_w2(df) ) = 0.0_r_tran + + end subroutine adj_vertical_mass_flux_code + +end module adj_vertical_mass_flux_kernel_mod From 14b71b4562274b27d45aeef45491b3d145ef9ca3 Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 21 Jul 2026 10:41:48 +0100 Subject: [PATCH 07/22] Added source code for w3v_adv_upd. Changed EPS to EPS_R_TRAN to match the kinds properly on scale factor calculations in the transport adjoint tests. --- .../mol/adjt_horizontal_mass_flux_alg_mod.x90 | 7 +- .../mol/adjt_vertical_mass_flux_alg_mod.x90 | 7 +- .../mol/adjt_w3v_advective_update_alg_mod.x90 | 151 +++++++++++++++++ .../mol/atlt_w3v_advective_update_alg_mod.x90 | 154 ++++++++++++++++++ .../source/driver/adjoint_test_driver_mod.f90 | 12 +- .../adjoint/build/psyad_files_list_apps.txt | 2 - science/adjoint/build/psyad_vars.mk | 2 - .../adjt_w3v_advective_update_alg_mod.patch | 93 ----------- .../atlt_w3v_advective_update_alg_mod.patch | 106 ------------ .../adj_w3v_advective_update_kernel_mod.patch | 42 ----- .../atl_w3v_advective_update_kernel_mod.patch | 58 ------- .../adj_w3v_advective_update_kernel_mod.F90 | 137 ++++++++++++++++ .../atl_w3v_advective_update_kernel_mod.F90 | 151 +++++++++++++++++ 13 files changed, 609 insertions(+), 313 deletions(-) create mode 100644 applications/adjoint_tests/source/algorithm/transport/mol/adjt_w3v_advective_update_alg_mod.x90 create mode 100644 applications/adjoint_tests/source/algorithm/transport/mol/atlt_w3v_advective_update_alg_mod.x90 delete mode 100644 science/adjoint/patches/algorithm/adjt_w3v_advective_update_alg_mod.patch delete mode 100644 science/adjoint/patches/algorithm/atlt_w3v_advective_update_alg_mod.patch delete mode 100644 science/adjoint/patches/kernel/adj_w3v_advective_update_kernel_mod.patch delete mode 100644 science/adjoint/patches/kernel/atl_w3v_advective_update_kernel_mod.patch create mode 100644 science/adjoint/source/kernel/transport/mol/adj_w3v_advective_update_kernel_mod.F90 create mode 100644 science/adjoint/source/kernel/transport/mol/atl_w3v_advective_update_kernel_mod.F90 diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 index 33b4ede366..7a14c618d0 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 @@ -12,7 +12,8 @@ module adjt_horizontal_mass_flux_alg_mod use mesh_mod, only : mesh_type use function_space_collection_mod, only : function_space_collection use fs_continuity_mod, only : W2, W3 - use constants_mod, only : i_def, r_def, r_tran, EPS + use constants_mod, only : i_def, r_def, & + r_tran, EPS_R_TRAN use log_mod, only : log_event, & log_scratch_space, & LOG_LEVEL_ERROR, & @@ -103,8 +104,8 @@ module adjt_horizontal_mass_flux_alg_mod write( log_scratch_space, * ) "reconstruction inner product = ", reconstruction_inner_prod call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) - mass_flux_sf = 1.0_r_tran / ( real(mass_flux_inner_prod, kind=r_tran) + EPS ) - reconstruction_sf = 1.0_r_tran / ( real(reconstruction_inner_prod, kind=r_tran) + EPS ) + mass_flux_sf = 1.0_r_tran / ( real(mass_flux_inner_prod, kind=r_tran) + EPS_R_TRAN ) + reconstruction_sf = 1.0_r_tran / ( real(reconstruction_inner_prod, kind=r_tran) + EPS_R_TRAN ) inner1 = 0.0_r_tran inner1 = inner1 + real(mass_flux_inner_prod, kind=r_tran) * mass_flux_sf diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 index a8c80243f7..bd539b1c2b 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 @@ -12,7 +12,8 @@ module adjt_vertical_mass_flux_alg_mod use mesh_mod, only : mesh_type use function_space_collection_mod, only : function_space_collection use fs_continuity_mod, only : W2, W3 - use constants_mod, only : i_def, r_def, r_tran, EPS + use constants_mod, only : i_def, r_def, & + r_tran, EPS_R_TRAN use log_mod, only : log_event, & log_scratch_space, & LOG_LEVEL_ERROR, & @@ -103,8 +104,8 @@ module adjt_vertical_mass_flux_alg_mod write( log_scratch_space, * ) "reconstruction inner product = ", reconstruction_inner_prod call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) - mass_flux_sf = 1.0_r_tran / ( real(mass_flux_inner_prod, kind=r_tran) + EPS ) - reconstruction_sf = 1.0_r_tran / ( real(reconstruction_inner_prod, kind=r_tran) + EPS ) + mass_flux_sf = 1.0_r_tran / ( real(mass_flux_inner_prod, kind=r_tran) + EPS_R_TRAN ) + reconstruction_sf = 1.0_r_tran / ( real(reconstruction_inner_prod, kind=r_tran) + EPS_R_TRAN ) inner1 = 0.0_r_tran inner1 = inner1 + real(mass_flux_inner_prod, kind=r_tran) * mass_flux_sf diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_w3v_advective_update_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_w3v_advective_update_alg_mod.x90 new file mode 100644 index 0000000000..c7d6ec62a6 --- /dev/null +++ b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_w3v_advective_update_alg_mod.x90 @@ -0,0 +1,151 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> @brief Module containing adjoint test for adj_w3v_advective_update_kernel +module adjt_w3v_advective_update_alg_mod + + use config_mod, only : config_type + use r_tran_field_mod, only : r_tran_field_type + use function_space_mod, only : function_space_type + use mesh_mod, only : mesh_type + use function_space_collection_mod, only : function_space_collection + use fs_continuity_mod, only : W2, W3 + use constants_mod, only : i_def, r_def, & + r_tran, EPS_R_TRAN + use operator_mod, only : operator_type + use setop_random_alg_mod, only : setop_random_alg + use log_mod, only : log_event, & + log_scratch_space, & + LOG_LEVEL_ERROR, & + LOG_LEVEL_INFO, & + LOG_LEVEL_DEBUG + + implicit none + + public :: adjt_w3v_advective_update_alg + + contains + + !============================================================================= + !> @brief Adjoint test for adj_w3v_advective_update_kernel. + !> @details Passes if adjoint is transpose of tangent linear. + !> Determined by testing the equality of inner products and , + !> where M is the tangent linear and A is the adjoint. + !> @param[in] config Application namelist configuration object + !> @param[in] mesh Mesh object + subroutine adjt_w3v_advective_update_alg(config, mesh) + + use w3v_advective_update_kernel_mod, only : w3v_advective_update_kernel_type + use adj_w3v_advective_update_kernel_mod, only : adj_w3v_advective_update_kernel_type + + implicit none + + ! Arguments + type(config_type), intent(in) :: config + type(mesh_type), pointer, intent(in) :: mesh + + ! Arguments for tl and adj calls + type(r_tran_field_type) :: advective_increment + type(r_tran_field_type) :: tracer + type(r_tran_field_type) :: wind + type(operator_type) :: m3_inv + + ! Copies of input fields used in inner products + type(r_tran_field_type) :: advective_increment_input + type(r_tran_field_type) :: tracer_input + + ! Variables for initialising fields + type(function_space_type), pointer :: vector_space_w2_ptr + type(function_space_type), pointer :: vector_space_w3_ptr + integer(kind=i_def) :: element_order_h + integer(kind=i_def) :: element_order_v + integer(kind=i_def), parameter :: ndata = 6 + + ! Inner products + real(kind=r_def) :: advective_increment_inner_prod + real(kind=r_def) :: tracer_inner_prod + real(kind=r_tran) :: advective_increment_sf + real(kind=r_tran) :: tracer_sf + real(kind=r_tran) :: inner1 + real(kind=r_def) :: advective_increment_advective_increment_input_inner_prod + real(kind=r_def) :: tracer_tracer_input_inner_prod + real(kind=r_tran) :: inner2 + + ! Test parameters and variables + real(kind=r_tran), parameter :: overall_tolerance = 1500.0_r_tran + real(kind=r_tran) :: machine_tol + real(kind=r_tran) :: relative_diff + + element_order_h = config%finite_element%element_order_h() + element_order_v = config%finite_element%element_order_v() + vector_space_w2_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W2) + vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W3, & + ndata, ndata_first = .false.) + + call advective_increment%initialise(vector_space=vector_space_w3_ptr, name='advective_increment') + call tracer%initialise(vector_space=vector_space_w3_ptr, name='tracer') + call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') + call m3_inv%initialise(vector_space_w3_ptr, vector_space_w3_ptr) + + call advective_increment%copy_field_properties(advective_increment_input) + call tracer%copy_field_properties(tracer_input) + advective_increment_inner_prod = 0.0_r_def + tracer_inner_prod = 0.0_r_def + + ! Initialise arguments and call the tangent-linear kernel. + call invoke( setval_random(advective_increment), & + setval_x(advective_increment_input, advective_increment), & + setval_random(tracer), & + setval_x(tracer_input, tracer), & + setval_random(wind) ) + call setop_random_alg(m3_inv) + call invoke( w3v_advective_update_kernel_type(advective_increment, tracer, & + wind, m3_inv), & + x_innerproduct_x(advective_increment_inner_prod, advective_increment), & + x_innerproduct_x(tracer_inner_prod, tracer) ) + + write( log_scratch_space, * ) "adjt_w3v_advective_update inner products:" + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "advective_increment inner product = ", advective_increment_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "tracer inner product = ", tracer_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + + advective_increment_sf = 1.0_r_tran / ( real(advective_increment_inner_prod, kind=r_tran) + EPS_R_TRAN ) + tracer_sf = 1.0_r_tran / ( real(tracer_inner_prod, kind=r_tran) + EPS_R_TRAN ) + + inner1 = 0.0_r_tran + inner1 = inner1 + real(advective_increment_inner_prod, kind=r_tran) * advective_increment_sf + inner1 = inner1 + real(tracer_inner_prod, kind=r_tran) * tracer_sf + + advective_increment_advective_increment_input_inner_prod = 0.0_r_def + tracer_tracer_input_inner_prod = 0.0_r_def + call invoke( inc_a_times_X(advective_increment_sf, advective_increment), & + inc_a_times_X(tracer_sf, tracer), & + adj_w3v_advective_update_kernel_type(advective_increment, tracer, & + wind, m3_inv), & + x_innerproduct_y(advective_increment_advective_increment_input_inner_prod, & + advective_increment, advective_increment_input), & + x_innerproduct_y(tracer_tracer_input_inner_prod, & + tracer, tracer_input) ) + + inner2 = 0.0_r_tran + inner2 = inner2 + real(advective_increment_advective_increment_input_inner_prod, kind=r_tran) + inner2 = inner2 + real(tracer_tracer_input_inner_prod, kind=r_tran) + + ! Test the inner-product values for equality, allowing for the precision of the active variables + machine_tol = spacing(max(abs(inner1), abs(inner2))) + relative_diff = abs(inner1 - inner2) / machine_tol + if (relative_diff < overall_tolerance) then + write(log_scratch_space, *) "PASSED w3v_advective_update_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_INFO) + else + write(log_scratch_space, *) "FAILED w3v_advective_update_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_ERROR) + end if + + end subroutine adjt_w3v_advective_update_alg + +end module adjt_w3v_advective_update_alg_mod diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_w3v_advective_update_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_w3v_advective_update_alg_mod.x90 new file mode 100644 index 0000000000..83a1d9dbe8 --- /dev/null +++ b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_w3v_advective_update_alg_mod.x90 @@ -0,0 +1,154 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> @brief Module containing adjoint test for atl_w3v_advective_update_kernel +module atlt_w3v_advective_update_alg_mod + + use config_mod, only : config_type + use r_tran_field_mod, only : r_tran_field_type + use function_space_mod, only : function_space_type + use mesh_mod, only : mesh_type + use function_space_collection_mod, only : function_space_collection + use fs_continuity_mod, only : W2, W3 + use constants_mod, only : i_def, r_def, & + r_tran, EPS_R_TRAN + use operator_mod, only : operator_type + use setop_random_alg_mod, only : setop_random_alg + use log_mod, only : log_event, & + log_scratch_space, & + LOG_LEVEL_ERROR, & + LOG_LEVEL_INFO, & + LOG_LEVEL_DEBUG + + implicit none + + public :: atlt_w3v_advective_update_alg + + contains + + !============================================================================= + !> @brief Adjoint test for atl_w3v_advective_update_kernel. + !> @details Passes if adjoint is transpose of tangent linear. + !> Determined by testing the equality of inner products and , + !> where M is the tangent linear and A is the adjoint. + !> @param[in] config Application namelist configuration object + !> @param[in] mesh Mesh object + subroutine atlt_w3v_advective_update_alg(config, mesh) + + use tl_w3v_advective_update_kernel_mod, only : tl_w3v_advective_update_kernel_type + use atl_w3v_advective_update_kernel_mod, only : atl_w3v_advective_update_kernel_type + + implicit none + + ! Arguments + type(config_type), intent(in) :: config + type(mesh_type), pointer, intent(in) :: mesh + + ! Arguments for tl and adj calls + type(r_tran_field_type) :: advective_increment + type(r_tran_field_type) :: tracer + type(r_tran_field_type) :: ls_wind + type(r_tran_field_type) :: wind + type(operator_type) :: m3_inv + + ! Copies of input fields used in inner products + type(r_tran_field_type) :: advective_increment_input + type(r_tran_field_type) :: wind_input + + ! Variables for initialising fields + type(function_space_type), pointer :: vector_space_w2_ptr + type(function_space_type), pointer :: vector_space_w3_ptr + integer(kind=i_def) :: element_order_h + integer(kind=i_def) :: element_order_v + integer(kind=i_def), parameter :: ndata = 6 + + ! Inner products + real(kind=r_def) :: advective_increment_inner_prod + real(kind=r_def) :: wind_inner_prod + real(kind=r_tran) :: advective_increment_sf + real(kind=r_tran) :: wind_sf + real(kind=r_tran) :: inner1 + real(kind=r_def) :: advective_increment_advective_increment_input_inner_prod + real(kind=r_def) :: wind_wind_input_inner_prod + real(kind=r_tran) :: inner2 + + ! Test parameters and variables + real(kind=r_tran), parameter :: overall_tolerance = 1500.0_r_tran + real(kind=r_tran) :: machine_tol + real(kind=r_tran) :: relative_diff + + element_order_h = config%finite_element%element_order_h() + element_order_v = config%finite_element%element_order_v() + vector_space_w2_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W2) + vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, W3, & + ndata, ndata_first = .false.) + + call advective_increment%initialise(vector_space=vector_space_w3_ptr, name='advective_increment') + call tracer%initialise(vector_space=vector_space_w3_ptr, name='tracer') + call ls_wind%initialise(vector_space=vector_space_w2_ptr, name='ls_wind') + call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') + call m3_inv%initialise(vector_space_w3_ptr, vector_space_w3_ptr) + + call advective_increment%copy_field_properties(advective_increment_input) + call wind%copy_field_properties(wind_input) + advective_increment_inner_prod = 0.0_r_def + wind_inner_prod = 0.0_r_def + + ! Initialise arguments and call the tangent-linear kernel. + call invoke( setval_random(advective_increment), & + setval_x(advective_increment_input, advective_increment), & + setval_random(tracer), & + setval_random(ls_wind), & + setval_random(wind), & + setval_x(wind_input, wind) ) + call setop_random_alg(m3_inv) + call invoke( tl_w3v_advective_update_kernel_type(advective_increment, tracer, & + ls_wind, wind, m3_inv), & + x_innerproduct_x(advective_increment_inner_prod, advective_increment), & + x_innerproduct_x(wind_inner_prod, wind) ) + + write( log_scratch_space, * ) "atlt_w3v_advective_update inner products:" + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "advective_increment inner product = ", advective_increment_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod + call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) + + advective_increment_sf = 1.0_r_tran / ( real(advective_increment_inner_prod, kind=r_tran) + EPS_R_TRAN ) + wind_sf = 1.0_r_tran / ( real(wind_inner_prod, kind=r_tran) + EPS_R_TRAN ) + + inner1 = 0.0_r_tran + inner1 = inner1 + real(advective_increment_inner_prod, kind=r_tran) * advective_increment_sf + inner1 = inner1 + real(wind_inner_prod, kind=r_tran) * wind_sf + + advective_increment_advective_increment_input_inner_prod = 0.0_r_def + wind_wind_input_inner_prod = 0.0_r_def + call invoke( inc_a_times_X(advective_increment_sf, advective_increment), & + inc_a_times_X(wind_sf, wind), & + atl_w3v_advective_update_kernel_type(advective_increment, tracer, & + ls_wind, wind, m3_inv), & + x_innerproduct_y(advective_increment_advective_increment_input_inner_prod, & + advective_increment, advective_increment_input), & + x_innerproduct_y(wind_wind_input_inner_prod, & + wind, wind_input) ) + + inner2 = 0.0_r_tran + inner2 = inner2 + real(advective_increment_advective_increment_input_inner_prod, kind=r_tran) + inner2 = inner2 + real(wind_wind_input_inner_prod, kind=r_tran) + + ! Test the inner-product values for equality, allowing for the precision of the active variables + machine_tol = spacing(max(abs(inner1), abs(inner2))) + relative_diff = abs(inner1 - inner2) / machine_tol + if (relative_diff < overall_tolerance) then + write(log_scratch_space, *) "PASSED tl_w3v_advective_update_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_INFO) + else + write(log_scratch_space, *) "FAILED tl_w3v_advective_update_kernel_type:", inner1, inner2, relative_diff + call log_event(log_scratch_space, LOG_LEVEL_ERROR) + end if + + end subroutine atlt_w3v_advective_update_alg + +end module atlt_w3v_advective_update_alg_mod diff --git a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 index dc73aadb15..7fa7f9ad7c 100644 --- a/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 +++ b/applications/adjoint_tests/source/driver/adjoint_test_driver_mod.f90 @@ -91,10 +91,12 @@ subroutine run( modeldb ) use atlt_mol_conservative_alg_mod, only : atlt_mol_conservative_alg use atlt_mol_advective_alg_mod, only : atlt_mol_advective_alg use atlt_poly1d_vert_adv_alg_mod, only : atlt_poly1d_vert_adv_alg - use atlt_horizontal_mass_flux_alg_mod, only : atlt_horizontal_mass_flux_alg - use atlt_vertical_mass_flux_alg_mod, only : atlt_vertical_mass_flux_alg use adjt_horizontal_mass_flux_alg_mod, only : adjt_horizontal_mass_flux_alg use adjt_vertical_mass_flux_alg_mod, only : adjt_vertical_mass_flux_alg + use atlt_horizontal_mass_flux_alg_mod, only : atlt_horizontal_mass_flux_alg + use atlt_vertical_mass_flux_alg_mod, only : atlt_vertical_mass_flux_alg + use adjt_w3v_advective_update_alg_mod, only : adjt_w3v_advective_update_alg + use atlt_w3v_advective_update_alg_mod, only : atlt_w3v_advective_update_alg ! ./transport/control use atlt_transport_field_alg_mod, only : atlt_transport_field_alg @@ -168,10 +170,12 @@ subroutine run( modeldb ) call atlt_poly1d_vert_w3_recon_alg( modeldb%config, mesh ) call atlt_w3h_advective_update_alg( mesh ) call atlt_poly1d_vert_adv_alg( modeldb%config, mesh ) - call atlt_horizontal_mass_flux_alg( modeldb%config, mesh ) - call atlt_vertical_mass_flux_alg( modeldb%config, mesh ) call adjt_horizontal_mass_flux_alg( modeldb%config, mesh ) call adjt_vertical_mass_flux_alg( modeldb%config, mesh ) + call atlt_horizontal_mass_flux_alg( modeldb%config, mesh ) + call atlt_vertical_mass_flux_alg( modeldb%config, mesh ) + call adjt_w3v_advective_update_alg( modeldb%config, mesh ) + call atlt_w3v_advective_update_alg( modeldb%config, mesh ) ! -- Lookup table solutions. call adjt_poly1d_recon_lookup_alg( modeldb%config, mesh, adj_trans_lookup_cache ) call adjt_poly2d_recon_lookup_alg( modeldb%config, mesh, Wtheta, adj_trans_lookup_cache ) diff --git a/science/adjoint/build/psyad_files_list_apps.txt b/science/adjoint/build/psyad_files_list_apps.txt index d6bcaabaad..b6af361146 100644 --- a/science/adjoint/build/psyad_files_list_apps.txt +++ b/science/adjoint/build/psyad_files_list_apps.txt @@ -1,7 +1,5 @@ science/linear/source/kernel/linear_physics/stabilise_bl_u_kernel_mod.F90 -science/linear/source/kernel/transport/mol/tl_w3v_advective_update_kernel_mod.F90 science/gungho/source/kernel/solver/apply_mixed_lu_operator_kernel_mod.F90 science/gungho/source/kernel/solver/apply_mixed_operator_kernel_mod.F90 science/gungho/source/kernel/solver/opt_apply_variable_hx_kernel_mod.F90 science/gungho/source/kernel/solver/apply_elim_mixed_lp_operator_kernel_mod.F90 -science/gungho/source/kernel/transport/mol/w3v_advective_update_kernel_mod.F90 diff --git a/science/adjoint/build/psyad_vars.mk b/science/adjoint/build/psyad_vars.mk index d05a57ec95..bf4c09bd60 100644 --- a/science/adjoint/build/psyad_vars.mk +++ b/science/adjoint/build/psyad_vars.mk @@ -22,5 +22,3 @@ all: export ACTIVE_strong_curl_kernel_mod := xi res_dot_product cur all: export ACTIVE_sci_average_w2b_to_w2_kernel_mod := field_w2 field_w2_broken all: export ACTIVE_sci_extract_w_kernel_mod := velocity_w2v u_physics all: export ACTIVE_sci_combine_multidata_field_kernel_mod := field1_in field2_in field_out -all: export ACTIVE_w3v_advective_update_kernel_mod := advective_increment tracer dtdz t_U t_D -all: export ACTIVE_tl_w3v_advective_update_kernel_mod := advective_increment wind w diff --git a/science/adjoint/patches/algorithm/adjt_w3v_advective_update_alg_mod.patch b/science/adjoint/patches/algorithm/adjt_w3v_advective_update_alg_mod.patch deleted file mode 100644 index 1914d7ca2a..0000000000 --- a/science/adjoint/patches/algorithm/adjt_w3v_advective_update_alg_mod.patch +++ /dev/null @@ -1,93 +0,0 @@ -@@ -13,9 +13,9 @@ - use finite_element_config_mod, only : element_order_h, element_order_v - use fs_continuity_mod, only : w2, w3 - use operator_mod, only : operator_type -- use constants_mod, only : i_def, r_def -- use setop_random_kernel_mod, only : setop_random_kernel_type -- use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space -+ use constants_mod, only : i_def, r_def, r_tran -+ use setop_random_alg_mod, only : setop_random_alg -+ use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space, log_level_debug - real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def - type(mesh_type), pointer, intent(in) :: mesh - type(field_type), dimension(3), intent(in), optional :: chi -@@ -28,53 +28,55 @@ - type(operator_type) :: m3_inv - type(field_type) :: advective_increment_input - type(field_type) :: tracer_input -- type(field_type) :: wind_input - real(kind=r_def) :: advective_increment_inner_prod - real(kind=r_def) :: tracer_inner_prod -- real(kind=r_def) :: wind_inner_prod -- real(kind=r_def) :: inner1 -+ real(kind=r_def) :: advective_increment_sf -+ real(kind=r_def) :: tracer_sf -+ real(kind=r_tran) :: inner1 - real(kind=r_def) :: advective_increment_advective_increment_input_inner_prod - real(kind=r_def) :: tracer_tracer_input_inner_prod -- real(kind=r_def) :: wind_wind_input_inner_prod -- real(kind=r_def) :: inner2 -+ real(kind=r_tran) :: inner2 - real(kind=r_def) :: MachineTol - real(kind=r_def) :: relative_diff -+ real(kind=r_def), parameter :: eps = 1.0e-30_r_def - - vector_space_w2_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w2) -- vector_space_w3_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w3) -+ vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, w3, 6, ndata_first = .false.) - call advective_increment%initialise(vector_space=vector_space_w3_ptr, name='advective_increment') - call tracer%initialise(vector_space=vector_space_w3_ptr, name='tracer') - call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') - call m3_inv%initialise(vector_space_w3_ptr, vector_space_w3_ptr) - call advective_increment_input%initialise(vector_space=vector_space_w3_ptr, name='advective_increment_input') - call tracer_input%initialise(vector_space=vector_space_w3_ptr, name='tracer_input') -- call wind_input%initialise(vector_space=vector_space_w2_ptr, name='wind_input') - advective_increment_inner_prod = 0.0_r_def - tracer_inner_prod = 0.0_r_def -- wind_inner_prod = 0.0_r_def -- - ! Initialise arguments and call the tangent-linear kernel. - call invoke(setval_random(advective_increment), setval_x(advective_increment_input, advective_increment), & --&setval_random(tracer), setval_x(tracer_input, tracer), setval_random(wind), setval_x(wind_input, wind), & --&setop_random_kernel_type(m3_inv), w3v_advective_update_kernel_type(advective_increment, tracer, wind, m3_inv), & --&x_innerproduct_x(advective_increment_inner_prod, advective_increment), x_innerproduct_x(tracer_inner_prod, tracer), & --&x_innerproduct_x(wind_inner_prod, wind)) -+&setval_random(tracer), setval_x(tracer_input, tracer), setval_random(wind)) -+ call setop_random_alg(m3_inv) -+ call invoke(w3v_advective_update_kernel_type(advective_increment, tracer, wind, m3_inv), & -+&x_innerproduct_x(advective_increment_inner_prod, advective_increment), x_innerproduct_x(tracer_inner_prod, tracer)) -+ write( log_scratch_space, * ) "adjt_w3v_advective_update inner products:" -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "advective_increment inner product = ", advective_increment_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "tracer inner product = ", tracer_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ advective_increment_sf = 1.0_r_def / (advective_increment_inner_prod + eps) -+ tracer_sf = 1.0_r_def / (tracer_inner_prod + eps) - inner1 = 0.0_r_def -- inner1 = inner1 + advective_increment_inner_prod -- inner1 = inner1 + tracer_inner_prod -- inner1 = inner1 + wind_inner_prod -+ inner1 = inner1 + real(advective_increment_inner_prod * advective_increment_sf, r_tran) -+ inner1 = inner1 + real(tracer_inner_prod * tracer_sf, r_tran) -+ call invoke( inc_a_times_X( advective_increment_sf, advective_increment ), & -+ inc_a_times_X( tracer_sf, tracer ) ) - advective_increment_advective_increment_input_inner_prod = 0.0_r_def - tracer_tracer_input_inner_prod = 0.0_r_def -- wind_wind_input_inner_prod = 0.0_r_def - call invoke(adj_w3v_advective_update_kernel_type(advective_increment, tracer, wind, m3_inv), & - &x_innerproduct_y(advective_increment_advective_increment_input_inner_prod, advective_increment, advective_increment_input), & --&x_innerproduct_y(tracer_tracer_input_inner_prod, tracer, tracer_input), x_innerproduct_y(wind_wind_input_inner_prod, wind, & --&wind_input)) -- inner2 = 0.0_r_def -- inner2 = inner2 + advective_increment_advective_increment_input_inner_prod -- inner2 = inner2 + tracer_tracer_input_inner_prod -- inner2 = inner2 + wind_wind_input_inner_prod -- -+&x_innerproduct_y(tracer_tracer_input_inner_prod, tracer, tracer_input)) -+ inner2 = 0.0_r_tran -+ inner2 = inner2 + real(advective_increment_advective_increment_input_inner_prod, r_tran) -+ inner2 = inner2 + real(tracer_tracer_input_inner_prod, r_tran) - ! Test the inner-product values for equality, allowing for the precision of the active variables - MachineTol = SPACING(MAX(ABS(inner1), ABS(inner2))) - relative_diff = ABS(inner1 - inner2) / MachineTol diff --git a/science/adjoint/patches/algorithm/atlt_w3v_advective_update_alg_mod.patch b/science/adjoint/patches/algorithm/atlt_w3v_advective_update_alg_mod.patch deleted file mode 100644 index 5f735abaed..0000000000 --- a/science/adjoint/patches/algorithm/atlt_w3v_advective_update_alg_mod.patch +++ /dev/null @@ -1,106 +0,0 @@ -@@ -9,13 +9,13 @@ - use mesh_mod, only : mesh_type - use function_space_collection_mod, only : function_space_collection - use tl_w3v_advective_update_kernel_mod, only : tl_w3v_advective_update_kernel_type -- use adj_w3v_advective_update_kernel_mod, only : adj_w3v_advective_update_kernel_type -+ use atl_w3v_advective_update_kernel_mod, only : atl_w3v_advective_update_kernel_type - use finite_element_config_mod, only : element_order_h, element_order_v - use fs_continuity_mod, only : w2, w3 - use operator_mod, only : operator_type - use constants_mod, only : i_def, r_def -- use setop_random_kernel_mod, only : setop_random_kernel_type -- use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space -+ use setop_random_alg_mod, only : setop_random_alg -+ use log_mod, only : log_event, log_level_error, log_level_info, log_scratch_space, log_level_debug - real(kind=r_def), parameter :: overall_tolerance = 1500.0_r_def - type(mesh_type), pointer, intent(in) :: mesh - type(field_type), dimension(3), intent(in), optional :: chi -@@ -28,64 +28,59 @@ - type(field_type) :: wind - type(operator_type) :: m3_inv - type(field_type) :: advective_increment_input -- type(field_type) :: tracer_input -- type(field_type) :: ls_wind_input - type(field_type) :: wind_input - real(kind=r_def) :: advective_increment_inner_prod -- real(kind=r_def) :: tracer_inner_prod -- real(kind=r_def) :: ls_wind_inner_prod - real(kind=r_def) :: wind_inner_prod -+ real(kind=r_def) :: advective_increment_sf -+ real(kind=r_def) :: wind_sf - real(kind=r_def) :: inner1 - real(kind=r_def) :: advective_increment_advective_increment_input_inner_prod -- real(kind=r_def) :: tracer_tracer_input_inner_prod -- real(kind=r_def) :: ls_wind_ls_wind_input_inner_prod - real(kind=r_def) :: wind_wind_input_inner_prod - real(kind=r_def) :: inner2 - real(kind=r_def) :: MachineTol - real(kind=r_def) :: relative_diff -+ real(kind=r_def), parameter :: eps = 1.0e-30_r_def - - vector_space_w2_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w2) -- vector_space_w3_ptr => function_space_collection%get_fs(mesh,element_order_h,element_order_v,w3) -+ vector_space_w3_ptr => function_space_collection%get_fs(mesh, element_order_h, element_order_v, w3, 6, ndata_first = .false.) - call advective_increment%initialise(vector_space=vector_space_w3_ptr, name='advective_increment') - call tracer%initialise(vector_space=vector_space_w3_ptr, name='tracer') - call ls_wind%initialise(vector_space=vector_space_w2_ptr, name='ls_wind') - call wind%initialise(vector_space=vector_space_w2_ptr, name='wind') - call m3_inv%initialise(vector_space_w3_ptr, vector_space_w3_ptr) - call advective_increment_input%initialise(vector_space=vector_space_w3_ptr, name='advective_increment_input') -- call tracer_input%initialise(vector_space=vector_space_w3_ptr, name='tracer_input') -- call ls_wind_input%initialise(vector_space=vector_space_w2_ptr, name='ls_wind_input') - call wind_input%initialise(vector_space=vector_space_w2_ptr, name='wind_input') - advective_increment_inner_prod = 0.0_r_def -- tracer_inner_prod = 0.0_r_def -- ls_wind_inner_prod = 0.0_r_def - wind_inner_prod = 0.0_r_def -- - ! Initialise arguments and call the tangent-linear kernel. - call invoke(setval_random(advective_increment), setval_x(advective_increment_input, advective_increment), & --&setval_random(tracer), setval_x(tracer_input, tracer), setval_random(ls_wind), setval_x(ls_wind_input, ls_wind), & --&setval_random(wind), setval_x(wind_input, wind), setop_random_kernel_type(m3_inv), & --&tl_w3v_advective_update_kernel_type(advective_increment, tracer, ls_wind, wind, m3_inv), & --&x_innerproduct_x(advective_increment_inner_prod, advective_increment), x_innerproduct_x(tracer_inner_prod, tracer), & --&x_innerproduct_x(ls_wind_inner_prod, ls_wind), x_innerproduct_x(wind_inner_prod, wind)) -+&setval_random(tracer), setval_random(ls_wind), & -+&setval_random(wind), setval_x(wind_input, wind)) -+ call setop_random_alg(m3_inv) -+ call invoke(tl_w3v_advective_update_kernel_type(advective_increment, tracer, ls_wind, wind, m3_inv), & -+&x_innerproduct_x(advective_increment_inner_prod, advective_increment), & -+&x_innerproduct_x(wind_inner_prod, wind)) -+ write( log_scratch_space, * ) "atlt_w3v_advective_update inner products:" -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "advective_increment inner product = ", advective_increment_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod -+ call log_event( log_scratch_space, log_level_debug ) -+ advective_increment_sf = 1.0_r_def / (advective_increment_inner_prod + eps) -+ wind_sf = 1.0_r_def / (wind_inner_prod + eps) - inner1 = 0.0_r_def -- inner1 = inner1 + advective_increment_inner_prod -- inner1 = inner1 + tracer_inner_prod -- inner1 = inner1 + ls_wind_inner_prod -- inner1 = inner1 + wind_inner_prod -+ inner1 = inner1 + advective_increment_inner_prod * advective_increment_sf -+ inner1 = inner1 + wind_inner_prod * wind_sf -+ call invoke( inc_a_times_X( advective_increment_sf, advective_increment ), & -+ inc_a_times_X( wind_sf, wind ) ) - advective_increment_advective_increment_input_inner_prod = 0.0_r_def -- tracer_tracer_input_inner_prod = 0.0_r_def -- ls_wind_ls_wind_input_inner_prod = 0.0_r_def - wind_wind_input_inner_prod = 0.0_r_def -- call invoke(adj_w3v_advective_update_kernel_type(advective_increment, tracer, ls_wind, wind, m3_inv), & -+ call invoke(atl_w3v_advective_update_kernel_type(advective_increment, tracer, ls_wind, wind, m3_inv), & - &x_innerproduct_y(advective_increment_advective_increment_input_inner_prod, advective_increment, advective_increment_input), & --&x_innerproduct_y(tracer_tracer_input_inner_prod, tracer, tracer_input), x_innerproduct_y(ls_wind_ls_wind_input_inner_prod, & --&ls_wind, ls_wind_input), x_innerproduct_y(wind_wind_input_inner_prod, wind, wind_input)) -+&x_innerproduct_y(wind_wind_input_inner_prod, wind, wind_input)) - inner2 = 0.0_r_def - inner2 = inner2 + advective_increment_advective_increment_input_inner_prod -- inner2 = inner2 + tracer_tracer_input_inner_prod -- inner2 = inner2 + ls_wind_ls_wind_input_inner_prod - inner2 = inner2 + wind_wind_input_inner_prod -- - ! Test the inner-product values for equality, allowing for the precision of the active variables - MachineTol = SPACING(MAX(ABS(inner1), ABS(inner2))) - relative_diff = ABS(inner1 - inner2) / MachineTol diff --git a/science/adjoint/patches/kernel/adj_w3v_advective_update_kernel_mod.patch b/science/adjoint/patches/kernel/adj_w3v_advective_update_kernel_mod.patch deleted file mode 100644 index 76dd8fa6a7..0000000000 --- a/science/adjoint/patches/kernel/adj_w3v_advective_update_kernel_mod.patch +++ /dev/null @@ -1,42 +0,0 @@ -@@ -45,12 +45,7 @@ - integer(kind=i_def) :: offset - real(kind=r_tran) :: w - real(kind=r_tran) :: dtdz -- real(kind=r_tran) :: t_u -- real(kind=r_tran) :: t_d - -- dtdz = 0.0_r_tran -- t_u = 0.0_r_tran -- t_d = 0.0_r_tran - if (ndf_w2 == 2) then - df = 1 - offset = 0 -@@ -61,23 +56,16 @@ - do k = nlayers - 1, 0, -1 - w = 0.5 * wind(k + map_w2(df)) + 0.5 * wind(k + map_w2(df) + 1) - ik = cell * nlayers + k - nlayers + 1 -- dtdz = dtdz + advective_increment(map_w3(1) + k) * w * REAL(m3_inv(ik,1,1), kind=r_tran) -- t_d = t_d + (-dtdz) -- t_u = t_u + dtdz -- dtdz = 0.0 -+ dtdz = advective_increment(map_w3(1) + k) * w * REAL(m3_inv(ik,1,1), kind=r_tran) - if (w <= 0.0_r_tran .AND. k < nlayers - 1) then -- tracer(map_md(1) + offset + k + 1) = tracer(map_md(1) + offset + k + 1) + t_u -- t_u = 0.0 -+ tracer(map_md(1) + offset + k + 1) = tracer(map_md(1) + offset + k + 1) + dtdz - else -- tracer(map_md(1) + offset + nlayers + k) = tracer(map_md(1) + offset + nlayers + k) + t_u -- t_u = 0.0 -+ tracer(map_md(1) + offset + nlayers + k) = tracer(map_md(1) + offset + nlayers + k) + dtdz - end if - if (w > 0.0_r_tran .AND. k > 0) then -- tracer(map_md(1) + offset + nlayers + k - 1) = tracer(map_md(1) + offset + nlayers + k - 1) + t_d -- t_d = 0.0 -+ tracer(map_md(1) + offset + nlayers + k - 1) = tracer(map_md(1) + offset + nlayers + k - 1) - dtdz - else -- tracer(map_md(1) + offset + k) = tracer(map_md(1) + offset + k) + t_d -- t_d = 0.0 -+ tracer(map_md(1) + offset + k) = tracer(map_md(1) + offset + k) - dtdz - end if - enddo - diff --git a/science/adjoint/patches/kernel/atl_w3v_advective_update_kernel_mod.patch b/science/adjoint/patches/kernel/atl_w3v_advective_update_kernel_mod.patch deleted file mode 100644 index 7cd2087cd6..0000000000 --- a/science/adjoint/patches/kernel/atl_w3v_advective_update_kernel_mod.patch +++ /dev/null @@ -1,58 +0,0 @@ -@@ -1,11 +1,11 @@ --module adj_w3v_advective_update_kernel_mod -+module atl_w3v_advective_update_kernel_mod - use argument_mod, only : any_discontinuous_space_1, any_w2, arg_type, cell_column, gh_field, gh_inc, gh_operator, gh_read, & - &gh_readwrite, gh_real - use constants_mod, only : i_def, r_def - use fs_continuity_mod, only : w3 - use kernel_mod, only : kernel_type - implicit none -- type, public, extends(kernel_type) :: adj_w3v_advective_update_kernel_type -+ type, public, extends(kernel_type) :: atl_w3v_advective_update_kernel_type - type(ARG_TYPE) :: META_ARGS(5) = (/ & - arg_type(gh_field, gh_real, gh_read, w3), & - arg_type(gh_field, gh_real, gh_read, any_discontinuous_space_1), & -@@ -14,15 +14,15 @@ - arg_type(gh_operator, gh_real, gh_read, w3, w3)/) - INTEGER :: OPERATES_ON = cell_column - CONTAINS -- PROCEDURE, NOPASS :: adj_w3v_advective_update_code --END TYPE adj_w3v_advective_update_kernel_type -+ PROCEDURE, NOPASS :: atl_w3v_advective_update_code -+END TYPE atl_w3v_advective_update_kernel_type - - private - -- public :: adj_w3v_advective_update_code -+ public :: atl_w3v_advective_update_code - - contains -- subroutine adj_w3v_advective_update_code(cell, nlayers, advective_increment, tracer, ls_wind, wind, ncell_3d, m3_inv, ndf_w3, & -+ subroutine atl_w3v_advective_update_code(cell, nlayers, advective_increment, tracer, ls_wind, wind, ncell_3d, m3_inv, ndf_w3, & - &undf_w3, map_w3, ndf_md, undf_md, map_md, ndf_w2, undf_w2, map_w2) - integer(kind=i_def), intent(in) :: nlayers - integer(kind=i_def), intent(in) :: cell -@@ -51,7 +51,6 @@ - real(kind=r_def) :: t_u - real(kind=r_def) :: t_d - -- w = 0.0_r_def - if (ndf_w2 == 2) then - df = 1 - offset = 0 -@@ -73,12 +72,11 @@ - end if - dtdz = -t_d + t_u - ik = cell * nlayers + k - nlayers + 1 -- w = w + dtdz * advective_increment(map_w3(1) + k) * m3_inv(ik,1,1) -+ w = dtdz * advective_increment(map_w3(1) + k) * m3_inv(ik,1,1) - wind(k + map_w2(df)) = wind(k + map_w2(df)) + 0.5 * w - wind(k + map_w2(df) + 1) = wind(k + map_w2(df) + 1) + 0.5 * w -- w = 0.0 - enddo - -- end subroutine adj_w3v_advective_update_code -+ end subroutine atl_w3v_advective_update_code - --end module adj_w3v_advective_update_kernel_mod -+end module atl_w3v_advective_update_kernel_mod diff --git a/science/adjoint/source/kernel/transport/mol/adj_w3v_advective_update_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/adj_w3v_advective_update_kernel_mod.F90 new file mode 100644 index 0000000000..e4650dac39 --- /dev/null +++ b/science/adjoint/source/kernel/transport/mol/adj_w3v_advective_update_kernel_mod.F90 @@ -0,0 +1,137 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + +!> @brief Kernel which computes adjoint of vertical advective update through fitting +!! a high order upwind reconstruction. +module adj_w3v_advective_update_kernel_mod + + use argument_mod, only : arg_type, & + GH_FIELD, GH_REAL, & + GH_OPERATOR, & + GH_READWRITE, GH_READ, & + ANY_DISCONTINUOUS_SPACE_1, & + ANY_W2, & + CELL_COLUMN + use constants_mod, only : r_def, i_def, r_tran + use fs_continuity_mod, only : W3 + use kernel_mod, only : kernel_type + + implicit none + + private + !------------------------------------------------------------------------------- + ! Public types + !------------------------------------------------------------------------------- + !> The type declaration for the kernel. Contains the metadata needed by the Psy layer + type, public, extends(kernel_type) :: adj_w3v_advective_update_kernel_type + private + type(arg_type) :: meta_args(4) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_READ, W3), & + arg_type(GH_FIELD, GH_REAL, GH_READWRITE, ANY_DISCONTINUOUS_SPACE_1), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_W2), & + arg_type(GH_OPERATOR, GH_REAL, GH_READ, W3, W3) & + /) + integer :: operates_on = CELL_COLUMN + contains + procedure, nopass :: adj_w3v_advective_update_code + end type + + !------------------------------------------------------------------------------- + ! Contained functions/subroutines + !------------------------------------------------------------------------------- + public :: adj_w3v_advective_update_code + contains + + !> @brief Computes the adjoint horizontal advective update for a tracer in W3. + !> @param[in] cell Horizontal cell index + !> @param[in] nlayers Number of layers + !> @param[in] advective_increment Advective update field to compute + !> @param[in,out] tracer Pointwise tracer field to advect stored on cell faces + !> @param[in] wind Wind field + !> @param[in] ncell_3d Total number of cells + !> @param[in] m3_inv Inverse mass matrix for W3 space + !> @param[in] ndf_w3 Number of degrees of freedom per cell + !> @param[in] undf_w3 Number of unique degrees of freedom for the + !! advective_update field + !> @param[in] map_w3 Dofmap for the cell at the base of the column + !> @param[in] ndf_md Number of degrees of freedom per cell + !> @param[in] undf_md Number of unique degrees of freedom for the + !! tracer field + !> @param[in] map_md Dofmap for the cell at the base of the column + !> @param[in] ndf_w2 Number of degrees of freedom per cell for the wind fields + !> @param[in] undf_w2 Number of unique degrees of freedom for the wind fields + !> @param[in] map_w2 Dofmap for the cell at the base of the column for the wind fields + subroutine adj_w3v_advective_update_code( cell, & + nlayers, & + advective_increment, & + tracer, & + wind, & + ncell_3d, & + m3_inv, & + ndf_w3, & + undf_w3, & + map_w3, & + ndf_md, & + undf_md, & + map_md, & + ndf_w2, & + undf_w2, & + map_w2 & + ) + + implicit none + + ! Arguments + integer(kind=i_def), intent(in) :: nlayers, cell, ncell_3d + integer(kind=i_def), intent(in) :: ndf_w3, ndf_w2, ndf_md + integer(kind=i_def), intent(in) :: undf_w3, undf_w2, undf_md + integer(kind=i_def), dimension(ndf_w3), intent(in) :: map_w3 + integer(kind=i_def), dimension(ndf_w2), intent(in) :: map_w2 + integer(kind=i_def), dimension(ndf_md), intent(in) :: map_md + + real(kind=r_tran), dimension(undf_w3), intent(in) :: advective_increment + real(kind=r_tran), dimension(undf_w2), intent(in) :: wind + real(kind=r_tran), dimension(undf_md), intent(inout) :: tracer + + real(kind=r_def), dimension(ncell_3d, ndf_w3, ndf_w3), intent(in) :: m3_inv + + ! Internal variables + integer(kind=i_def) :: k, ik, df, offset + real(kind=r_tran) :: w, dtdz + + if ( ndf_w2 == 2 ) then + ! W2v space, reconstruction has ndata=2 + df = 1 + offset = 0 + else + ! W2 space, reconstruction has ndata=6 + df = 5 + offset = 4*nlayers + end if + + ! Vertical advective update + do k = nlayers - 1, 0, -1 + w = 0.5_r_tran*( wind(map_w2(df) + k) + wind(map_w2(df) + k + 1) ) + ik = 1 + k + (cell-1)*nlayers + dtdz = advective_increment(map_w3(1) + k) * w * real(m3_inv(ik,1,1), kind=r_tran) + + if (w <= 0.0_r_tran .and. k < nlayers - 1) then + tracer(map_md(1) + offset + k + 1) = tracer(map_md(1) + offset + k + 1) + dtdz + else + tracer(map_md(1) + offset + nlayers + k) = tracer(map_md(1) + offset + nlayers + k) + dtdz + end if + if (w > 0.0_r_tran .and. k > 0) then + tracer(map_md(1) + offset + nlayers + k - 1) = tracer(map_md(1) + offset + nlayers + k - 1) - dtdz + else + tracer(map_md(1) + offset + k) = tracer(map_md(1) + offset + k) - dtdz + end if + end do + + end subroutine adj_w3v_advective_update_code + +end module adj_w3v_advective_update_kernel_mod diff --git a/science/adjoint/source/kernel/transport/mol/atl_w3v_advective_update_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_w3v_advective_update_kernel_mod.F90 new file mode 100644 index 0000000000..67186a4b54 --- /dev/null +++ b/science/adjoint/source/kernel/transport/mol/atl_w3v_advective_update_kernel_mod.F90 @@ -0,0 +1,151 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright 2022 Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + +!> @brief Kernel which computes adjoint vertical advective update through fitting a high order +!! upwind reconstruction. + +module atl_w3v_advective_update_kernel_mod + + use argument_mod, only : arg_type, & + GH_FIELD, GH_REAL, & + GH_OPERATOR, & + GH_INC, GH_READ, & + ANY_DISCONTINUOUS_SPACE_1, & + ANY_W2, & + CELL_COLUMN + use constants_mod, only : r_def, i_def + use fs_continuity_mod, only : W3 + use kernel_mod, only : kernel_type + + implicit none + + private + !------------------------------------------------------------------------------- + ! Public types + !------------------------------------------------------------------------------- + !> The type declaration for the kernel. Contains the metadata needed by the Psy layer + type, public, extends(kernel_type) :: atl_w3v_advective_update_kernel_type + private + type(arg_type) :: meta_args(5) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_READ, W3), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_INC, ANY_W2), & + arg_type(GH_OPERATOR, GH_REAL, GH_READ, W3, W3) & + /) + integer :: operates_on = CELL_COLUMN + contains + procedure, nopass :: atl_w3v_advective_update_code + end type + + !------------------------------------------------------------------------------- + ! Contained functions/subroutines + !------------------------------------------------------------------------------- + public :: atl_w3v_advective_update_code + contains + + !> @brief Computes the adjoint vertical advective update for a tracer in W3. + !> @param[in] cell Horizontal cell index + !> @param[in] nlayers Number of layers + !> @param[in] advective_increment Advective update field to compute + !> @param[in] tracer Pointwise tracer field to advect stored on cell faces + !> @param[in] ls_wind Linear wind field + !> @param[in,out] wind Perturbation wind field + !> @param[in] ncell_3d Total number of cells + !> @param[in] m3_inv Inverse mass matrix for W3 space + !> @param[in] ndf_w3 Number of degrees of freedom per cell + !> @param[in] undf_w3 Number of unique degrees of freedom for the + !! advective_update field + !> @param[in] map_w3 Dofmap for the cell at the base of the column + !> @param[in] ndf_md Number of degrees of freedom per cell + !> @param[in] undf_md Number of unique degrees of freedom for the + !! tracer field + !> @param[in] map_md Dofmap for the cell at the base of the column + !> @param[in] ndf_w2 Number of degrees of freedom per cell for the wind fields + !> @param[in] undf_w2 Number of unique degrees of freedom for the wind fields + !> @param[in] map_w2 Dofmap for the cell at the base of the column for the wind fields + subroutine atl_w3v_advective_update_code( cell, & + nlayers, & + advective_increment, & + tracer, & + ls_wind, & + wind, & + ncell_3d, & + m3_inv, & + ndf_w3, & + undf_w3, & + map_w3, & + ndf_md, & + undf_md, & + map_md, & + ndf_w2, & + undf_w2, & + map_w2 & + ) + + implicit none + + ! Arguments + integer(kind=i_def), intent(in) :: nlayers, cell, ncell_3d + integer(kind=i_def), intent(in) :: ndf_w3, ndf_w2, ndf_md + integer(kind=i_def), intent(in) :: undf_w3, undf_w2, undf_md + integer(kind=i_def), dimension(ndf_w3), intent(in) :: map_w3 + integer(kind=i_def), dimension(ndf_w2), intent(in) :: map_w2 + integer(kind=i_def), dimension(ndf_md), intent(in) :: map_md + + real(kind=r_def), dimension(undf_w3), intent(in) :: advective_increment + real(kind=r_def), dimension(undf_w2), intent(in) :: ls_wind + real(kind=r_def), dimension(undf_w2), intent(inout) :: wind + real(kind=r_def), dimension(undf_md), intent(in) :: tracer + + real(kind=r_def), dimension(ncell_3d, ndf_w3, ndf_w3), intent(in) :: m3_inv + + ! Internal variables + integer(kind=i_def) :: k, ik, df, offset + real(kind=r_def) :: ls_w, w, dtdz, t_U, t_D + + if ( ndf_w2 == 2 ) then + ! W2v space, reconstruction has ndata=2 + df = 1 + offset = 0 + else + ! W2 space, reconstruction has ndata=6 + df = 5 + offset = 4*nlayers + end if + + ! Vertical advective update + do k = nlayers - 1, 0, -1 + ls_w = 0.5_r_def*( ls_wind(map_w2(df) + k) + ls_wind(map_w2(df) + k + 1) ) + + if ( ls_w > 0.0_r_def .and. k > 0 ) then + ! Overwrite t_D from cell below + t_D = tracer(map_md(1) + offset + nlayers + k - 1) + else + ! Values from this cell + t_D = tracer(map_md(1) + offset + k) + end if + + if ( ls_w <= 0.0_r_def .and. k < nlayers-1 ) then + ! Overwrite t_U from cell above + t_U = tracer(map_md(1) + offset + k + 1) + else + ! Values from this cell + t_U = tracer(map_md(1) + offset + nlayers + k) + end if + + dtdz = t_U - t_D + ik = 1 + k + (cell-1)*nlayers + w = dtdz * advective_increment(map_w3(1) + k) * m3_inv(ik,1,1) + wind(k + map_w2(df)) = wind(k + map_w2(df)) + 0.5_r_def * w + wind(k + map_w2(df) + 1) = wind(k + map_w2(df) + 1) + 0.5_r_def * w + end do + + end subroutine atl_w3v_advective_update_code + +end module atl_w3v_advective_update_kernel_mod From a0d736ba67bad59becb40b1833e021b92355fe9b Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 21 Jul 2026 10:46:48 +0100 Subject: [PATCH 08/22] Some tidying --- .../algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 | 4 ---- .../transport/mol/atl_w3v_advective_update_kernel_mod.F90 | 2 +- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 index 9301704d82..cc48c19d28 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_poly1d_vert_adv_alg_mod.x90 @@ -88,10 +88,6 @@ module atlt_poly1d_vert_adv_alg_mod global_order, & logspace) - - - - end subroutine atlt_poly1d_vert_adv_alg !============================================================================= diff --git a/science/adjoint/source/kernel/transport/mol/atl_w3v_advective_update_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_w3v_advective_update_kernel_mod.F90 index 67186a4b54..7528902e3c 100644 --- a/science/adjoint/source/kernel/transport/mol/atl_w3v_advective_update_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/mol/atl_w3v_advective_update_kernel_mod.F90 @@ -1,5 +1,5 @@ !----------------------------------------------------------------------------- -! (c) Crown copyright 2022 Met Office. All rights reserved. +! (c) Crown copyright Met Office. All rights reserved. ! The file LICENCE, distributed with this code, contains details of the terms ! under which the code may be used. !----------------------------------------------------------------------------- From 89435466226b685b3dd0c107c6569abd37f179f2 Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 21 Jul 2026 10:55:27 +0100 Subject: [PATCH 09/22] Added new kernels to fortitude.toml --- science/adjoint/fortitude.toml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/science/adjoint/fortitude.toml b/science/adjoint/fortitude.toml index d0347beda1..f04b7fb0bf 100644 --- a/science/adjoint/fortitude.toml +++ b/science/adjoint/fortitude.toml @@ -46,6 +46,14 @@ output-format = "grouped" #group results by file "adj_sci_psykal_builtin_light_mod.f90" = ["C082"] "invoke_adj_sci_convert_hdiv_field_kernel_mod.F90" = ["C082"] "invoke_adj_apply_helmholtz_op_lookup_mod.f90" = ["C031"] +"atl_vorticity_advection_kernel_mod.F90" = ["C031"] +"adj_horizontal_mass_flux_kernel_mod.F90" = ["C031"] +"adj_vertical_mass_flux_kernel_mod.F90" = ["C031"] +"adj_w3v_advective_update_kernel_mod.F90" = ["C031"] +"atl_horizontal_mass_flux_kernel_mod.F90" = ["C031"] +"atl_poly1d_vert_adv_kernel_mod.F90" = ["C031"] +"atl_vertical_mass_flux_kernel_mod.F90" = ["C031"] +"atl_w3v_advective_update_kernel_mod.F90" = ["C031"] # Leaving out for now (these rules are used in the universal config): # S071 From 8478f0d29de20cdb4acd746f52d3584b274f957c Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 21 Jul 2026 11:04:59 +0100 Subject: [PATCH 10/22] More tidying --- .../mol/adjt_horizontal_mass_flux_alg_mod.x90 | 2 +- .../mol/adjt_vertical_mass_flux_alg_mod.x90 | 2 +- .../mol/atlt_horizontal_mass_flux_alg_mod.x90 | 2 +- .../atl_vorticity_advection_kernel_mod.F90 | 34 +++++++++---------- .../adj_horizontal_mass_flux_kernel_mod.F90 | 1 - .../atl_horizontal_mass_flux_kernel_mod.F90 | 2 +- .../mol/atl_vertical_mass_flux_kernel_mod.F90 | 1 - 7 files changed, 21 insertions(+), 23 deletions(-) diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 index 7a14c618d0..3c7870b520 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 @@ -22,7 +22,7 @@ module adjt_horizontal_mass_flux_alg_mod implicit none - public + public :: adjt_horizontal_mass_flux_alg contains diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 index bd539b1c2b..4bab652521 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 @@ -22,7 +22,7 @@ module adjt_vertical_mass_flux_alg_mod implicit none - public + public :: adjt_vertical_mass_flux_alg contains diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_horizontal_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_horizontal_mass_flux_alg_mod.x90 index 30078a4996..fafac236d6 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_horizontal_mass_flux_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_horizontal_mass_flux_alg_mod.x90 @@ -21,7 +21,7 @@ module atlt_horizontal_mass_flux_alg_mod implicit none - public + public :: atlt_horizontal_mass_flux_alg contains diff --git a/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 b/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 index e4adbadba4..19b8460a00 100644 --- a/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 @@ -7,16 +7,16 @@ !> @brief Adjoint to the vorticity advection component !> of the rhs of the momentum equation. module atl_vorticity_advection_kernel_mod -use kernel_mod, only: kernel_type -use argument_mod, only: arg_type, func_type, & - GH_FIELD, GH_REAL, & - GH_READ, GH_INC, & - ANY_SPACE_9, & - ANY_DISCONTINUOUS_SPACE_3, & - GH_BASIS, GH_DIFF_BASIS, & - CELL_COLUMN, GH_QUADRATURE_XYoZ -use constants_mod, only: r_def, i_def -use fs_continuity_mod, only: W1, W2, Wchi +use kernel_mod, only: kernel_type +use argument_mod, only: arg_type, func_type, & + GH_FIELD, GH_REAL, & + GH_READ, GH_INC, & + ANY_SPACE_9, & + ANY_DISCONTINUOUS_SPACE_3, & + GH_BASIS, GH_DIFF_BASIS, & + CELL_COLUMN, GH_QUADRATURE_XYoZ +use constants_mod, only: r_def, i_def +use fs_continuity_mod, only: W1, W2, Wchi use base_mesh_config_mod, only: geometry, topology use finite_element_config_mod, only: coord_system @@ -30,13 +30,13 @@ module atl_vorticity_advection_kernel_mod !> The type declaration for the kernel. Contains the metadata needed by the Psy layer type, public, extends(kernel_type) :: atl_vorticity_advection_kernel_type private - type(arg_type) :: meta_args(7) = (/ & - arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & - arg_type(GH_FIELD, GH_REAL, GH_INC, W2), & - arg_type(GH_FIELD, GH_REAL, GH_INC, W1), & - arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & - arg_type(GH_FIELD, GH_REAL, GH_READ, W1), & - arg_type(GH_FIELD*3, GH_REAL, GH_READ, WChi), & + type(arg_type) :: meta_args(7) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & + arg_type(GH_FIELD, GH_REAL, GH_INC, W2), & + arg_type(GH_FIELD, GH_REAL, GH_INC, W1), & + arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & + arg_type(GH_FIELD, GH_REAL, GH_READ, W1), & + arg_type(GH_FIELD*3, GH_REAL, GH_READ, WChi), & arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3) & /) type(func_type) :: meta_funcs(3) = (/ & diff --git a/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 index 4c3d573313..085254159a 100644 --- a/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 @@ -102,7 +102,6 @@ subroutine adj_horizontal_mass_flux_code( nlayers, & ijp = map_md(1) + (df-1)*nlayers reconstruction(ijp + k) = reconstruction(ijp + k) & + mass_flux(map_w2(df) + k)*wind(map_w2(df)+k) - end if end do end do diff --git a/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 index c82496bb7f..08e7425eae 100644 --- a/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 @@ -112,4 +112,4 @@ subroutine atl_horizontal_mass_flux_code( nlayers, & end subroutine atl_horizontal_mass_flux_code -end module atl_horizontal_mass_flux_kernel_mod +end module atl_horizontal_mass_flux_kernel_mod diff --git a/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 index bda3189be1..5c5bc3fcb3 100644 --- a/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 @@ -116,7 +116,6 @@ subroutine atl_vertical_mass_flux_code( nlayers, & + mass_flux(map_w2(df) + k)*( & wgt*reconstruction(ijp1) & + (1.0_r_def-wgt)*reconstruction(ijp2)) - end do mass_flux( map_w2(df) ) = 0.0_r_def From 64efaca8f176e584fd7f75bf769bc3ce4e6968d1 Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 21 Jul 2026 11:07:45 +0100 Subject: [PATCH 11/22] More tidying --- .../algorithm/transport/mol/atlt_vertical_mass_flux_alg_mod.x90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_vertical_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_vertical_mass_flux_alg_mod.x90 index 3b0119cada..10c392906d 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_vertical_mass_flux_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_vertical_mass_flux_alg_mod.x90 @@ -21,7 +21,7 @@ module atlt_vertical_mass_flux_alg_mod implicit none - public + public :: atlt_vertical_mass_flux_alg contains From 856078faa4c543eabb006ec47e81bfd10828afe3 Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 21 Jul 2026 11:15:45 +0100 Subject: [PATCH 12/22] More tidying --- .../transport/common/atlt_vorticity_advection_alg_mod.x90 | 1 - 1 file changed, 1 deletion(-) diff --git a/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 index ac657713f6..81f667b646 100644 --- a/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/common/atlt_vorticity_advection_alg_mod.x90 @@ -21,7 +21,6 @@ module atlt_vorticity_advection_alg_mod LOG_LEVEL_INFO, & LOG_LEVEL_DEBUG - implicit none public :: atlt_vorticity_advection_alg From 5d5d431b1209efc085b34985f31bac5b1f245b6c Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 21 Jul 2026 11:18:14 +0100 Subject: [PATCH 13/22] Added indenting to make this consistent with other adjoint kernels --- .../mol/atl_vertical_mass_flux_kernel_mod.F90 | 212 +++++++++--------- 1 file changed, 106 insertions(+), 106 deletions(-) diff --git a/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 index 5c5bc3fcb3..b162efd40d 100644 --- a/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 @@ -10,115 +10,115 @@ !! upwind reconstruction of a field on cell edges. module atl_vertical_mass_flux_kernel_mod -use argument_mod, only : arg_type, func_type, & - GH_FIELD, GH_REAL, & - GH_READINC, GH_READ, & - GH_INC, & - CELL_COLUMN, & - ANY_DISCONTINUOUS_SPACE_1, & - ANY_W2 -use constants_mod, only : r_def, i_def, l_def -use kernel_mod, only : kernel_type + use argument_mod, only : arg_type, func_type, & + GH_FIELD, GH_REAL, & + GH_READINC, GH_READ, & + GH_INC, & + CELL_COLUMN, & + ANY_DISCONTINUOUS_SPACE_1, & + ANY_W2 + use constants_mod, only : r_def, i_def, l_def + use kernel_mod, only : kernel_type -implicit none - -private + implicit none -!------------------------------------------------------------------------------- -! Public types -!------------------------------------------------------------------------------- -!> The type declaration for the kernel. Contains the metadata needed by the PSy layer -type, public, extends(kernel_type) :: atl_vertical_mass_flux_kernel_type private - type(arg_type) :: meta_args(4) = (/ & - arg_type(GH_FIELD, GH_REAL, GH_READINC, ANY_W2), & - arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_W2), & - arg_type(GH_FIELD, GH_REAL, GH_INC, ANY_W2), & - arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1) & - /) - integer :: operates_on = CELL_COLUMN -contains - procedure, nopass :: atl_vertical_mass_flux_code -end type - -!------------------------------------------------------------------------------- -! Contained functions/subroutines -!------------------------------------------------------------------------------- -public :: atl_vertical_mass_flux_code - -contains - -!> @brief Computes the vertical mass flux: wind*reconstruction. -!> @param[in] nlayers Number of layers -!> @param[in,out] mass_flux Vertical mass flux -!> @param[in] ls_wind Linear wind field -!> @param[in,out] wind Perturbation wind field -!> @param[in] reconstruction Tracer field reconstructed on cell edges -!> @param[in] ndf_w2 Number of degrees of freedom per cell -!> @param[in] undf_w2 Number of unique degrees of freedom for the wind field -!> @param[in] map_w2 Dofmap for the cell at the base of the column -!> @param[in] ndf_md Number of degrees of freedom per cell -!> @param[in] undf_md Number of unique degrees of freedom for the -!! reconstructed field -!> @param[in] map_md Dofmap for the cell at the base of the column -subroutine atl_vertical_mass_flux_code( nlayers, & - mass_flux, & - ls_wind, & - wind, & - reconstruction, & - ndf_w2, & - undf_w2, & - map_w2, & - ndf_md, & - undf_md, & - map_md ) - - implicit none - ! Arguments - integer(kind=i_def), intent(in) :: nlayers - integer(kind=i_def), intent(in) :: ndf_md - integer(kind=i_def), intent(in) :: undf_md - integer(kind=i_def), dimension(ndf_md), intent(in) :: map_md - integer(kind=i_def), intent(in) :: ndf_w2 - integer(kind=i_def), intent(in) :: undf_w2 - integer(kind=i_def), dimension(ndf_w2), intent(in) :: map_w2 - - real(kind=r_def), dimension(undf_md), intent(in) :: reconstruction - real(kind=r_def), dimension(undf_w2), intent(inout) :: wind - real(kind=r_def), dimension(undf_w2), intent(in) :: ls_wind - real(kind=r_def), dimension(undf_w2), intent(inout) :: mass_flux - - ! Internal variables - integer(kind=i_def) :: k, df, ijp1, ijp2, offset - real(kind=r_def) :: wgt - - ! df of dof on face - if ( ndf_w2 == 2 ) then - ! W2v space, reconstruction has ndata=2 - df = 1 - offset = 0 - else - ! W2 space, reconstruction has ndata=6 - df = 5 - offset = 4*nlayers - end if - - mass_flux( map_w2(df) + nlayers ) = 0.0_r_def - do k = nlayers - 1, 1, -1 - ! Value from bottom face of cell above edge - ijp2 = map_md(1) + offset + nlayers + k-1 - ! Take value from top face of cell below edge - ijp1 = map_md(1) + offset + k - - wgt = (0.5_r_def - sign(0.5_r_def, ls_wind(map_w2(df)+k))) - wind(k + map_w2(df)) = wind(k + map_w2(df)) & - + mass_flux(map_w2(df) + k)*( & - wgt*reconstruction(ijp1) & - + (1.0_r_def-wgt)*reconstruction(ijp2)) - end do - mass_flux( map_w2(df) ) = 0.0_r_def - -end subroutine atl_vertical_mass_flux_code + !------------------------------------------------------------------------------- + ! Public types + !------------------------------------------------------------------------------- + !> The type declaration for the kernel. Contains the metadata needed by the PSy layer + type, public, extends(kernel_type) :: atl_vertical_mass_flux_kernel_type + private + type(arg_type) :: meta_args(4) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_READINC, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_INC, ANY_W2), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_1) & + /) + integer :: operates_on = CELL_COLUMN + contains + procedure, nopass :: atl_vertical_mass_flux_code + end type + + !------------------------------------------------------------------------------- + ! Contained functions/subroutines + !------------------------------------------------------------------------------- + public :: atl_vertical_mass_flux_code + + contains + + !> @brief Computes the vertical mass flux: wind*reconstruction. + !> @param[in] nlayers Number of layers + !> @param[in,out] mass_flux Vertical mass flux + !> @param[in] ls_wind Linear wind field + !> @param[in,out] wind Perturbation wind field + !> @param[in] reconstruction Tracer field reconstructed on cell edges + !> @param[in] ndf_w2 Number of degrees of freedom per cell + !> @param[in] undf_w2 Number of unique degrees of freedom for the wind field + !> @param[in] map_w2 Dofmap for the cell at the base of the column + !> @param[in] ndf_md Number of degrees of freedom per cell + !> @param[in] undf_md Number of unique degrees of freedom for the + !! reconstructed field + !> @param[in] map_md Dofmap for the cell at the base of the column + subroutine atl_vertical_mass_flux_code( nlayers, & + mass_flux, & + ls_wind, & + wind, & + reconstruction, & + ndf_w2, & + undf_w2, & + map_w2, & + ndf_md, & + undf_md, & + map_md ) + + implicit none + + ! Arguments + integer(kind=i_def), intent(in) :: nlayers + integer(kind=i_def), intent(in) :: ndf_md + integer(kind=i_def), intent(in) :: undf_md + integer(kind=i_def), dimension(ndf_md), intent(in) :: map_md + integer(kind=i_def), intent(in) :: ndf_w2 + integer(kind=i_def), intent(in) :: undf_w2 + integer(kind=i_def), dimension(ndf_w2), intent(in) :: map_w2 + + real(kind=r_def), dimension(undf_md), intent(in) :: reconstruction + real(kind=r_def), dimension(undf_w2), intent(inout) :: wind + real(kind=r_def), dimension(undf_w2), intent(in) :: ls_wind + real(kind=r_def), dimension(undf_w2), intent(inout) :: mass_flux + + ! Internal variables + integer(kind=i_def) :: k, df, ijp1, ijp2, offset + real(kind=r_def) :: wgt + + ! df of dof on face + if ( ndf_w2 == 2 ) then + ! W2v space, reconstruction has ndata=2 + df = 1 + offset = 0 + else + ! W2 space, reconstruction has ndata=6 + df = 5 + offset = 4*nlayers + end if + + mass_flux( map_w2(df) + nlayers ) = 0.0_r_def + do k = nlayers - 1, 1, -1 + ! Value from bottom face of cell above edge + ijp2 = map_md(1) + offset + nlayers + k-1 + ! Take value from top face of cell below edge + ijp1 = map_md(1) + offset + k + + wgt = (0.5_r_def - sign(0.5_r_def, ls_wind(map_w2(df)+k))) + wind(k + map_w2(df)) = wind(k + map_w2(df)) & + + mass_flux(map_w2(df) + k)*( & + wgt*reconstruction(ijp1) & + + (1.0_r_def-wgt)*reconstruction(ijp2)) + end do + mass_flux( map_w2(df) ) = 0.0_r_def + + end subroutine atl_vertical_mass_flux_code end module atl_vertical_mass_flux_kernel_mod From d42889c4fc299a91c41681b465fdf27b257bf7be Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 21 Jul 2026 14:37:02 +0100 Subject: [PATCH 14/22] Some tidying --- .../transport/mol/atl_vertical_mass_flux_kernel_mod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 index b162efd40d..f53a3ebfe3 100644 --- a/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 @@ -112,9 +112,9 @@ subroutine atl_vertical_mass_flux_code( nlayers, & ijp1 = map_md(1) + offset + k wgt = (0.5_r_def - sign(0.5_r_def, ls_wind(map_w2(df)+k))) - wind(k + map_w2(df)) = wind(k + map_w2(df)) & + wind(k + map_w2(df)) = wind(k + map_w2(df)) & + mass_flux(map_w2(df) + k)*( & - wgt*reconstruction(ijp1) & + wgt*reconstruction(ijp1) & + (1.0_r_def-wgt)*reconstruction(ijp2)) end do mass_flux( map_w2(df) ) = 0.0_r_def From b7f3192fb24639feb7da9c01dd7cbfae3bf74e66 Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Tue, 21 Jul 2026 15:30:59 +0100 Subject: [PATCH 15/22] Fixed bug in adjoint kernel --- .../kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 index f53a3ebfe3..a5a2d68ce5 100644 --- a/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod.F90 @@ -112,10 +112,11 @@ subroutine atl_vertical_mass_flux_code( nlayers, & ijp1 = map_md(1) + offset + k wgt = (0.5_r_def - sign(0.5_r_def, ls_wind(map_w2(df)+k))) - wind(k + map_w2(df)) = wind(k + map_w2(df)) & + wind(map_w2(df) + k) = wind(map_w2(df) + k) & + mass_flux(map_w2(df) + k)*( & wgt*reconstruction(ijp1) & + (1.0_r_def-wgt)*reconstruction(ijp2)) + mass_flux(map_w2(df) + k) = 0.0_r_def end do mass_flux( map_w2(df) ) = 0.0_r_def From ade05b39cfd3b2a0eef5cb68d24ec02dc0a937dc Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Wed, 22 Jul 2026 10:54:04 +0100 Subject: [PATCH 16/22] Changed style of scale factor calculation to reduce brackets --- .../transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 | 6 +++--- .../transport/mol/adjt_vertical_mass_flux_alg_mod.x90 | 6 +++--- .../transport/mol/adjt_w3v_advective_update_alg_mod.x90 | 6 +++--- .../transport/mol/atlt_w3v_advective_update_alg_mod.x90 | 6 +++--- 4 files changed, 12 insertions(+), 12 deletions(-) diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 index 3c7870b520..7ad17ba5f6 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_horizontal_mass_flux_alg_mod.x90 @@ -13,7 +13,7 @@ module adjt_horizontal_mass_flux_alg_mod use function_space_collection_mod, only : function_space_collection use fs_continuity_mod, only : W2, W3 use constants_mod, only : i_def, r_def, & - r_tran, EPS_R_TRAN + r_tran, EPS use log_mod, only : log_event, & log_scratch_space, & LOG_LEVEL_ERROR, & @@ -104,8 +104,8 @@ module adjt_horizontal_mass_flux_alg_mod write( log_scratch_space, * ) "reconstruction inner product = ", reconstruction_inner_prod call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) - mass_flux_sf = 1.0_r_tran / ( real(mass_flux_inner_prod, kind=r_tran) + EPS_R_TRAN ) - reconstruction_sf = 1.0_r_tran / ( real(reconstruction_inner_prod, kind=r_tran) + EPS_R_TRAN ) + mass_flux_sf = 1.0_r_tran / real(mass_flux_inner_prod + EPS, kind=r_tran) + reconstruction_sf = 1.0_r_tran / real(reconstruction_inner_prod + EPS, kind=r_tran) inner1 = 0.0_r_tran inner1 = inner1 + real(mass_flux_inner_prod, kind=r_tran) * mass_flux_sf diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 index 4bab652521..bd3995c8c6 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_vertical_mass_flux_alg_mod.x90 @@ -13,7 +13,7 @@ module adjt_vertical_mass_flux_alg_mod use function_space_collection_mod, only : function_space_collection use fs_continuity_mod, only : W2, W3 use constants_mod, only : i_def, r_def, & - r_tran, EPS_R_TRAN + r_tran, EPS use log_mod, only : log_event, & log_scratch_space, & LOG_LEVEL_ERROR, & @@ -104,8 +104,8 @@ module adjt_vertical_mass_flux_alg_mod write( log_scratch_space, * ) "reconstruction inner product = ", reconstruction_inner_prod call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) - mass_flux_sf = 1.0_r_tran / ( real(mass_flux_inner_prod, kind=r_tran) + EPS_R_TRAN ) - reconstruction_sf = 1.0_r_tran / ( real(reconstruction_inner_prod, kind=r_tran) + EPS_R_TRAN ) + mass_flux_sf = 1.0_r_tran / real(mass_flux_inner_prod + EPS, kind=r_tran) + reconstruction_sf = 1.0_r_tran / real(reconstruction_inner_prod + EPS, kind=r_tran) inner1 = 0.0_r_tran inner1 = inner1 + real(mass_flux_inner_prod, kind=r_tran) * mass_flux_sf diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_w3v_advective_update_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_w3v_advective_update_alg_mod.x90 index c7d6ec62a6..ef07d7bc83 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/adjt_w3v_advective_update_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/adjt_w3v_advective_update_alg_mod.x90 @@ -13,7 +13,7 @@ module adjt_w3v_advective_update_alg_mod use function_space_collection_mod, only : function_space_collection use fs_continuity_mod, only : W2, W3 use constants_mod, only : i_def, r_def, & - r_tran, EPS_R_TRAN + r_tran, EPS use operator_mod, only : operator_type use setop_random_alg_mod, only : setop_random_alg use log_mod, only : log_event, & @@ -113,8 +113,8 @@ module adjt_w3v_advective_update_alg_mod write( log_scratch_space, * ) "tracer inner product = ", tracer_inner_prod call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) - advective_increment_sf = 1.0_r_tran / ( real(advective_increment_inner_prod, kind=r_tran) + EPS_R_TRAN ) - tracer_sf = 1.0_r_tran / ( real(tracer_inner_prod, kind=r_tran) + EPS_R_TRAN ) + advective_increment_sf = 1.0_r_tran / real(advective_increment_inner_prod + EPS, kind=r_tran) + tracer_sf = 1.0_r_tran / real(tracer_inner_prod + EPS, kind=r_tran) inner1 = 0.0_r_tran inner1 = inner1 + real(advective_increment_inner_prod, kind=r_tran) * advective_increment_sf diff --git a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_w3v_advective_update_alg_mod.x90 b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_w3v_advective_update_alg_mod.x90 index 83a1d9dbe8..6e9fa17665 100644 --- a/applications/adjoint_tests/source/algorithm/transport/mol/atlt_w3v_advective_update_alg_mod.x90 +++ b/applications/adjoint_tests/source/algorithm/transport/mol/atlt_w3v_advective_update_alg_mod.x90 @@ -13,7 +13,7 @@ module atlt_w3v_advective_update_alg_mod use function_space_collection_mod, only : function_space_collection use fs_continuity_mod, only : W2, W3 use constants_mod, only : i_def, r_def, & - r_tran, EPS_R_TRAN + r_tran, EPS use operator_mod, only : operator_type use setop_random_alg_mod, only : setop_random_alg use log_mod, only : log_event, & @@ -116,8 +116,8 @@ module atlt_w3v_advective_update_alg_mod write( log_scratch_space, * ) "wind inner product = ", wind_inner_prod call log_event( log_scratch_space, LOG_LEVEL_DEBUG ) - advective_increment_sf = 1.0_r_tran / ( real(advective_increment_inner_prod, kind=r_tran) + EPS_R_TRAN ) - wind_sf = 1.0_r_tran / ( real(wind_inner_prod, kind=r_tran) + EPS_R_TRAN ) + advective_increment_sf = 1.0_r_tran / real(advective_increment_inner_prod + EPS, kind=r_tran) + wind_sf = 1.0_r_tran / real(wind_inner_prod + EPS, kind=r_tran) inner1 = 0.0_r_tran inner1 = inner1 + real(advective_increment_inner_prod, kind=r_tran) * advective_increment_sf From 346ecb96abd9dbc1a1e97299c282de87bc97ee1f Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Wed, 29 Jul 2026 10:22:27 +0100 Subject: [PATCH 17/22] Addressed review comments --- .../mol/adj_horizontal_mass_flux_kernel_mod.F90 | 13 +++++-------- .../mol/atl_horizontal_mass_flux_kernel_mod.F90 | 14 +++++--------- 2 files changed, 10 insertions(+), 17 deletions(-) diff --git a/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 index 085254159a..2d454d2cdb 100644 --- a/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod.F90 @@ -85,14 +85,11 @@ subroutine adj_horizontal_mass_flux_code( nlayers, & real(kind=r_tran), dimension(undf_w2), intent(in) :: mass_flux ! Internal variables - integer(kind=i_def) :: k, df, ijp - integer(kind=i_def), parameter :: nfaces = 4 - real(kind=r_tran) :: direction - real(kind=r_tran), dimension(nfaces) :: v_dot_n - - ! Implied direction of outward normals dotted with basis functions. - ! If u*u_dot_n > 0 then this is the upwind cell - v_dot_n = (/ -1.0_r_tran, 1.0_r_tran, 1.0_r_tran, -1.0_r_tran /) + integer(kind=i_def) :: k, df, ijp + integer(kind=i_def), parameter :: nfaces = 4 + real(kind=r_tran) :: direction + real(kind=r_tran), dimension(nfaces), parameter :: v_dot_n = (/ -1.0_r_tran, 1.0_r_tran, & + 1.0_r_tran, -1.0_r_tran /) do df = nfaces, 1, -1 do k = nlayers - 1, 0, -1 diff --git a/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 b/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 index 08e7425eae..f1903abca5 100644 --- a/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod.F90 @@ -89,15 +89,11 @@ subroutine atl_horizontal_mass_flux_code( nlayers, & real(kind=r_def), dimension(undf_w2), intent(in) :: mass_flux ! Internal variables - integer(kind=i_def) :: k, df, ijp - integer(kind=i_def), parameter :: nfaces = 4 - real(kind=r_def) :: direction - real(kind=r_def), dimension(nfaces) :: v_dot_n - - ! Implied direction of outward normals dotted with basis functions. - ! If u*u_dot_n > 0 then this is the upwind cell - v_dot_n = (/ -1.0_r_def, 1.0_r_def, 1.0_r_def, -1.0_r_def /) - + integer(kind=i_def) :: k, df, ijp + integer(kind=i_def), parameter :: nfaces = 4 + real(kind=r_def) :: direction + real(kind=r_def), dimension(nfaces), parameter :: v_dot_n = (/ -1.0_r_def, 1.0_r_def, & + 1.0_r_def, -1.0_r_def /) do df = nfaces, 1, -1 do k = nlayers - 1, 0, -1 direction = ls_wind(map_w2(df) + k)*v_dot_n(df) From e4f7eeab3de990a075e9a2821777d0f5e8a991cf Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Thu, 27 Aug 2026 11:57:04 +0100 Subject: [PATCH 18/22] Small optimisation --- .../atl_vorticity_advection_kernel_mod.F90 | 20 ++++++------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 b/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 index 19b8460a00..690887220c 100644 --- a/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 +++ b/science/adjoint/source/kernel/transport/common/atl_vorticity_advection_kernel_mod.F90 @@ -172,12 +172,6 @@ subroutine atl_vorticity_advection_code(nlayers, & chi_3_e(df) = chi_3( loc ) end do - ! The nonlinear term is: - ! v.( [(J^-1 * J^-T) * vorticity] cross u ) - ! The corresponding linear term is: - ! v.( ( [(J^-1 * J^-T) * ls_vorticity] cross u ) - ! + ( [(J^-1 * J^-T) * vorticity] cross u_ls ) ) - do qp2 = 1, nqp_v do qp1 = 1, nqp_h @@ -212,17 +206,15 @@ subroutine atl_vorticity_advection_code(nlayers, & vorticity_term(:) = vorticity_term(:) - w2_basis(:,df,qp1,qp2) * r_u( map_w2(df) + k ) end do - j_vorticity(:) = 0.0_r_def - u_at_quad(:) = 0.0_r_def - j_vorticity(1) = j_vorticity(1) + vorticity_term(3) * u_ls_at_quad(2) - j_vorticity(2) = j_vorticity(2) - vorticity_term(3) * u_ls_at_quad(1) - u_at_quad(2) = u_at_quad(2) + vorticity_term(3) * j_ls_vorticity(1) - u_at_quad(1) = u_at_quad(1) - vorticity_term(3) * j_ls_vorticity(2) + j_vorticity(1) = vorticity_term(3) * u_ls_at_quad(2) + j_vorticity(2) = -vorticity_term(3) * u_ls_at_quad(1) + u_at_quad(2) = vorticity_term(3) * j_ls_vorticity(1) + u_at_quad(1) = -vorticity_term(3) * j_ls_vorticity(2) - j_vorticity(3) = j_vorticity(3) + vorticity_term(2) * u_ls_at_quad(1) + j_vorticity(3) = vorticity_term(2) * u_ls_at_quad(1) j_vorticity(1) = j_vorticity(1) - vorticity_term(2) * u_ls_at_quad(3) u_at_quad(1) = u_at_quad(1) + vorticity_term(2) * j_ls_vorticity(3) - u_at_quad(3) = u_at_quad(3) - vorticity_term(2) * j_ls_vorticity(1) + u_at_quad(3) = -vorticity_term(2) * j_ls_vorticity(1) j_vorticity(2) = j_vorticity(2) + vorticity_term(1) * u_ls_at_quad(3) j_vorticity(3) = j_vorticity(3) - vorticity_term(1) * u_ls_at_quad(2) From 2da43f55e1fcfd7c3467ffd14c34bfcc50c5abfb Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Thu, 3 Sep 2026 11:46:11 +0100 Subject: [PATCH 19/22] Added unit test files --- science/adjoint/Makefile | 13 +- science/adjoint/fortitude.toml | 8 + ...atl_vorticity_advection_kernel_mod_test.pf | 329 ++++++++++++++++++ ...dj_horizontal_mass_flux_kernel_mod_test.pf | 86 +++++ .../adj_vertical_mass_flux_kernel_mod_test.pf | 93 +++++ ...dj_w3v_advective_update_kernel_mod_test.pf | 92 +++++ ...tl_horizontal_mass_flux_kernel_mod_test.pf | 103 ++++++ .../atl_poly1d_vert_adv_kernel_mod_test.pf | 243 +++++++++++++ .../atl_vertical_mass_flux_kernel_mod_test.pf | 98 ++++++ ...tl_w3v_advective_update_kernel_mod_test.pf | 101 ++++++ 10 files changed, 1161 insertions(+), 5 deletions(-) create mode 100644 science/adjoint/unit-test/kernel/transport/common/atl_vorticity_advection_kernel_mod_test.pf create mode 100644 science/adjoint/unit-test/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod_test.pf create mode 100644 science/adjoint/unit-test/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod_test.pf create mode 100644 science/adjoint/unit-test/kernel/transport/mol/adj_w3v_advective_update_kernel_mod_test.pf create mode 100644 science/adjoint/unit-test/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod_test.pf create mode 100644 science/adjoint/unit-test/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod_test.pf create mode 100644 science/adjoint/unit-test/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod_test.pf create mode 100644 science/adjoint/unit-test/kernel/transport/mol/atl_w3v_advective_update_kernel_mod_test.pf diff --git a/science/adjoint/Makefile b/science/adjoint/Makefile index 1988e6d863..24d0bc6676 100644 --- a/science/adjoint/Makefile +++ b/science/adjoint/Makefile @@ -73,17 +73,20 @@ document-latex: ALWAYS ############################################################################## # Unit tests # +unit-tests/%: export ADDITIONAL_EXTRACTION = \ + $(CORE_ROOT_DIR)/components/science/unit-test/support unit-tests/%: export BIN_DIR ?= $(PROJECT_DIR)/test unit-tests/%: export EXTERNAL_STATIC_LIBRARIES += pfunit unit-tests/%: export IMPORT_PARTS = $(CORE_ROOT_DIR)/infrastructure \ $(CORE_ROOT_DIR)/components/science \ $(APPS_ROOT_DIR)/science/gungho \ $(APPS_ROOT_DIR)/science/linear -unit-tests/%: export PROGRAMS = adjoint_unit_tests -unit-tests/%: export PROJECT = adjoint -unit-tests/%: export SOURCE_DIR = source -unit-tests/%: export TEST_DIR = unit-test -unit-tests/%: export WORKING_DIR := $(WORKING_DIR)/unit-tests +unit-tests/%: export META_FILE_DIR = rose-meta/lfric-adjoint/HEAD +unit-tests/%: export PROGRAMS = adjoint_unit_tests +unit-tests/%: export PROJECT = adjoint +unit-tests/%: export SOURCE_DIR = source +unit-tests/%: export TEST_DIR = unit-test +unit-tests/%: export WORKING_DIR := $(WORKING_DIR)/unit-tests unit-tests: extract_meta unit-tests/run unit-tests/build: extract_meta unit-tests/build diff --git a/science/adjoint/fortitude.toml b/science/adjoint/fortitude.toml index 085d9de023..80ee5d3b58 100644 --- a/science/adjoint/fortitude.toml +++ b/science/adjoint/fortitude.toml @@ -22,6 +22,14 @@ output-format = "grouped" #group results by file "setop_average_two_fields_kernel_mod_test.pf" = ["E001", "C121"] "setop_random_kernel_mod_test.pf" = ["E001", "C121"] "set_mask_by_threshold_kernel_mod_test.pf" = ["E001", "C121"] +"atl_vorticity_advection_kernel_mod_test.pf" = ["E001", "C121"] +"adj_horizontal_mass_flux_kernel_mod_test.pf" = ["E001", "C121"] +"adj_vertical_mass_flux_kernel_mod_test.pf" = ["E001", "C121"] +"adj_w3v_advective_update_kernel_mod_test.pf" = ["E001", "C121"] +"atl_horizontal_mass_flux_kernel_mod_test.pf" = ["E001", "C121"] +"atl_poly1d_vert_adv_kernel_mod._testpf" = ["E001", "C121"] +"atl_vertical_mass_flux_kernel_mod_test.pf" = ["E001", "C121"] +"atl_w3v_advective_update_kernel_mod_test.pf" = ["E001", "C121"] "adj_mixed_operator_alg_mod.x90" = ["C061"] "atl_hydrostatic_kernel_mod.F90" = ["C031"] "atl_kinetic_energy_gradient_kernel_mod.F90" = ["C031"] diff --git a/science/adjoint/unit-test/kernel/transport/common/atl_vorticity_advection_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/common/atl_vorticity_advection_kernel_mod_test.pf new file mode 100644 index 0000000000..c95fdb3a52 --- /dev/null +++ b/science/adjoint/unit-test/kernel/transport/common/atl_vorticity_advection_kernel_mod_test.pf @@ -0,0 +1,329 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- + +!>@brief Unit test file for the adjoint of the vorticity advection. +module atl_vorticity_advection_kernel_mod_test + + use constants_mod, only: i_def, r_def, imdi + use funit + + use finite_element_config_mod, & + only : cellshape_quadrilateral, & + coord_system_xyz, coord_space_wchi + use feign_config_mod, only : feign_finite_element_config + use sci_chi_transform_mod, only : init_chi_transforms, & + final_chi_transforms + + use atl_vorticity_advection_kernel_mod, & + only: atl_vorticity_advection_code + + use get_unit_test_m3x3_dofmap_mod, & + only: get_w0_m3x3_dofmap, & + get_w1_m3x3_dofmap, & + get_w2_m3x3_dofmap, & + get_w3_m3x3_dofmap + + use get_unit_test_m3x3_q3x3x3_sizes_mod, & + only: get_w0_m3x3_q3x3x3_size, & + get_w1_m3x3_q3x3x3_size, & + get_w2_m3x3_q3x3x3_size, & + get_w3_m3x3_q3x3x3_size + + use get_unit_test_q3x3x3_basis_mod, & + only: get_w0_q3x3x3_diff_basis, & + get_w1_q3x3x3_basis, & + get_w2_q3x3x3_basis, & + get_w0_q3x3x3_basis + + use get_unit_test_q3x3x3_quadrature_mod, & + only: get_gaussian_q3x3x3_quadrature_weights_xy, & + get_gaussian_q3x3x3_quadrature_weights_z + + use get_unit_test_3x3x3_chi_mod, & + only : get_w0_3x3x3_field + + implicit none + + private + public :: atl_vorticity_advection_test_type, & + test_computed_output + + @TestCase + type, extends(TestCase) :: atl_vorticity_advection_test_type + private + + real(r_def), allocatable :: r_u_data(:) + real(r_def), allocatable :: xi_data(:) + real(r_def), allocatable :: mass_flux_data(:) + real(r_def), allocatable :: ls_xi_data(:) + real(r_def), allocatable :: ls_mass_flux_data(:) + + real(r_def), allocatable :: basis_r_u(:,:,:,:) + real(r_def), allocatable :: basis_xi(:,:,:,:) + real(r_def), allocatable :: basis_chi(:,:,:,:) + real(r_def), allocatable :: diff_basis_chi(:,:,:,:) + + integer(i_def), allocatable :: map_chi(:,:) + integer(i_def), allocatable :: map_r_u(:,:) + integer(i_def), allocatable :: map_xi(:,:) + + integer(i_def) :: ndf_chi, undf_chi + integer(i_def) :: ndf_r_u, undf_r_u + integer(i_def) :: ndf_xi, undf_xi + + integer(i_def) :: nqp_h, nqp_v + integer(i_def) :: ncells + integer(i_def) :: dim_space, dim_space_diff + + real(r_def), allocatable :: wh(:) + real(r_def), allocatable :: wv(:) + + real(r_def), allocatable :: chi_data(:,:) + real(r_def), allocatable :: panel_id(:) + + real(r_def), allocatable :: basis_w1(:,:,:,:) + real(r_def), allocatable :: basis_w2(:,:,:,:) + real(r_def), allocatable :: basis_w0(:,:,:,:) + real(r_def), allocatable :: diff_basis_w0(:,:,:,:) + + integer(i_def), allocatable :: map_w0(:,:) + integer(i_def), allocatable :: map_w1(:,:) + integer(i_def), allocatable :: map_w2(:,:) + integer(i_def), allocatable :: map_pid(:,:) + + integer(i_def) :: ndf_w0, undf_w0 + integer(i_def) :: ndf_w1, undf_w1 + integer(i_def) :: ndf_w2, undf_w2 + integer(i_def) :: ndf_pid, undf_pid + + contains + procedure setUp + procedure tearDown + procedure test_computed_output + + end type atl_vorticity_advection_test_type + + real(r_def), parameter :: tol = 1.0e-9_r_def + real(r_def), parameter :: dx = 6000.0_r_def, & + dy = 1000.0_r_def, & + dz = 2000.0_r_def + integer(i_def), parameter :: nlayers = 3 + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine setUp( this ) + + implicit none + + class(atl_vorticity_advection_test_type), intent(inout) :: this + + call feign_finite_element_config( & + cellshape=cellshape_quadrilateral, & + coord_order=0_i_def, & + coord_order_nonprime=1_i_def, & + coord_space=coord_space_wchi, & + coord_system=coord_system_xyz, & + element_order_h=0_i_def, & + element_order_v=0_i_def, & + rehabilitate=.true., & + vorticity_in_w1=.false. ) + + call init_chi_transforms(imdi, imdi) + + ! Get infrastructure support data + !===================================== + + ! Get w0 + call get_w0_m3x3_q3x3x3_size( this%ndf_w0, & + this%undf_w0, & + this%ncells, & + this%dim_space, & + this%dim_space_diff, & + this%nqp_h, & + this%nqp_v, & + nlayers ) + + call get_w0_m3x3_dofmap( this%map_w0 ) + call get_w0_q3x3x3_diff_basis( this%basis_w0 ) + call get_w0_q3x3x3_diff_basis( this%diff_basis_w0 ) + + ! Get w1 + call get_w1_m3x3_q3x3x3_size( this%ndf_w1, & + this%undf_w1, & + this%ncells, & + this%dim_space, & + this%dim_space_diff, & + this%nqp_h, & + this%nqp_v, & + nlayers ) + call get_w1_m3x3_dofmap( this%map_w1 ) + call get_w1_q3x3x3_basis( this%basis_w1 ) + + ! Get w2 + call get_w2_m3x3_q3x3x3_size( this%ndf_w2, & + this%undf_w2, & + this%ncells, & + this%dim_space, & + this%dim_space_diff, & + this%nqp_h, & + this%nqp_v, & + nlayers ) + call get_w2_m3x3_dofmap( this%map_w2 ) + call get_w2_q3x3x3_basis( this%basis_w2 ) + + ! Get panel_id function space entities + call get_w3_m3x3_q3x3x3_size( this%ndf_pid, & + this%undf_pid, & + this%ncells, & + this%dim_space, & + this%dim_space_diff, & + this%nqp_h, & + this%nqp_v, & + 1 ) + call get_w3_m3x3_dofmap( this%map_pid, 1 ) + + ! Get weights + call get_gaussian_q3x3x3_quadrature_weights_xy(this%wh) + call get_gaussian_q3x3x3_quadrature_weights_z(this%wv) + + ! Compute coordinates + allocate(this%chi_data(3,this%undf_w0)) + allocate(this%panel_id(this%undf_pid)) + + this%panel_id(:) = 1.0_r_def + call get_w0_3x3x3_field(this%chi_data(1,:), & + this%chi_data(2,:), & + this%chi_data(3,:), & + dx, dy, dz, & + this%map_w0, & + nlayers) + + ! Assign chi + this%ndf_chi = this%ndf_w0 + this%undf_chi = this%undf_w0 + allocate( this%map_chi, source=this%map_w0 ) + allocate( this%basis_chi, source=this%diff_basis_w0 ) + allocate( this%diff_basis_chi, source=this%diff_basis_w0 ) + + ! Assign r_u + this%ndf_r_u = this%ndf_w2 + this%undf_r_u = this%undf_w2 + allocate( this%map_r_u, source=this%map_w2 ) + allocate( this%basis_r_u, source=this%basis_w2 ) + + ! Assign Xi + this%ndf_xi = this%ndf_w1 + this%undf_xi = this%undf_w1 + allocate( this%map_xi, source=this%map_w1 ) + allocate( this%basis_xi, source=this%basis_w1 ) + + ! Assign Data + allocate( this%r_u_data(this%undf_r_u) ) + allocate( this%xi_data(this%undf_xi) ) + allocate( this%mass_flux_data(this%undf_w2) ) + allocate( this%ls_xi_data(this%undf_xi) ) + allocate( this%ls_mass_flux_data(this%undf_w2) ) + + end subroutine setUp + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine tearDown( this ) + + use config_loader_mod, only: final_configuration + + implicit none + + class(atl_vorticity_advection_test_type), intent(inout) :: this + + deallocate( this%r_u_data ) + deallocate( this%mass_flux_data ) + deallocate( this%xi_data ) + deallocate( this%map_chi ) + deallocate( this%map_r_u ) + deallocate( this%map_xi ) + deallocate( this%map_pid ) + deallocate( this%basis_r_u ) + deallocate( this%basis_xi ) + deallocate( this%diff_basis_chi ) + + deallocate( this%wh ) + deallocate( this%wv ) + deallocate( this%chi_data ) + deallocate( this%basis_w1 ) + deallocate( this%basis_w2 ) + deallocate( this%diff_basis_w0 ) + deallocate( this%map_w0 ) + deallocate( this%map_w1 ) + deallocate( this%map_w2 ) + + call final_configuration() + call final_chi_transforms() + + end subroutine tearDown + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @Test + subroutine test_computed_output( this ) + + implicit none + + class(atl_vorticity_advection_test_type), intent(inout) :: this + real(r_def) :: answer + integer:: k, cell + + !===================================== + ! Apply test on interior cell 1, for non-zero input + cell = 1 + this%r_u_data = 5.0_r_def + this%xi_data = 10.0_r_def + this%mass_flux_data = 15.0_r_def + this%ls_xi_data = 10.0_r_def + this%ls_mass_flux_data = 10.0_r_def + + call atl_vorticity_advection_code( nlayers, & + this%r_u_data, & + this%mass_flux_data, & + this%xi_data, & + this%ls_mass_flux_data, & + this%ls_xi_data, & + this%chi_data(1,:), & + this%chi_data(2,:), & + this%chi_data(3,:), & + this%panel_id, & + this%ndf_r_u, & + this%undf_r_u, & + this%map_r_u(:,cell), & + this%basis_r_u, & + this%ndf_xi, & + this%undf_xi, & + this%map_xi(:,cell), & + this%basis_xi, & + this%ndf_chi, & + this%undf_chi, & + this%map_chi(:,cell), & + this%basis_chi, & + this%diff_basis_chi, & + this%ndf_pid, & + this%undf_pid, & + this%map_pid(:,cell), & + this%nqp_h, & + this%nqp_v, & + this%wh, & + this%wv ) + + ! Answer from known output, rather than calculated analytically + k = 1 + answer = 14.999948611111115_r_def + @assertEqual(answer, this%mass_flux_data(this%map_r_u(5,cell)+k), tol) + @assertEqual(answer, this%mass_flux_data(this%map_r_u(6,cell)+k), tol) + answer = 10.0_r_def + @assertEqual(answer, this%xi_data(this%map_xi(5,cell)+k), tol) + @assertEqual(answer, this%xi_data(this%map_xi(6,cell)+k), tol) + + end subroutine test_computed_output + +end module atl_vorticity_advection_kernel_mod_test diff --git a/science/adjoint/unit-test/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod_test.pf new file mode 100644 index 0000000000..d37c880ce0 --- /dev/null +++ b/science/adjoint/unit-test/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod_test.pf @@ -0,0 +1,86 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- + +module adj_horizontal_mass_flux_kernel_mod_test + + use adj_horizontal_mass_flux_kernel_mod, only: adj_horizontal_mass_flux_code + use constants_mod, only: i_def, r_def, l_def + use funit + + implicit none + + private + + public :: adj_horizontal_mass_flux_kernel_test_type, test_all + + @TestCase + type, extends(TestCase) :: adj_horizontal_mass_flux_kernel_test_type + private + contains + procedure test_all + end type adj_horizontal_mass_flux_kernel_test_type + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @Test + subroutine test_all( this) + + implicit none + + class(adj_horizontal_mass_flux_kernel_test_type), intent(inout) :: this + + integer(kind=i_def), parameter :: nlayers = 1 + integer(kind=i_def), parameter :: ndf_w2 = 4 + integer(kind=i_def), parameter :: undf_w2 = nlayers*ndf_w2 + integer(kind=i_def), dimension(ndf_w2) :: map_w2 + integer(kind=i_def), parameter :: ndf_md = 1 + integer(kind=i_def), parameter :: ndata = 4 + integer(kind=i_def), parameter :: undf_md = nlayers*ndata*ndf_md + integer(kind=i_def), dimension(ndf_md) :: map_md + + + real(kind=r_def), dimension(undf_w2) :: mass_flux + real(kind=r_def), dimension(undf_w2) :: wind + real(kind=r_def), dimension(undf_md) :: density + + real(kind=r_def) :: answer + real(kind=r_def), parameter :: tol = 1.0e-12_r_def + + integer(kind=i_def) :: k + + map_md(1) = 1 + map_w2(:) = (/1, nlayers+1, 2*nlayers+1, 3*nlayers+1 /) + + ! Set wind + wind(:) = 1.0_r_def + + ! Set density on edges + density(:) = 2.0_r_def + + ! Set flux + mass_flux(:) = 3.0_r_def + + call adj_horizontal_mass_flux_code(nlayers, & + mass_flux, & + wind, & + density, & + ndf_w2, & + undf_w2, & + map_w2, & + ndf_md, & + undf_md, & + map_md ) + + k = 0 + answer = 2.0_r_def + @assertEqual(answer, density(map_md(1) + k)) + answer = 5.0_r_def + @assertEqual(answer, density(map_md(1) + k + nlayers)) + + end subroutine test_all + +end module adj_horizontal_mass_flux_kernel_mod_test diff --git a/science/adjoint/unit-test/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod_test.pf new file mode 100644 index 0000000000..494aba8b69 --- /dev/null +++ b/science/adjoint/unit-test/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod_test.pf @@ -0,0 +1,93 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> Test the vertical mass flux computation +module adj_vertical_mass_flux_kernel_mod_test + + use adj_vertical_mass_flux_kernel_mod, only : adj_vertical_mass_flux_code + use, intrinsic :: iso_fortran_env, only : real64, real32 + use constants_mod, only : i_def, r_def + use funit + + implicit none + + private + public :: test_all + + @TestCase + type, extends(TestCase), public :: adj_vertical_mass_flux_test_type + private + contains + procedure test_all + end type adj_vertical_mass_flux_test_type + +contains + + @test + subroutine test_all( this ) + + implicit none + + class(adj_vertical_mass_flux_test_type), intent(inout) :: this + + real(kind=r_def) :: tol + real(kind=r_def) :: answer + + ! Mesh + integer(kind=i_def), parameter :: nlayers = 2 + + ! Vector Space + integer(kind=i_def), parameter :: ndf_wv = 2_i_def + integer(kind=i_def), parameter :: undf_wv = nlayers + 1 + integer(kind=i_def), dimension(ndf_wv) :: map_wv + real(kind=r_def), dimension(undf_wv) :: wind + real(kind=r_def), dimension(undf_wv) :: mass_flux + + ! Multidata Space + integer(kind=i_def), parameter :: ndf_md = 1_i_def + integer(kind=i_def), parameter :: undf_md = 2_i_def*nlayers + integer(kind=i_def), dimension(ndf_md) :: map_md + real(kind=r_def), dimension(undf_md) :: reconstruction + + integer(kind=i_def) :: k, df + + map_md = (/ 1 /) + map_wv(1) = 1 + map_wv(2) = 2 + + ! Set some values for the initial field + wind(:) = 1.0_r_def + reconstruction(:) = 2.0_r_def + mass_flux(:) = 3.0_r_def + + call adj_vertical_mass_flux_code(nlayers, & + mass_flux, & + wind, & + reconstruction, & + ndf_wv, undf_wv, map_wv, & + ndf_md, undf_md, map_md & + ) + + select case(r_def) + case(real64) + tol = 1.0e-9_r_def + case(real32) + tol = 1.0e-6_r_def + case default + @assertFail("r_def precision not implemented") + end select + + k = 0 + answer = 0.0_r_def + @assertEqual(answer, mass_flux(map_wv(1)+k), tol) + @assertEqual(answer, mass_flux(map_wv(2)+k), tol) + answer = 2.0_r_def + @assertEqual(answer, reconstruction(map_md(1)+k), tol) + answer = 5.0_r_def + @assertEqual(answer, reconstruction(map_md(1)+k+nlayers), tol) + + end subroutine test_all + +end module adj_vertical_mass_flux_kernel_mod_test diff --git a/science/adjoint/unit-test/kernel/transport/mol/adj_w3v_advective_update_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/adj_w3v_advective_update_kernel_mod_test.pf new file mode 100644 index 0000000000..f4353316d3 --- /dev/null +++ b/science/adjoint/unit-test/kernel/transport/mol/adj_w3v_advective_update_kernel_mod_test.pf @@ -0,0 +1,92 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> Test the vertical advective wind update computation +module adj_w3v_advective_update_kernel_mod_test + + use adj_w3v_advective_update_kernel_mod, only : adj_w3v_advective_update_code + use, intrinsic :: iso_fortran_env, only : real64, real32 + use constants_mod, only : i_def, r_def, r_tran + use funit + + implicit none + + private + public :: test_all + + @TestCase + type, extends(TestCase), public :: adj_w3v_advective_update_test_type + private + contains + procedure test_all + end type adj_w3v_advective_update_test_type + +contains + + @test + subroutine test_all( this ) + + implicit none + + class(adj_w3v_advective_update_test_type), intent(inout) :: this + + real(kind=r_tran) :: tol + real(kind=r_tran) :: answer + + ! Mesh + integer(kind=i_def), parameter :: nlayers = 2 + integer(kind=i_def), parameter :: ncell_3d = nlayers + integer(kind=i_def), parameter :: cell = 1 + ! Scalar Space + integer(kind=i_def), parameter :: ndf_ws = 1_i_def + integer(kind=i_def), parameter :: undf_ws = ndf_ws*nlayers + integer(kind=i_def), dimension(ndf_ws) :: map_ws + real(kind=r_tran), dimension(undf_ws) :: advective_update + real(kind=r_def), dimension(ncell_3d, ndf_ws, ndf_ws) :: m3_inv + ! Vector Space + integer(kind=i_def), parameter :: ndf_wv = 2_i_def + integer(kind=i_def), parameter :: undf_wv = nlayers + 1 + integer(kind=i_def), dimension(ndf_wv) :: map_wv + real(kind=r_tran), dimension(undf_wv) :: wind + ! Multidata Space + integer(kind=i_def), parameter :: ndf_md = 1_i_def + integer(kind=i_def), parameter :: undf_md = 4_i_def*nlayers + integer(kind=i_def), dimension(ndf_md) :: map_md + real(kind=r_tran), dimension(undf_md) :: wind_recon + + integer(kind=i_def) :: k, df + + map_ws = (/ 1 /) + map_md = (/ 1 /) + map_wv(1) = 1 + map_wv(2) = 2 + + ! Set some values for the initial field + wind(:) = 1.0_r_def + wind_recon(:) = 2.0_r_def + m3_inv(:,:,:) = 0.1_r_def + advective_update = 3.0_r_tran + + call adj_w3v_advective_update_code(cell, nlayers, & + advective_update, & + wind_recon, & + wind, & + ncell_3d, m3_inv, & + ndf_ws, undf_ws, map_ws, & + ndf_md, undf_md, map_md, & + ndf_wv, undf_wv, map_wv & + ) + + tol = 1.0e-7_r_tran ! precision with 32-bit r_def + + k = 0 + answer = 1.7_r_def + @assertEqual(answer, wind_recon(map_md(1)+k), tol) + answer = 2.0_r_def + @assertEqual(answer, wind_recon(map_md(1)+k+nlayers), tol) + + end subroutine test_all + +end module adj_w3v_advective_update_kernel_mod_test diff --git a/science/adjoint/unit-test/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod_test.pf new file mode 100644 index 0000000000..dc143e55da --- /dev/null +++ b/science/adjoint/unit-test/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod_test.pf @@ -0,0 +1,103 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- + +module atl_horizontal_mass_flux_kernel_mod_test + + use atl_horizontal_mass_flux_kernel_mod, only: atl_horizontal_mass_flux_code + use constants_mod, only: i_def, r_def, l_def + use funit + + implicit none + + private + + public :: atl_horizontal_mass_flux_kernel_test_type, test_all + + @TestCase + type, extends(TestCase) :: atl_horizontal_mass_flux_kernel_test_type + private + contains + procedure test_all + end type atl_horizontal_mass_flux_kernel_test_type + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @Test + subroutine test_all( this ) + + implicit none + + class(atl_horizontal_mass_flux_kernel_test_type), intent(inout) :: this + + integer(kind=i_def), parameter :: nlayers = 1 + integer(kind=i_def), parameter :: ndf_w2 = 4 + integer(kind=i_def), parameter :: undf_w2 = nlayers*ndf_w2 + integer(kind=i_def), dimension(ndf_w2) :: map_w2 + integer(kind=i_def), parameter :: ndf_md = 1 + integer(kind=i_def), parameter :: ndata = 4 + integer(kind=i_def), parameter :: undf_md = nlayers*ndata*ndf_md + integer(kind=i_def), dimension(ndf_md) :: map_md + + + real(kind=r_def), dimension(undf_w2) :: mass_flux + real(kind=r_def), dimension(undf_w2) :: ls_wind + real(kind=r_def), dimension(undf_w2) :: wind + real(kind=r_def), dimension(undf_md) :: density + + real(kind=r_def), parameter :: tol = 1.0e-12_r_def + real(kind=r_def) :: answer + integer(kind=i_def) :: k + + map_md(1) = 1 + map_w2(:) = (/1, nlayers+1, 2*nlayers+1, 3*nlayers+1 /) + + ! Set wind + do k = 0, nlayers - 1 + ls_wind(map_w2(1)+k) = 1.0_r_def + ls_wind(map_w2(2)+k) = 1.0_r_def + ls_wind(map_w2(3)+k) = -1.0_r_def + ls_wind(map_w2(4)+k) = -1.0_r_def + end do + wind = -0.5_r_def*ls_wind + + ! Set density on edges + do k = 0, nlayers - 1 + density(map_md(1) + k ) = 1.0_r_def + density(map_md(1) + k + nlayers ) = 2.0_r_def + density(map_md(1) + k + 2*nlayers ) = 3.0_r_def + density(map_md(1) + k + 3*nlayers ) = 4.0_r_def + end do + + ! Set default flux + mass_flux(:) = 5.0_r_def + + + call atl_horizontal_mass_flux_code(nlayers, & + mass_flux, & + ls_wind, & + wind, & + density, & + ndf_w2, & + undf_w2, & + map_w2, & + ndf_md, & + undf_md, & + map_md ) + + k = 0 + answer = -0.5_r_def + @assertEqual(answer, wind(map_w2(1)+k)) + answer = 9.5_r_def + @assertEqual(answer, wind(map_w2(2)+k)) + answer = 0.5_r_def + @assertEqual(answer, wind(map_w2(3)+k)) + answer = 20.5_r_def + @assertEqual(answer, wind(map_w2(4)+k)) + + end subroutine test_all + +end module atl_horizontal_mass_flux_kernel_mod_test diff --git a/science/adjoint/unit-test/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod_test.pf new file mode 100644 index 0000000000..400f09ec99 --- /dev/null +++ b/science/adjoint/unit-test/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod_test.pf @@ -0,0 +1,243 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- + +!>@brief Test the TL vertical advective computation using 1d polynomials +module atl_poly1d_vert_adv_kernel_mod_test + + use atl_poly1d_vert_adv_kernel_mod, only: atl_poly1d_vert_adv_code + use constants_mod, only : i_def, r_def, l_def, EPS + use funit + use, intrinsic :: iso_fortran_env, only: real64 + + + implicit none + + private + public :: test_standard, & + test_logspace + + @TestCase + type, extends(TestCase), public :: atl_poly1d_vert_adv_test_type + private + + real(r_def) :: answer, use_tol + + integer(i_def), allocatable :: map_w2v(:) + integer(i_def), allocatable :: map_wt(:) + integer(i_def), allocatable :: map_c(:) + + real(r_def), allocatable :: flux(:) + real(r_def), allocatable :: wind(:) + real(r_def), allocatable :: density(:) + real(r_def), allocatable :: ls_wind(:) + real(r_def), allocatable :: ls_density(:) + real(r_def), allocatable :: coeff(:) + + contains + procedure setUp + procedure tearDown + procedure test_standard + procedure test_logspace + + end type atl_poly1d_vert_adv_test_type + + real(r_def), parameter :: tol = 1.0e-12_r_def ! r_def 64bit + integer(i_def), parameter :: nfaces_v = 2 + integer(i_def), parameter :: nlayers = 6 + integer(i_def), parameter :: mol_order = 3 + integer(i_def), parameter :: ndata = (mol_order+1)*nfaces_v + integer(i_def), parameter :: ndf_w2v = 2 + integer(i_def), parameter :: ndf_wt = 2 + integer(i_def), parameter :: ndf_c = 2 + integer(i_def), parameter :: undf_w2v = nlayers+1 + integer(i_def), parameter :: undf_wt = nlayers+1 + integer(i_def), parameter :: undf_c = ndata*(nlayers+1) + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine setUp( this ) + + implicit none + + class(atl_poly1d_vert_adv_test_type), intent(inout) :: this + + integer(i_def) :: k, f + + allocate(this%map_w2v(ndf_w2v)) + allocate(this%map_wt(ndf_wt)) + allocate(this%map_c(ndf_c)) + allocate(this%flux(undf_wt)) + allocate(this%wind(undf_w2v)) + allocate(this%density(undf_wt)) + allocate(this%ls_wind(undf_w2v)) + allocate(this%ls_density(undf_wt)) + allocate(this%coeff(undf_c)) + + this%map_wt(:) = (/ 1, 2 /) + this%map_w2v(:) = (/ 1, 2 /) + this%map_c(:) = (/ 1, 1 + ndata /) + + do k = 0, nlayers + do f = 1, nfaces_v + this%coeff(0 + (f-1)*(mol_order+1) + k*ndata + this%map_c(1)) = -2.0_r_def/6.0_r_def + this%coeff(1 + (f-1)*(mol_order+1) + k*ndata + this%map_c(1)) = -3.0_r_def/6.0_r_def + this%coeff(2 + (f-1)*(mol_order+1) + k*ndata + this%map_c(1)) = 6.0_r_def/6.0_r_def + this%coeff(3 + (f-1)*(mol_order+1) + k*ndata + this%map_c(1)) = -1.0_r_def/6.0_r_def + end do + end do + + end subroutine setUp + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine tearDown( this ) + + use config_loader_mod, only: final_configuration + + implicit none + + class(atl_poly1d_vert_adv_test_type), intent(inout) :: this + + deallocate(this%map_w2v) + deallocate(this%map_wt) + deallocate(this%map_c) + deallocate(this%flux) + deallocate(this%wind) + deallocate(this%density) + deallocate(this%ls_wind) + deallocate(this%ls_density) + deallocate(this%coeff) + + call final_configuration() + + end subroutine tearDown + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @Test + subroutine test_standard( this ) + + implicit none + + class(atl_poly1d_vert_adv_test_type), intent(inout) :: this + + integer(i_def) :: k + logical(l_def) :: logspace + + ! Test standard polynomial interpolation + + this%flux = 2.0_r_def + + this%wind(:) = 1.0_r_def + this%ls_wind(:) = 1.0_r_def + + do k = 1,nlayers+1 + this%density(k) = real(k,r_def) + this%ls_density(k) = real(k,r_def) + end do + + logspace = .false. + + call atl_poly1d_vert_adv_code( nlayers, & + this%flux, & + this%wind, & + this%density, & + this%ls_wind, & + this%ls_density, & + this%coeff, & + ndata, & + mol_order, & + logspace, & + ndf_wt, & + undf_wt, & + this%map_wt, & + ndf_w2v, & + undf_w2v, & + this%map_w2v, & + ndf_c, & + undf_c, & + this%map_c) + if ( r_def == real64 ) then + this%use_tol = tol + else + this%use_tol = 10.0_r_def*spacing( maxval( this%flux(this%map_wt(1)+2:this%map_wt(1)+4) ) ) + end if + this%answer = 3.0_r_def + @assertEqual(this%answer, this%wind(this%map_w2v(1)+2), this%use_tol) + @assertEqual(this%answer, this%wind(this%map_w2v(1)+3), this%use_tol) + @assertEqual(this%answer, this%wind(this%map_w2v(1)+4), this%use_tol) + this%answer = 5.3333333333333339_r_def + @assertEqual(this%answer, this%density(this%map_wt(1)+2), this%use_tol) + this%answer = 3.6666666666666674_r_def + @assertEqual(this%answer, this%density(this%map_wt(1)+3), this%use_tol) + this%answer = 5.6666666666666670_r_def + @assertEqual(this%answer, this%density(this%map_wt(1)+4), this%use_tol) + + end subroutine test_standard + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + @Test + subroutine test_logspace( this ) + + implicit none + + class(atl_poly1d_vert_adv_test_type), intent(inout) :: this + + integer(i_def) :: k + logical(l_def) :: logspace + + ! Test polynomial interpolation in log-space + + this%flux = 2.0_r_def + + this%wind(:) = 1.0_r_def + this%ls_wind(:) = 1.0_r_def + + do k = 1,nlayers+1 + this%density(k) = exp(-real(k,r_def)) + this%ls_density(k) = exp(-real(k,r_def)) + end do + + logspace = .true. + + call atl_poly1d_vert_adv_code( nlayers, & + this%flux, & + this%wind, & + this%density, & + this%ls_wind, & + this%ls_density, & + this%coeff, & + ndata, & + mol_order, & + logspace, & + ndf_wt, & + undf_wt, & + this%map_wt, & + ndf_w2v, & + undf_w2v, & + this%map_w2v, & + ndf_c, & + undf_c, & + this%map_c) + + if ( r_def == real64 ) then + this%use_tol = tol + else + this%use_tol = 10.0_r_def*spacing( maxval( this%flux(this%map_wt(1)+2:this%map_wt(1)+3) ) ) + end if + + k = 2 + this%answer = 0.90042586326427210_r_def + @assertEqual(this%answer, this%wind(this%map_w2v(1)+k), this%use_tol) + @assertEqual(this%answer, this%wind(this%map_w2v(1)+k), this%use_tol) + k = 3 + this%answer = -3.8088999669036823_r_def + @assertEqual(this%answer, this%density(this%map_wt(1)+k), this%use_tol) + @assertEqual(this%answer, this%density(this%map_wt(1)+k), this%use_tol) + + end subroutine test_logspace + +end module atl_poly1d_vert_adv_kernel_mod_test diff --git a/science/adjoint/unit-test/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod_test.pf new file mode 100644 index 0000000000..c6d3fb3bb4 --- /dev/null +++ b/science/adjoint/unit-test/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod_test.pf @@ -0,0 +1,98 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> Test the vertical mass flux computation +module atl_vertical_mass_flux_kernel_mod_test + + use atl_vertical_mass_flux_kernel_mod, only : atl_vertical_mass_flux_code + use, intrinsic :: iso_fortran_env, only : real64, real32 + use constants_mod, only : i_def, r_def + use funit + + implicit none + + private + public :: test_all + + @TestCase + type, extends(TestCase), public :: atl_vertical_mass_flux_test_type + private + contains + procedure test_all + end type atl_vertical_mass_flux_test_type + +contains + + @test + subroutine test_all( this ) + + implicit none + + class(atl_vertical_mass_flux_test_type), intent(inout) :: this + + real(kind=r_def) :: tol + real(kind=r_def) :: answer + + ! Mesh + integer(kind=i_def), parameter :: nlayers = 2 + + ! Vector Space + integer(kind=i_def), parameter :: ndf_wv = 2_i_def + integer(kind=i_def), parameter :: undf_wv = nlayers + 1 + integer(kind=i_def), dimension(ndf_wv) :: map_wv + real(kind=r_def), dimension(undf_wv) :: ls_wind + real(kind=r_def), dimension(undf_wv) :: wind + real(kind=r_def), dimension(undf_wv) :: mass_flux + + ! Multidata Space + integer(kind=i_def), parameter :: ndf_md = 1_i_def + integer(kind=i_def), parameter :: undf_md = 2_i_def*nlayers + integer(kind=i_def), dimension(ndf_md) :: map_md + real(kind=r_def), dimension(undf_md) :: reconstruction + + integer(kind=i_def) :: k, df + + map_md = (/ 1 /) + map_wv(1) = 1 + map_wv(2) = 2 + + ! Set some values for the initial field + ls_wind(:) = 10.0_r_def + reconstruction(:) = 21.0_r_def + + wind = -0.5_r_def*ls_wind + + mass_flux = 1.0_r_def + + call atl_vertical_mass_flux_code(nlayers, & + mass_flux, & + ls_wind, & + wind, & + reconstruction, & + ndf_wv, undf_wv, map_wv, & + ndf_md, undf_md, map_md & + ) + + select case(r_def) + case(real64) + tol = 1.0e-9_r_def + case(real32) + tol = 1.0e-6_r_def + case default + @assertFail("r_def precision not implemented") + end select + + k = 0 + answer = 0.0_r_def + @assertEqual(answer, mass_flux(map_wv(1)+k), tol) + @assertEqual(answer, mass_flux(map_wv(2)+k), tol) + answer = -5.0_r_def + @assertEqual(answer, wind(map_wv(1)+k), tol) + answer = 16.0_r_def + @assertEqual(answer, wind(map_wv(2)+k), tol) + + end subroutine test_all + +end module atl_vertical_mass_flux_kernel_mod_test diff --git a/science/adjoint/unit-test/kernel/transport/mol/atl_w3v_advective_update_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/atl_w3v_advective_update_kernel_mod_test.pf new file mode 100644 index 0000000000..16129652b5 --- /dev/null +++ b/science/adjoint/unit-test/kernel/transport/mol/atl_w3v_advective_update_kernel_mod_test.pf @@ -0,0 +1,101 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright Met Office. All rights reserved. +! The file LICENCE, distributed with this code, contains details of the terms +! under which the code may be used. +!----------------------------------------------------------------------------- +!> Test the vertical advective wind update computation +module atl_w3v_advective_update_kernel_mod_test + + use atl_w3v_advective_update_kernel_mod, only : atl_w3v_advective_update_code + use, intrinsic :: iso_fortran_env, only : real64, real32 + use constants_mod, only : i_def, r_def + use funit + + implicit none + + private + public :: test_all + + @TestCase + type, extends(TestCase), public :: atl_w3v_advective_update_test_type + private + contains + procedure test_all + end type atl_w3v_advective_update_test_type + +contains + + @test + subroutine test_all( this ) + + implicit none + + class(atl_w3v_advective_update_test_type), intent(inout) :: this + + real(kind=r_def) :: tol + real(kind=r_def) :: answer + + ! Mesh + integer(kind=i_def), parameter :: nlayers = 2 + integer(kind=i_def), parameter :: ncell_3d = nlayers + integer(kind=i_def), parameter :: cell = 1 + ! Scalar Space + integer(kind=i_def), parameter :: ndf_ws = 1_i_def + integer(kind=i_def), parameter :: undf_ws = ndf_ws*nlayers + integer(kind=i_def), dimension(ndf_ws) :: map_ws + real(kind=r_def), dimension(undf_ws) :: advective_update + real(kind=r_def), dimension(ndf_ws, ndf_ws, ncell_3d) :: m3_inv + ! Vector Space + integer(kind=i_def), parameter :: ndf_wv = 2_i_def + integer(kind=i_def), parameter :: undf_wv = nlayers + 1 + integer(kind=i_def), dimension(ndf_wv) :: map_wv + real(kind=r_def), dimension(undf_wv) :: ls_wind + real(kind=r_def), dimension(undf_wv) :: wind + ! Multidata Space + integer(kind=i_def), parameter :: ndf_md = 1_i_def + integer(kind=i_def), parameter :: undf_md = 4_i_def*nlayers + integer(kind=i_def), dimension(ndf_md) :: map_md + real(kind=r_def), dimension(undf_md) :: wind_recon + + integer(kind=i_def) :: k, df + + map_ws = (/ 1 /) + map_md = (/ 1 /) + map_wv(1) = 1 + map_wv(2) = 2 + + ! Set some values for the initial field + ls_wind(:) = 10.0_r_def + wind_recon(:) = 21.0_r_def + wind = -0.5_r_def*ls_wind + + m3_inv(:,:,:) = 0.1_r_def + advective_update = 1.0_r_def + + call atl_w3v_advective_update_code(cell, nlayers, & + advective_update, & + wind_recon, & + ls_wind, & + wind, & + ncell_3d, m3_inv, & + ndf_ws, undf_ws, map_ws, & + ndf_md, undf_md, map_md, & + ndf_wv, undf_wv, map_wv & + ) + + select case(r_def) + case(real64) + tol = 1.0e-9_r_def + case(real32) + tol = 1.0e-6_r_def + case default + @assertFail("r_def precision not implemented") + end select + + k = 0 + answer = -5.0_r_def + @assertEqual(answer, wind(map_wv(1)+k), tol) + + end subroutine test_all + +end module atl_w3v_advective_update_kernel_mod_test From 0e6019cc5addcd9a9a0df6cd3dea1e849862509c Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Thu, 3 Sep 2026 11:49:19 +0100 Subject: [PATCH 20/22] Updated test docstrings --- .../transport/mol/adj_horizontal_mass_flux_kernel_mod_test.pf | 2 +- .../transport/mol/adj_vertical_mass_flux_kernel_mod_test.pf | 2 +- .../transport/mol/adj_w3v_advective_update_kernel_mod_test.pf | 2 +- .../transport/mol/atl_horizontal_mass_flux_kernel_mod_test.pf | 2 +- .../kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod_test.pf | 2 +- .../transport/mol/atl_vertical_mass_flux_kernel_mod_test.pf | 2 +- .../transport/mol/atl_w3v_advective_update_kernel_mod_test.pf | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/science/adjoint/unit-test/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod_test.pf index d37c880ce0..a63751172e 100644 --- a/science/adjoint/unit-test/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod_test.pf +++ b/science/adjoint/unit-test/kernel/transport/mol/adj_horizontal_mass_flux_kernel_mod_test.pf @@ -3,7 +3,7 @@ ! The file LICENCE, distributed with this code, contains details of the terms ! under which the code may be used. !----------------------------------------------------------------------------- - +!> Test file for the adjoint horizontal mass flux computation module adj_horizontal_mass_flux_kernel_mod_test use adj_horizontal_mass_flux_kernel_mod, only: adj_horizontal_mass_flux_code diff --git a/science/adjoint/unit-test/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod_test.pf index 494aba8b69..5061c34c77 100644 --- a/science/adjoint/unit-test/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod_test.pf +++ b/science/adjoint/unit-test/kernel/transport/mol/adj_vertical_mass_flux_kernel_mod_test.pf @@ -3,7 +3,7 @@ ! The file LICENCE, distributed with this code, contains details of the terms ! under which the code may be used. !----------------------------------------------------------------------------- -!> Test the vertical mass flux computation +!> Test file for the adjoint vertical mass flux computation module adj_vertical_mass_flux_kernel_mod_test use adj_vertical_mass_flux_kernel_mod, only : adj_vertical_mass_flux_code diff --git a/science/adjoint/unit-test/kernel/transport/mol/adj_w3v_advective_update_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/adj_w3v_advective_update_kernel_mod_test.pf index f4353316d3..e8efaee5b9 100644 --- a/science/adjoint/unit-test/kernel/transport/mol/adj_w3v_advective_update_kernel_mod_test.pf +++ b/science/adjoint/unit-test/kernel/transport/mol/adj_w3v_advective_update_kernel_mod_test.pf @@ -3,7 +3,7 @@ ! The file LICENCE, distributed with this code, contains details of the terms ! under which the code may be used. !----------------------------------------------------------------------------- -!> Test the vertical advective wind update computation +!> Test file for the adjoint vertical advective wind update computation module adj_w3v_advective_update_kernel_mod_test use adj_w3v_advective_update_kernel_mod, only : adj_w3v_advective_update_code diff --git a/science/adjoint/unit-test/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod_test.pf index dc143e55da..0f6ec54f7d 100644 --- a/science/adjoint/unit-test/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod_test.pf +++ b/science/adjoint/unit-test/kernel/transport/mol/atl_horizontal_mass_flux_kernel_mod_test.pf @@ -3,7 +3,7 @@ ! The file LICENCE, distributed with this code, contains details of the terms ! under which the code may be used. !----------------------------------------------------------------------------- - +!> Test file for the adjoint of TL horizontal mass flux computation module atl_horizontal_mass_flux_kernel_mod_test use atl_horizontal_mass_flux_kernel_mod, only: atl_horizontal_mass_flux_code diff --git a/science/adjoint/unit-test/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod_test.pf index 400f09ec99..be83baaf89 100644 --- a/science/adjoint/unit-test/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod_test.pf +++ b/science/adjoint/unit-test/kernel/transport/mol/atl_poly1d_vert_adv_kernel_mod_test.pf @@ -4,7 +4,7 @@ ! under which the code may be used. !----------------------------------------------------------------------------- -!>@brief Test the TL vertical advective computation using 1d polynomials +!>@brief Test file for the adjoint of TL vertical advective computation using 1d polynomials module atl_poly1d_vert_adv_kernel_mod_test use atl_poly1d_vert_adv_kernel_mod, only: atl_poly1d_vert_adv_code diff --git a/science/adjoint/unit-test/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod_test.pf index c6d3fb3bb4..28d9c783c6 100644 --- a/science/adjoint/unit-test/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod_test.pf +++ b/science/adjoint/unit-test/kernel/transport/mol/atl_vertical_mass_flux_kernel_mod_test.pf @@ -3,7 +3,7 @@ ! The file LICENCE, distributed with this code, contains details of the terms ! under which the code may be used. !----------------------------------------------------------------------------- -!> Test the vertical mass flux computation +!> Test file for the adjoint of TL vertical mass flux computation module atl_vertical_mass_flux_kernel_mod_test use atl_vertical_mass_flux_kernel_mod, only : atl_vertical_mass_flux_code diff --git a/science/adjoint/unit-test/kernel/transport/mol/atl_w3v_advective_update_kernel_mod_test.pf b/science/adjoint/unit-test/kernel/transport/mol/atl_w3v_advective_update_kernel_mod_test.pf index 16129652b5..30c7f12a1b 100644 --- a/science/adjoint/unit-test/kernel/transport/mol/atl_w3v_advective_update_kernel_mod_test.pf +++ b/science/adjoint/unit-test/kernel/transport/mol/atl_w3v_advective_update_kernel_mod_test.pf @@ -3,7 +3,7 @@ ! The file LICENCE, distributed with this code, contains details of the terms ! under which the code may be used. !----------------------------------------------------------------------------- -!> Test the vertical advective wind update computation +!> Test file for the adjoint of TL vertical advective wind update computation module atl_w3v_advective_update_kernel_mod_test use atl_w3v_advective_update_kernel_mod, only : atl_w3v_advective_update_code From 76ab1e1f1b6f4d4c5a0b4e0f746f0f1adca605ca Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Thu, 3 Sep 2026 11:57:20 +0100 Subject: [PATCH 21/22] Fixed typo --- science/adjoint/fortitude.toml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/science/adjoint/fortitude.toml b/science/adjoint/fortitude.toml index 80ee5d3b58..73363781ec 100644 --- a/science/adjoint/fortitude.toml +++ b/science/adjoint/fortitude.toml @@ -27,7 +27,7 @@ output-format = "grouped" #group results by file "adj_vertical_mass_flux_kernel_mod_test.pf" = ["E001", "C121"] "adj_w3v_advective_update_kernel_mod_test.pf" = ["E001", "C121"] "atl_horizontal_mass_flux_kernel_mod_test.pf" = ["E001", "C121"] -"atl_poly1d_vert_adv_kernel_mod._testpf" = ["E001", "C121"] +"atl_poly1d_vert_adv_kernel_mod._test.pf" = ["E001", "C121"] "atl_vertical_mass_flux_kernel_mod_test.pf" = ["E001", "C121"] "atl_w3v_advective_update_kernel_mod_test.pf" = ["E001", "C121"] "adj_mixed_operator_alg_mod.x90" = ["C061"] From e7c53a109d882b68e48fb8bcf58eb0c4a5210106 Mon Sep 17 00:00:00 2001 From: DrTVockerodtMO <114994380+DrTVockerodtMO@users.noreply.github.com> Date: Thu, 3 Sep 2026 11:58:44 +0100 Subject: [PATCH 22/22] And again... --- science/adjoint/fortitude.toml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/science/adjoint/fortitude.toml b/science/adjoint/fortitude.toml index 73363781ec..ff07902799 100644 --- a/science/adjoint/fortitude.toml +++ b/science/adjoint/fortitude.toml @@ -27,7 +27,7 @@ output-format = "grouped" #group results by file "adj_vertical_mass_flux_kernel_mod_test.pf" = ["E001", "C121"] "adj_w3v_advective_update_kernel_mod_test.pf" = ["E001", "C121"] "atl_horizontal_mass_flux_kernel_mod_test.pf" = ["E001", "C121"] -"atl_poly1d_vert_adv_kernel_mod._test.pf" = ["E001", "C121"] +"atl_poly1d_vert_adv_kernel_mod_test.pf" = ["E001", "C121"] "atl_vertical_mass_flux_kernel_mod_test.pf" = ["E001", "C121"] "atl_w3v_advective_update_kernel_mod_test.pf" = ["E001", "C121"] "adj_mixed_operator_alg_mod.x90" = ["C061"]