From e9bdaf4a66eca13d9a823556e6c9d1df7c338717 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Tue, 17 Mar 2026 10:14:48 +0000 Subject: [PATCH 01/44] Progress save --- applications/coupled/source/coupled.f90 | 2 +- .../source/driver/coupled_driver_mod.f90 | 2 +- .../source/driver/io_demo_driver_mod.f90 | 2 +- applications/io_demo/source/io_demo.f90 | 2 +- .../source/driver/lbc_demo_driver_mod.f90 | 2 +- applications/lbc_demo/source/lbc_demo.f90 | 2 +- .../driver/simple_diffusion_driver_mod.f90 | 2 +- .../source/simple_diffusion.f90 | 2 +- .../source/driver/skeleton_driver_mod.f90 | 2 +- applications/skeleton/source/skeleton.f90 | 2 +- .../driver/source/driver_coordinates_mod.F90 | 196 +++++++++++------- .../driver/source/driver_counter_mod.f90 | 31 ++- components/driver/source/driver_fem_mod.f90 | 39 ++-- components/driver/source/driver_log_mod.f90 | 34 +-- components/driver/source/driver_mesh_mod.f90 | 26 ++- .../driver/source/driver_modeldb_mod.f90 | 2 +- .../driver/source/mesh/create_mesh_mod.f90 | 111 ++++++---- .../assign_coordinate_alphabetaz_mod_test.pf | 53 +---- .../assign_coordinate_lonlatz_mod_test.pf | 80 ++----- .../assign_coordinate_xyz_mod_test.pf | 56 +---- .../unit-test/mesh/create_mesh_mod_test.pf | 42 ++-- .../kernel/geometry/sci_chi_transform_mod.F90 | 112 +++++++--- components/science/source/temp | 48 +++++ 23 files changed, 490 insertions(+), 360 deletions(-) create mode 100644 components/science/source/temp diff --git a/applications/coupled/source/coupled.f90 b/applications/coupled/source/coupled.f90 index a74455853..6d1b058ec 100644 --- a/applications/coupled/source/coupled.f90 +++ b/applications/coupled/source/coupled.f90 @@ -50,7 +50,7 @@ program coupled call init_config( filename, coupled_required_namelists, & config=modeldb%config ) - call init_logger( modeldb%mpi%get_comm(), & + call init_logger( modeldb, & program_name//"_"//cpl_component_name ) write(log_scratch_space,'(A)') & diff --git a/applications/coupled/source/driver/coupled_driver_mod.f90 b/applications/coupled/source/driver/coupled_driver_mod.f90 index 25799a019..4a82c3679 100644 --- a/applications/coupled/source/driver/coupled_driver_mod.f90 +++ b/applications/coupled/source/driver/coupled_driver_mod.f90 @@ -136,7 +136,7 @@ subroutine initialise( program_name, modeldb, calendar ) ! Build the FEM function spaces and coordinate fields - call init_fem( mesh_collection, chi_inventory, panel_id_inventory ) + call init_fem( modeldb, chi_inventory, panel_id_inventory ) ! Create and initialise prognostic fields mesh => mesh_collection%get_mesh(prime_mesh_name) diff --git a/applications/io_demo/source/driver/io_demo_driver_mod.f90 b/applications/io_demo/source/driver/io_demo_driver_mod.f90 index 2a9ebe515..c68622381 100644 --- a/applications/io_demo/source/driver/io_demo_driver_mod.f90 +++ b/applications/io_demo/source/driver/io_demo_driver_mod.f90 @@ -176,7 +176,7 @@ subroutine initialise(program_name, modeldb) !======================================================================= ! Build the FEM function spaces and coordinate fields !======================================================================= - call init_fem( mesh_collection, chi_inventory, panel_id_inventory ) + call init_fem( modeldb, chi_inventory, panel_id_inventory ) !======================================================================= ! Setup multifile reading diff --git a/applications/io_demo/source/io_demo.f90 b/applications/io_demo/source/io_demo.f90 index 4a5c69e73..3c288e4c8 100644 --- a/applications/io_demo/source/io_demo.f90 +++ b/applications/io_demo/source/io_demo.f90 @@ -60,7 +60,7 @@ program io_demo deallocate( filename ) - call init_logger(modeldb%mpi%get_comm(), program_name) + call init_logger(modeldb, program_name) subroutine_timers = modeldb%config%io%subroutine_timers() timer_output_path = modeldb%config%io%timer_output_path() diff --git a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 index ce9a4a29d..6016b5508 100644 --- a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 +++ b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 @@ -205,7 +205,7 @@ subroutine initialise( program_name, modeldb) !======================================================================= ! Build the FEM function spaces and coordinate fields !======================================================================= - call init_fem( mesh_collection, chi_inventory, panel_id_inventory ) + call init_fem( modeldb, chi_inventory, panel_id_inventory ) !======================================================================= ! Setup general I/O system. diff --git a/applications/lbc_demo/source/lbc_demo.f90 b/applications/lbc_demo/source/lbc_demo.f90 index 1500ada59..898892bd8 100644 --- a/applications/lbc_demo/source/lbc_demo.f90 +++ b/applications/lbc_demo/source/lbc_demo.f90 @@ -45,7 +45,7 @@ program lbc_demo call init_config(filename, required_namelists, & config=modeldb%config) - call init_logger( modeldb%mpi%get_comm(), program_name ) + call init_logger( modeldb, program_name ) ! Before anything else, test that the mesh provided was a regional domain. ! This application is not intended for cubed-sphere meshes. diff --git a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 index 8a5506f3b..c73ffb310 100644 --- a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 +++ b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 @@ -166,7 +166,7 @@ subroutine initialise( program_name, modeldb) !======================================================================= ! 2.0 Build the FEM function spaces and coordinate fields !======================================================================= - call init_fem( mesh_collection, chi_inventory, panel_id_inventory ) + call init_fem( modeldb, chi_inventory, panel_id_inventory ) !======================================================================= diff --git a/applications/simple_diffusion/source/simple_diffusion.f90 b/applications/simple_diffusion/source/simple_diffusion.f90 index b990fe6cf..bb984d20d 100644 --- a/applications/simple_diffusion/source/simple_diffusion.f90 +++ b/applications/simple_diffusion/source/simple_diffusion.f90 @@ -45,7 +45,7 @@ program simple_diffusion simple_diffusion_required_namelists, & config=modeldb%config ) - call init_logger( modeldb%mpi%get_comm(), program_name ) + call init_logger( modeldb, program_name ) write(log_scratch_space,& '("Application built with ", A, "-bit real numbers")') & diff --git a/applications/skeleton/source/driver/skeleton_driver_mod.f90 b/applications/skeleton/source/driver/skeleton_driver_mod.f90 index 7639444dd..2cd538829 100644 --- a/applications/skeleton/source/driver/skeleton_driver_mod.f90 +++ b/applications/skeleton/source/driver/skeleton_driver_mod.f90 @@ -160,7 +160,7 @@ subroutine initialise(program_name, modeldb) ! Build the FEM function spaces and coordinate fields !======================================================================= ! Create FEM specifics (function spaces and chi field) - call init_fem(mesh_collection, chi_inventory, panel_id_inventory) + call init_fem(modeldb, chi_inventory, panel_id_inventory) !======================================================================= ! Create and initialise prognostic fields diff --git a/applications/skeleton/source/skeleton.f90 b/applications/skeleton/source/skeleton.f90 index cd35a0ee8..57002571a 100644 --- a/applications/skeleton/source/skeleton.f90 +++ b/applications/skeleton/source/skeleton.f90 @@ -45,7 +45,7 @@ program skeleton call init_config( filename, skeleton_required_namelists, & config=modeldb%config ) - call init_logger( modeldb%mpi%get_comm(), program_name ) + call init_logger( modeldb, program_name ) write(log_scratch_space,'(A)') & 'Application built with '// trim(precision_real) // & diff --git a/components/driver/source/driver_coordinates_mod.F90 b/components/driver/source/driver_coordinates_mod.F90 index 686b196f2..092c997a9 100644 --- a/components/driver/source/driver_coordinates_mod.F90 +++ b/components/driver/source/driver_coordinates_mod.F90 @@ -7,24 +7,23 @@ !> @brief Module to assign the values of the coordinates of the mesh to a field. module driver_coordinates_mod - use base_mesh_config_mod, only: geometry, & - geometry_planar, & - geometry_spherical, & - topology, & - topology_fully_periodic, & - topology_non_periodic - use constants_mod, only: r_def, i_def, l_def, & - radians_to_degrees, & - i_halo_index, eps, pi - use log_mod, only: log_event, log_scratch_space, & - log_level_error - use planet_config_mod, only: scaled_radius - use coord_transform_mod, only: xyz2llr, llr2xyz, identify_panel, & - xyz2alphabetar, alphabetar2xyz, & - schmidt_transform_xyz, & - inverse_schmidt_transform_xyz - use finite_element_config_mod, only: coord_system, & - coord_system_xyz + use constants_mod, only: r_def, i_def, l_def, & + radians_to_degrees, & + i_halo_index, eps, pi + use driver_modeldb_mod, only: modeldb_type + use log_mod, only: log_event, log_scratch_space, & + log_level_error + use coord_transform_mod, only: xyz2llr, llr2xyz, identify_panel, & + xyz2alphabetar, alphabetar2xyz, & + schmidt_transform_xyz, & + inverse_schmidt_transform_xyz + + ! Configuration modules + use base_mesh_config_mod, only: geometry_planar, & + geometry_spherical, & + topology_fully_periodic, & + topology_non_periodic + use finite_element_config_mod, only: coord_system_xyz implicit none @@ -53,10 +52,11 @@ module driver_coordinates_mod !! from the mesh generator and then 'assign_coordinate' on a column by !! column basis. !> + !> @param[in] modeldb Model state object !> @param[in,out] chi Model coordinate array of size 3 of fields !> @param[in] panel_id Field giving the ID of mesh panels !> @param[in] mesh Mesh on which this field is attached - subroutine assign_coordinate_field(chi, panel_id, mesh) + subroutine assign_coordinate_field(modeldb, chi, panel_id, mesh) use domain_mod, only: domain_type use field_mod, only: field_type, field_proxy_type @@ -69,14 +69,16 @@ subroutine assign_coordinate_field(chi, panel_id, mesh) implicit none + type(modeldb_type), intent(in) :: modeldb + type( field_type ), intent( inout ) :: chi(3) type( field_type ), intent( inout ) :: panel_id type( mesh_type ), intent( in ), pointer :: mesh - integer(i_def), pointer :: map(:,:) => null() - integer(i_def), pointer :: map_pid(:,:) => null() - real(kind=r_def), pointer :: dof_coords(:,:) => null() - class(reference_element_type), pointer :: reference_element => null() + integer(i_def), pointer :: map(:,:) + integer(i_def), pointer :: map_pid(:,:) + real(kind=r_def), pointer :: dof_coords(:,:) + class(reference_element_type), pointer :: reference_element type(field_proxy_type) :: chi_proxy(3) type(field_proxy_type) :: panel_id_proxy @@ -106,6 +108,18 @@ subroutine assign_coordinate_field(chi, panel_id, mesh) real(kind=r_def) :: inverse_rot_matrix(3,3) real(kind=r_def) :: stretch_factor + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() + coord_system = modeldb%config%finite_element%coord_system() + scaled_radius = modeldb%config%planet%scaled_radius() + + nullify( map, map_pid, dof_coords, reference_element ) + ! Break encapsulation and get the proxy. chi_proxy(1) = chi(1)%get_proxy() chi_proxy(2) = chi(2)%get_proxy() @@ -176,12 +190,14 @@ subroutine assign_coordinate_field(chi, panel_id, mesh) do cell = 1,chi_proxy(1)%vspace%get_ncell() - call calc_panel_id( nlayers_pid, & - ndf_pid, undf_pid, & - map_pid(:,cell), & - panel_id_proxy%data, & - global_dof_id, & - panel_ncells ) + call calc_panel_id( nlayers_pid, & + ndf_pid, undf_pid, & + map_pid(:,cell), & + panel_id_proxy%data, & + geometry, & + topology, & + global_dof_id, & + panel_ncells ) call mesh%get_column_coords(cell,column_coords) @@ -200,6 +216,9 @@ subroutine assign_coordinate_field(chi, panel_id, mesh) domain_max_x, & domain_min_y, & panel_id_proxy%data, & + geometry, & + topology, & + scaled_radius, & ndf_pid, & undf_pid, & map_pid(:,cell) ) @@ -210,32 +229,34 @@ subroutine assign_coordinate_field(chi, panel_id, mesh) do cell = 1,chi_proxy(1)%vspace%get_ncell() - call calc_panel_id( nlayers_pid, & - ndf_pid, undf_pid, & - map_pid(:,cell), & - panel_id_proxy%data, & - global_dof_id, & - panel_ncells ) + call calc_panel_id( nlayers_pid, & + ndf_pid, undf_pid, & + map_pid(:,cell), & + panel_id_proxy%data, & + geometry, topology, & + global_dof_id, & + panel_ncells ) call mesh%get_column_coords(cell,column_coords) - call assign_coordinate_lonlatz( nlayers, & - ndf, & - nverts, & - undf, & - map(:,cell), & - chi_proxy(1)%data, & - chi_proxy(2)%data, & - chi_proxy(3)%data, & - column_coords, & - dof_coords, & - vertex_coords, & - to_rotate, & - inverse_rot_matrix, & - panel_id_proxy%data, & - ndf_pid, & - undf_pid, & - map_pid(:,cell) ) + call assign_coordinate_lonlatz( nlayers, & + ndf, & + nverts, & + undf, & + map(:,cell), & + chi_proxy(1)%data, & + chi_proxy(2)%data, & + chi_proxy(3)%data, & + column_coords, & + dof_coords, & + vertex_coords, & + to_rotate, & + inverse_rot_matrix, & + panel_id_proxy%data, & + scaled_radius, & + ndf_pid, & + undf_pid, & + map_pid(:,cell) ) end do else if ( geometry == geometry_spherical .and. & @@ -243,33 +264,35 @@ subroutine assign_coordinate_field(chi, panel_id, mesh) do cell = 1,chi_proxy(1)%vspace%get_ncell() - call calc_panel_id( nlayers_pid, & - ndf_pid, undf_pid, & - map_pid(:,cell), & - panel_id_proxy%data, & - global_dof_id, & - panel_ncells ) + call calc_panel_id( nlayers_pid, & + ndf_pid, undf_pid, & + map_pid(:,cell), & + panel_id_proxy%data, & + geometry, topology, & + global_dof_id, & + panel_ncells ) call mesh%get_column_coords(cell,column_coords) - call assign_coordinate_alphabetaz( nlayers, & - ndf, & - nverts, & - undf, & - map(:,cell), & - chi_proxy(1)%data, & - chi_proxy(2)%data, & - chi_proxy(3)%data, & - column_coords, & - dof_coords, & - vertex_coords, & - to_rotate, & - inverse_rot_matrix, & - stretch_factor, & - panel_id_proxy%data, & - ndf_pid, & - undf_pid, & - map_pid(:,cell) ) + call assign_coordinate_alphabetaz( nlayers, & + ndf, & + nverts, & + undf, & + map(:,cell), & + chi_proxy(1)%data, & + chi_proxy(2)%data, & + chi_proxy(3)%data, & + column_coords, & + dof_coords, & + vertex_coords, & + to_rotate, & + inverse_rot_matrix, & + stretch_factor, & + panel_id_proxy%data, & + scaled_radius, & + ndf_pid, & + undf_pid, & + map_pid(:,cell) ) end do else @@ -299,6 +322,8 @@ end subroutine assign_coordinate_field !> @param[in] undf_pid Universal number of DoFs for the panel_id field !> @param[in] map_pid DoF map for the panel_id field !> @param[out] panel_id Field (to be calculated) with the ID of cubed sphere panels + !> @param[in] geometry + !> @param[in] topology !> @param[in] global_dof_id Array of global id's !> @param[in] panel_ncells Number of cells per cubed sphere panel subroutine calc_panel_id( nlayers, & @@ -306,6 +331,7 @@ subroutine calc_panel_id( nlayers, & undf_pid, & map_pid, & panel_id, & + geometry, topology, & global_dof_id, & panel_ncells ) @@ -320,6 +346,10 @@ subroutine calc_panel_id( nlayers, & ! Internal variables integer(kind=i_def) :: vert, k + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + + if ( geometry == geometry_spherical .and. & topology == topology_fully_periodic ) then @@ -351,6 +381,9 @@ end subroutine calc_panel_id !> @param[in] domain_x Domain extent in x direction for planar mesh !> @param[in] domain_y Domain extent in y direction for planar mesh !> @param[in] panel_id Field giving IDs of mesh panels + !> @param[in] geometry + !> @param[in] topology + !> @param[in] scaled_radius !> @param[in] ndf_pid Number of DoFs per cell for panel_id space !> @param[in] undf_pid Number of universal DoFs for panel_id space !> @param[in] map_pid DoF map for panel_id space @@ -369,6 +402,9 @@ subroutine assign_coordinate_xyz( nlayers, & domain_x, & domain_y, & panel_id, & + geometry, & + topology, & + scaled_radius, & ndf_pid, & undf_pid, & map_pid ) @@ -387,6 +423,8 @@ subroutine assign_coordinate_xyz( nlayers, & real(kind=r_def), intent(in) :: chi_hat_node(3,ndf), chi_hat_vert(nverts,3) real(kind=r_def), intent(in) :: domain_x, domain_y real(kind=r_def), intent(in) :: panel_id(undf_pid) + integer(i_def), intent(in) :: geometry, topology + real(r_def), intent(in) :: scaled_radius ! Internal variables integer(kind=i_def) :: k, df, dfk, vert @@ -471,6 +509,7 @@ end subroutine assign_coordinate_xyz !! Cartesian coordinates from physical ones !> @param[in] stretch_factor Stretch factor for Schmidt transform !> @param[in] panel_id Field giving IDs of mesh panels + !> @param[in] scaled_radius !> @param[in] ndf_pid Number of DoFs per cell for panel_id space !> @param[in] undf_pid Number of universal DoFs for panel_id space !> @param[in] map_pid DoF map for panel_id space @@ -489,6 +528,7 @@ subroutine assign_coordinate_alphabetaz( nlayers, & inverse_rot_matrix, & stretch_factor, & panel_id, & + scaled_radius, & ndf_pid, & undf_pid, & map_pid ) @@ -507,6 +547,7 @@ subroutine assign_coordinate_alphabetaz( nlayers, & integer(kind=i_def), intent(in) :: ndf_pid, undf_pid integer(kind=i_def), intent(in) :: map_pid(ndf_pid) real(kind=r_def), intent(in) :: panel_id(undf_pid) + real(kind=r_def), intent(in) :: scaled_radius ! Internal variables integer(kind=i_def) :: k, df, dfk, vert @@ -587,6 +628,7 @@ end subroutine assign_coordinate_alphabetaz !> @param[in] inverse_rot_matrix Rotation matrix to apply to obtain native !! Cartesian coordinates from physical ones !> @param[in] panel_id Field giving IDs of mesh panels + !> @param[in] scaled_radius !> @param[in] ndf_pid Number of DoFs per cell for panel_id space !> @param[in] undf_pid Number of universal DoFs for panel_id space !> @param[in] map_pid DoF map for panel_id space @@ -604,6 +646,7 @@ subroutine assign_coordinate_lonlatz( nlayers, & to_rotate, & inverse_rot_matrix, & panel_id, & + scaled_radius, & ndf_pid, & undf_pid, & map_pid ) @@ -621,6 +664,7 @@ subroutine assign_coordinate_lonlatz( nlayers, & integer(kind=i_def), intent(in) :: ndf_pid, undf_pid integer(kind=i_def), intent(in) :: map_pid(ndf_pid) real(kind=r_def), intent(in) :: panel_id(undf_pid) + real(kind=r_def), intent(in) :: scaled_radius ! Internal variables integer(kind=i_def) :: k, df, dfk, vert diff --git a/components/driver/source/driver_counter_mod.f90 b/components/driver/source/driver_counter_mod.f90 index c4cfb300a..41b255c7b 100644 --- a/components/driver/source/driver_counter_mod.f90 +++ b/components/driver/source/driver_counter_mod.f90 @@ -7,10 +7,9 @@ !> module driver_counter_mod - use count_mod, only : count_type, halo_calls - use io_config_mod, only : subroutine_counters, & - counter_output_suffix - use timer_mod, only : timer, output_timer, init_timer + use count_mod, only: count_type, halo_calls + use driver_modeldb_mod, only: modeldb_type + use timer_mod, only: timer, output_timer, init_timer implicit none @@ -26,13 +25,18 @@ module driver_counter_mod !> !> @param[in] identifier Top level halo name. !> - subroutine init_counters( identifier ) + subroutine init_counters( modeldb, identifier ) implicit none - character(*), intent(in) :: identifier + type(modeldb_type), intent(in) :: modeldb + character(*), intent(in) :: identifier - if (subroutine_counters) then + logical(l_def) :: subroutine_counters + + subroutine_counters = modeldb%config%io%subroutine_counters() + + if ( subroutine_counters ) then allocate( halo_calls, source=count_type('halo_calls') ) call halo_calls%counter( identifier ) end if @@ -50,13 +54,20 @@ end subroutine init_counters !> !> @param[in] identifier Top level counter name. !> - subroutine final_counters( identifier ) + subroutine final_counters(modeldb, identifier ) implicit none - character(*), intent(in) :: identifier + type(modeldb_type), intent(in) :: modeldb + character(*), intent(in) :: identifier - if ( subroutine_counters ) then + logical(l_def) :: subroutine_counters + character(str_def) :: counter_output_suffix + + subroutine_counters = modeldb%config%io%subroutine_counters() + counter_output_suffix = modeldb%config%io%counter_output_suffix() + + if (subroutine_counters) then call halo_calls%counter( identifier ) call halo_calls%output_counters( counter_output_suffix ) end if diff --git a/components/driver/source/driver_fem_mod.f90 b/components/driver/source/driver_fem_mod.f90 index 7ba02690e..cf5156eb2 100644 --- a/components/driver/source/driver_fem_mod.f90 +++ b/components/driver/source/driver_fem_mod.f90 @@ -15,8 +15,8 @@ module driver_fem_mod use sci_chi_transform_mod, only: init_chi_transforms, & final_chi_transforms use constants_mod, only: i_def, l_def, str_def + use driver_modeldb_mod, only: modeldb_type use extrusion_mod, only: TWOD, PRIME_EXTRUSION - use finite_element_config_mod, only: coord_order use field_mod, only: field_type use fs_continuity_mod, only: W0, W2, W3, Wtheta, Wchi, W2v, W2h use function_space_mod, only: function_space_type @@ -35,9 +35,7 @@ module driver_fem_mod LOG_LEVEL_ERROR, & log_scratch_space use mesh_mod, only: mesh_type - use mesh_collection_mod, only: mesh_collection_type - - use base_mesh_config_mod, only: geometry, topology + use mesh_collection_mod, only: mesh_collection implicit none @@ -48,40 +46,45 @@ module driver_fem_mod !> @brief Initialises the coordinate fields (chi) and FEM components. !> - !> @param[in] mesh_collection Collection of all meshes to set up + !> @param[in] modeldb Model state object !! coordinates for !> @param[in,out] chi_inventory Inventory object, containing all of !! the chi fields indexed by mesh !> @param[in,out] panel_id_inventory Inventory object, containing all of !! the fields with the ID of mesh panels - subroutine init_fem( mesh_collection, chi_inventory, panel_id_inventory ) + subroutine init_fem( modeldb, chi_inventory, panel_id_inventory ) implicit none ! Coordinate field - type(mesh_collection_type), intent(in) :: mesh_collection - type(inventory_by_mesh_type), intent(inout) :: chi_inventory - type(inventory_by_mesh_type), intent(inout) :: panel_id_inventory + type(modeldb_type), target, intent(in) :: modeldb + + type(inventory_by_mesh_type), intent(inout) :: chi_inventory + type(inventory_by_mesh_type), intent(inout) :: panel_id_inventory character(str_def), allocatable :: all_mesh_names(:) - type(mesh_type), pointer :: mesh => null() - type(mesh_type), pointer :: twod_mesh => null() + type(mesh_type), pointer :: mesh + type(mesh_type), pointer :: twod_mesh type(field_type) :: chi(3) type(field_type) :: panel_id - type(function_space_type), pointer :: fs => null() - integer(kind=i_def) :: chi_space, coord, i + type(function_space_type), pointer :: fs + integer(i_def) :: chi_space, coord, i character(str_def) :: mesh_name + integer(i_def) :: coord_order call log_event( 'FEM specifics: creating function spaces...', log_level_info ) + coord_order = modeldb%config%finite_element%coord_order() + + nullify(mesh, twod_mesh, fs) + ! ======================================================================== ! ! Initialise coordinates ! ======================================================================== ! ! Initialise coordinate transformations - call init_chi_transforms( geometry, topology, & - mesh_collection=mesh_collection ) + call init_chi_transforms( modeldb ) ! To loop through mesh collection, get all mesh names ! Then get mesh from collection using these names @@ -125,7 +128,7 @@ subroutine init_fem( mesh_collection, chi_inventory, panel_id_inventory ) end do ! Set coordinate fields -------------------------------------------------- - call assign_coordinate_field(chi, panel_id, mesh) + call assign_coordinate_field(modeldb, chi, panel_id, mesh) ! Add fields to inventory call chi_inventory%copy_field_array(chi, mesh) @@ -143,11 +146,11 @@ end subroutine init_fem !> @param[in] mesh_collection Collection of all meshes to set up !! coordinates for !> @param[in] multigrid_mesh_names Names of the multigrid meshes - subroutine init_function_space_chains( mesh_collection, multigrid_mesh_names ) + subroutine init_function_space_chains( multigrid_mesh_names ) implicit none - type(mesh_collection_type), intent(in) :: mesh_collection +! type(mesh_collection_type), intent(in) :: mesh_collection character(str_def), intent(in) :: multigrid_mesh_names(:) type(mesh_type), pointer :: mesh => null() diff --git a/components/driver/source/driver_log_mod.f90 b/components/driver/source/driver_log_mod.f90 index 28f416313..2d3db8330 100644 --- a/components/driver/source/driver_log_mod.f90 +++ b/components/driver/source/driver_log_mod.f90 @@ -1,7 +1,8 @@ module driver_log_mod -use constants_mod, only: i_def +use constants_mod, only: i_def, l_def use convert_to_upper_mod, only: convert_to_upper +use driver_modeldb_mod, only: modeldb_type use lfric_mpi_mod, only: lfric_comm_type use log_mod, only: log_event, & log_set_level, & @@ -14,14 +15,14 @@ module driver_log_mod LOG_LEVEL_INFO, & LOG_LEVEL_DEBUG, & LOG_LEVEL_TRACE -use logging_config_mod, only: run_log_level, & - key_from_run_log_level, & - RUN_LOG_LEVEL_ERROR, & - RUN_LOG_LEVEL_INFO, & - RUN_LOG_LEVEL_DEBUG, & - RUN_LOG_LEVEL_TRACE, & - RUN_LOG_LEVEL_WARNING, & - log_to_rank_zero_only + +use logging_config_mod, only: key_from_run_log_level, & + RUN_LOG_LEVEL_ERROR, & + RUN_LOG_LEVEL_INFO, & + RUN_LOG_LEVEL_DEBUG, & + RUN_LOG_LEVEL_TRACE, & + RUN_LOG_LEVEL_WARNING + implicit none @@ -35,14 +36,23 @@ module driver_log_mod !> @param[in] communicator MPI communicator to use for logging. !> @param[in] program_name Identifies the running program. !> -subroutine init_logger(communicator, program_name) +subroutine init_logger(modeldb, program_name) implicit none - character(len=*), intent(in) :: program_name - type(lfric_comm_type), intent(in) :: communicator + type(modeldb_type), intent(in) :: modeldb + character(len=*), intent(in) :: program_name + + type(lfric_comm_type) :: communicator integer(i_def) :: log_level + integer(i_def) :: run_log_level + logical(l_def) :: log_to_rank_zero_only + + communicator = modeldb%mpi%get_comm() + + run_log_level = modeldb%config%logging%run_log_level() + log_to_rank_zero_only = modeldb%config%logging%log_to_rank_zero_only() call initialise_logging( communicator%get_comm_mpi_val(), program_name, & log_to_rank_zero_only=log_to_rank_zero_only) diff --git a/components/driver/source/driver_mesh_mod.f90 b/components/driver/source/driver_mesh_mod.f90 index a8ce5eda5..460521463 100644 --- a/components/driver/source/driver_mesh_mod.f90 +++ b/components/driver/source/driver_mesh_mod.f90 @@ -127,6 +127,14 @@ subroutine init_mesh( config, & integer :: topology integer :: mesh_selection + ! Multigrid related + character(str_def), allocatable :: chain_mesh_tags(:) + logical(l_def) :: inner_halo_tiles + logical(l_def) :: coarsen_multigrid_tiles + integer(i_def) :: tile_size_x + integer(i_def) :: tile_size_y + integer(i_def) :: max_tiled_multigrid_level + ! Local variables character(str_def), allocatable :: names(:) character(str_def), allocatable :: tmp_mesh_names(:) @@ -147,6 +155,15 @@ subroutine init_mesh( config, & file_prefix = config%base_mesh%file_prefix() cellshape = config%finite_element%cellshape() + ! Temporary extraction, These configuration varaibles need + ! to be refactored out. + chain_mesh_tags = config%multigrid% chain_mesh_tags() + inner_halo_tiles = config%partitioning%inner_halo_tiles() + tile_size_x = config%partitioning%tile_size_x() + tile_size_y = config%partitioning%tile_size_y() + max_tiled_multigrid_level = config%partitioning%max_tiled_multigrid_level() + coarsen_multigrid_tiles = config%partitioning%coarsen_multigrid_tiles() + if ( .not. prepartitioned ) then generate_inner_halos = config%partitioning%generate_inner_halos() end if @@ -327,12 +344,17 @@ subroutine init_mesh( config, & end if ! prepartitioned - !============================================================================ ! 3.0 Extrude the specified meshes from local mesh objects into ! mesh objects on the given extrusion. !============================================================================ - call create_mesh( mesh_names, extrusion, alt_name=names ) + call create_mesh( mesh_names, extrusion, alt_name=names, & + chain_mesh_tags = chain_mesh_tags, & + inner_halo_tiles = inner_halo_tiles, & + tile_size_x = tile_size_x, & + tile_size_y = tile_size_y, & + max_tiled_multigrid_level = max_tiled_multigrid_level, & + coarsen_multigrid_tiles = coarsen_multigrid_tiles ) !============================================================================ diff --git a/components/driver/source/driver_modeldb_mod.f90 b/components/driver/source/driver_modeldb_mod.f90 index d26db8254..3743bed6a 100644 --- a/components/driver/source/driver_modeldb_mod.f90 +++ b/components/driver/source/driver_modeldb_mod.f90 @@ -13,12 +13,12 @@ module driver_modeldb_mod use calendar_mod, only: calendar_type + use config_mod, only: config_type use driver_model_data_mod, only: model_data_type use key_value_collection_mod, only: key_value_collection_type use lfric_mpi_mod, only: lfric_mpi_type use model_clock_mod, only: model_clock_type use namelist_collection_mod, only: namelist_collection_type - use config_mod, only: config_type use io_context_collection_mod, only: io_context_collection_type implicit none diff --git a/components/driver/source/mesh/create_mesh_mod.f90 b/components/driver/source/mesh/create_mesh_mod.f90 index a91e6d5fb..e1471c9c3 100644 --- a/components/driver/source/mesh/create_mesh_mod.f90 +++ b/components/driver/source/mesh/create_mesh_mod.f90 @@ -34,13 +34,13 @@ module create_mesh_mod method_geometric, & method_quadratic - use multigrid_config_mod, only: chain_mesh_tags +! use multigrid_config_mod, only: chain_mesh_tags - use partitioning_config_mod, only: tile_size_x, & - tile_size_y, & - inner_halo_tiles, & - max_tiled_multigrid_level, & - coarsen_multigrid_tiles +! use partitioning_config_mod, only: tile_size_x, & +! tile_size_y, & +! inner_halo_tiles, & +! max_tiled_multigrid_level, & +! coarsen_multigrid_tiles implicit none @@ -106,8 +106,13 @@ end function create_extrusion !! extruded meshes, defaults to local_mesh_names !! if absent. subroutine create_mesh_multiple( local_mesh_names, & - extrusion, & - alt_name ) + extrusion, & + alt_name, & + chain_mesh_tags, & + tile_size_x,tile_size_y, & + max_tiled_multigrid_level, & + inner_halo_tiles, & + coarsen_multigrid_tiles ) implicit none character(str_def), intent(in) :: local_mesh_names(:) @@ -115,12 +120,16 @@ subroutine create_mesh_multiple( local_mesh_names, & character(str_def), intent(in), & optional :: alt_name(:) + character(str_def), intent(in), optional :: chain_mesh_tags(:) + integer(i_def), intent(in), optional :: max_tiled_multigrid_level, tile_size_x,tile_size_y + logical(l_def), intent(in), optional :: inner_halo_tiles + logical(l_def), intent(in), optional :: coarsen_multigrid_tiles + ! Local variables integer(i_def) :: i character(str_def), allocatable :: names(:) if (present(alt_name)) then - if ( size(alt_name) /= size(local_mesh_names) ) then write(log_scratch_space, '(A)') & 'Number of alternative mesh names does not match '// & @@ -129,17 +138,19 @@ subroutine create_mesh_multiple( local_mesh_names, & end if allocate(names, source=alt_name) - else - allocate(names, source=local_mesh_names) - end if do i=1, size(local_mesh_names) - call create_mesh_single( local_mesh_names(i), & - extrusion, & - alt_name=names(i) ) + call create_mesh_single( local_mesh_names(i), extrusion, & + alt_name=names(i), & + chain_mesh_tags=chain_mesh_tags, & + tile_size_x=tile_size_x, & + tile_size_y=tile_size_y, & + max_tiled_multigrid_level=max_tiled_multigrid_level, & + inner_halo_tiles=inner_halo_tiles, & + coarsen_multigrid_tiles=coarsen_multigrid_tiles ) end do deallocate(names) @@ -157,16 +168,29 @@ end subroutine create_mesh_multiple !> @param[in] alt_name Optional, Alternative name for the !! extruded mesh, defaults to local_mesh_name !! if absent. -subroutine create_mesh_single( local_mesh_name, & - extrusion, & - alt_name ) +!! @param[in] max_tiled_multigrid_level [optional], needs to be refactored out as its multigrid +!! @param[in] chain_mesh_tags [optional], needs to be refactored out as its multigrid +!! @param[in] coarsen_multigrid_tiles [optional], needs to be refactored out as its multigrid +subroutine create_mesh_single( local_mesh_name, & + extrusion, & + alt_name, & + chain_mesh_tags, & + tile_size_x, tile_size_y, & + max_tiled_multigrid_level, & + inner_halo_tiles, & + coarsen_multigrid_tiles ) implicit none character(str_def), intent(in) :: local_mesh_name class(extrusion_type), intent(in) :: extrusion - character(str_def), intent(in), & - optional :: alt_name + + character(str_def), intent(in), optional :: alt_name + character(str_def), intent(in), optional :: chain_mesh_tags(:) + integer(i_def), intent(in), optional :: max_tiled_multigrid_level + integer(i_def), intent(in), optional :: tile_size_x,tile_size_y + logical(l_def), intent(in), optional :: inner_halo_tiles + logical(l_def), intent(in), optional :: coarsen_multigrid_tiles type(local_mesh_type), pointer :: local_mesh_ptr => null() @@ -233,19 +257,27 @@ subroutine create_mesh_single( local_mesh_name, & if ( extrusion%get_id() == PRIME_EXTRUSION .or. & extrusion%get_id() == SHIFTED .or. & extrusion%get_id() == DOUBLE_LEVEL ) then - if ( allocated(chain_mesh_tags) ) then - ! Multigrid setup - use tiling if multigrid level is allowed, and - ! if mesh name includes the mesh tag at that level - do multigrid_level = 1, SIZE(chain_mesh_tags) - if ( index( trim(name), trim(chain_mesh_tags(multigrid_level)) ) > 0 & - .and. multigrid_level <= max_multigrid_level ) then - set_tile_size = .true. - exit - end if - end do + + if ( present(chain_mesh_tags) ) then + if (size(chain_mesh_tags) > 1) then + ! Multigrid setup - use tiling if multigrid level is allowed, and + ! if mesh name includes the mesh tag at that level + do multigrid_level = 1, SIZE(chain_mesh_tags) + if ( index( trim(name), trim(chain_mesh_tags(multigrid_level)) ) > 0 & + .and. multigrid_level <= max_multigrid_level ) then + set_tile_size = .true. + exit + end if + end do + else + set_tile_size = .true. + end if + else + ! Not a multigrid setup - use tiling set_tile_size = .true. + end if end if @@ -255,17 +287,22 @@ subroutine create_mesh_single( local_mesh_name, & if ( set_tile_size ) then if ( tile_size_x /= imdi ) tile_size(1) = tile_size_x if ( tile_size_y /= imdi ) tile_size(2) = tile_size_y - if ( coarsen_multigrid_tiles .and. allocated( chain_mesh_tags ) ) then - do multigrid_level = 1, SIZE(chain_mesh_tags) - if ( index( trim(name), & - trim(chain_mesh_tags(multigrid_level)) ) > 0 ) exit - tile_size = max( tile_size / 2, 1 ) - end do + + if ( present(chain_mesh_tags) ) then + if (size(chain_mesh_tags) > 1 .and. coarsen_multigrid_tiles) then + do multigrid_level = 1, SIZE(chain_mesh_tags) + if ( index( trim(name), & + trim(chain_mesh_tags(multigrid_level)) ) > 0 ) exit + tile_size = max( tile_size / 2, 1 ) + end do + end if end if + end if mesh = mesh_type( local_mesh_ptr, extrusion, mesh_name=name, & - tile_size=tile_size, inner_halo_tiles=inner_halo_tiles ) + tile_size=tile_size, & + inner_halo_tiles=inner_halo_tiles ) mesh_id = mesh_collection%add_new_mesh( mesh ) call mesh%clear() diff --git a/components/driver/unit-test/assign_coordinate_alphabetaz_mod_test.pf b/components/driver/unit-test/assign_coordinate_alphabetaz_mod_test.pf index 2928f43ca..f6c125ce9 100644 --- a/components/driver/unit-test/assign_coordinate_alphabetaz_mod_test.pf +++ b/components/driver/unit-test/assign_coordinate_alphabetaz_mod_test.pf @@ -14,47 +14,10 @@ module assign_coordinate_alphabetaz_mod_test implicit none private - public :: set_up, tear_down, test_all - - real(kind=r_def), parameter :: radius = 104.0_r_def + public :: test_all contains - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @before - subroutine set_up() - - use extrusion_config_mod, only : method_uniform, & - stretching_method_linear - use feign_config_mod, only : feign_extrusion_config, & - feign_planet_config - - implicit none - - call feign_extrusion_config( method=method_uniform, & - planet_radius=radius, & - domain_height=10.0_r_def, & - number_of_layers=5_i_def, & - stretching_method=stretching_method_linear, & - stretching_height=15.0_r_def, & - eta_values=(/0.5_r_def/) ) - - call feign_planet_config( scaling_factor=1.0_r_def ) - - end subroutine set_up - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @after - subroutine tear_down() - - use config_loader_mod, only: final_configuration - - implicit none - - call final_configuration() - - end subroutine tear_down - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @test subroutine test_all() @@ -64,6 +27,7 @@ contains implicit none real(kind=r_def), parameter :: dh = 17.0_r_def + real(kind=r_def), parameter :: scaled_radius = 104.0_r_def integer(kind=i_def) :: nlayers, ndf_chi, undf_chi, ndf_pid, undf_pid integer(kind=i_def) :: map_chi(1), map_pid(1), nverts, i @@ -152,8 +116,8 @@ contains alpha_out, beta_out, height_out, & verts_XYZ, nodal_coord, verts_ref, & to_rotate, inverse_rot_matrix, & - stretch_factor, & - panel_id, ndf_pid, undf_pid, map_pid ) + stretch_factor, panel_id, scaled_radius, & + ndf_pid, undf_pid, map_pid) ! The answer should be the central point of the box ! alpha = pi/12, beta = -pi/24, h = dh / 2, panel_id = 3 @@ -176,8 +140,9 @@ contains alpha_out, beta_out, height_out, & verts_XYZ, nodal_coord, verts_ref, & to_rotate, inverse_rot_matrix, & - stretch_factor, & - panel_id, ndf_pid, undf_pid, map_pid ) + stretch_factor, panel_id, scaled_radius, & + ndf_pid, undf_pid, map_pid) + ! Alpha and beta swap from the example above ! alpha = -pi/24, beta = pi/12, h = dh / 2, panel_id = 5 @@ -220,8 +185,8 @@ contains alpha_out, beta_out, height_out, & verts_XYZ, nodal_coord, verts_ref, & to_rotate, inverse_rot_matrix, & - stretch_factor, & - panel_id, ndf_pid, undf_pid, map_pid ) + stretch_factor, panel_id, scaled_radius, & + ndf_pid, undf_pid, map_pid) ! Answer is in panel 3, with alpha and beta rotated from panel 1 ! alpha = 0.0, beta = -pi/6 (negative of the original longitude), h = dh / 2 diff --git a/components/driver/unit-test/assign_coordinate_lonlatz_mod_test.pf b/components/driver/unit-test/assign_coordinate_lonlatz_mod_test.pf index 175ba7ce2..383110cb3 100644 --- a/components/driver/unit-test/assign_coordinate_lonlatz_mod_test.pf +++ b/components/driver/unit-test/assign_coordinate_lonlatz_mod_test.pf @@ -13,47 +13,10 @@ module assign_coordinate_lonlatz_mod_test implicit none private - public :: set_up, tear_down, test_all - - real(kind=r_def), parameter :: radius = 19.0_r_def + public :: test_all contains - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @before - subroutine set_up() - - use extrusion_config_mod, only : method_uniform, & - stretching_method_linear - use feign_config_mod, only : feign_extrusion_config, & - feign_planet_config - - implicit none - - call feign_extrusion_config( method=method_uniform, & - planet_radius=radius, & - domain_height=10.0_r_def, & - number_of_layers=5_i_def, & - stretching_method=stretching_method_linear, & - stretching_height=15.0_r_def, & - eta_values=(/0.5_r_def/) ) - - call feign_planet_config( scaling_factor=1.0_r_def ) - - end subroutine set_up - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @after - subroutine tear_down() - - use config_loader_mod, only : final_configuration - - implicit none - - call final_configuration() - - end subroutine tear_down - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @test subroutine test_all() @@ -63,6 +26,7 @@ contains implicit none + real(kind=r_def), parameter :: scaled_radius = 19.0_r_def real(kind=r_def), parameter :: dh = 2.4_r_def real(kind=r_def), parameter :: tol = 1.0e-10_r_def ! for r_def 64-bit real(kind=r_def) :: use_tol @@ -118,17 +82,18 @@ contains ! Test with no rotation ---------------------------------------------------- to_rotate = .false. - inverse_rot_matrix = reshape([[1.0_r_def, 0.0_r_def, 0.0_r_def], & - [0.0_r_def, 1.0_r_def, 0.0_r_def], & - [0.0_r_def, 0.0_r_def, 1.0_r_def]], & + inverse_rot_matrix = reshape([[1.0_r_def, 0.0_r_def, 0.0_r_def], & + [0.0_r_def, 1.0_r_def, 0.0_r_def], & + [0.0_r_def, 0.0_r_def, 1.0_r_def]], & shape=[3,3]) - call assign_coordinate_lonlatz(nlayers, ndf_chi, nverts, & - undf_chi, map_chi, & - longitude, latitude, height, & - verts_XYZ, nodal_coord, verts_ref, & - to_rotate, inverse_rot_matrix, & - panel_id, ndf_pid, undf_pid, map_pid ) + call assign_coordinate_lonlatz(nlayers, ndf_chi, nverts, & + undf_chi, map_chi, & + longitude, latitude, height, & + verts_XYZ, nodal_coord, verts_ref, & + to_rotate, inverse_rot_matrix, & + panel_id, scaled_radius, & + ndf_pid, undf_pid, map_pid) ! The answer should be the central point of the box ! lon = 5*pi/12, lat = 5*pi/24, h = dh / 2 @@ -158,18 +123,19 @@ contains ! Rotation matrix corresponding to North pole at lon=pi/2 and lat=pi/2 to_rotate = .true. ! The corresponding rotation matrix is: - inverse_rot_matrix = reshape( & - [[ 0.0_r_def, -1.0_r_def, 0.0_r_def], & - [ 1.0_r_def, 0.0_r_def, 0.0_r_def], & - [ 0.0_r_def, 0.0_r_def, 1.0_r_def]], & + inverse_rot_matrix = reshape( & + [[ 0.0_r_def, -1.0_r_def, 0.0_r_def], & + [ 1.0_r_def, 0.0_r_def, 0.0_r_def], & + [ 0.0_r_def, 0.0_r_def, 1.0_r_def]], & shape=[3,3]) - call assign_coordinate_lonlatz(nlayers, ndf_chi, nverts, & - undf_chi, map_chi, & - longitude, latitude, height, & - verts_XYZ, nodal_coord, verts_ref, & - to_rotate, inverse_rot_matrix, & - panel_id, ndf_pid, undf_pid, map_pid ) + call assign_coordinate_lonlatz(nlayers, ndf_chi, nverts, & + undf_chi, map_chi, & + longitude, latitude, height, & + verts_XYZ, nodal_coord, verts_ref, & + to_rotate, inverse_rot_matrix, & + panel_id, scaled_radius, & + ndf_pid, undf_pid, map_pid) ! The answer should be the central point of the box ! lon = -pi/12, lat = 5*pi/24, h = dh / 2 diff --git a/components/driver/unit-test/assign_coordinate_xyz_mod_test.pf b/components/driver/unit-test/assign_coordinate_xyz_mod_test.pf index 8ad3613f9..bf888f210 100644 --- a/components/driver/unit-test/assign_coordinate_xyz_mod_test.pf +++ b/components/driver/unit-test/assign_coordinate_xyz_mod_test.pf @@ -19,62 +19,19 @@ module assign_coordinate_xyz_mod_test type, extends(TestCase) :: assign_coordinate_xyz_test_type private contains - procedure setUp - procedure tearDown procedure test_all end type assign_coordinate_xyz_test_type contains - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine setUp( this ) - - use base_mesh_config_mod, only : geometry_planar, & - topology_fully_periodic - use feign_config_mod, only : feign_base_mesh_config, & - feign_finite_element_config - use finite_element_config_mod, only : cellshape_quadrilateral, & - coord_system_xyz - - implicit none - - class(assign_coordinate_xyz_test_type), intent(inout) :: this - - call feign_base_mesh_config( file_prefix='foo', & - prime_mesh_name='unit_test', & - geometry=geometry_planar, & - prepartitioned=.false., & - topology=topology_fully_periodic, & - fplane=.false., f_lat_deg=0.0_r_def ) - - call feign_finite_element_config( cellshape=cellshape_quadrilateral, & - coord_order=0_i_def, & - coord_system=coord_system_xyz, & - element_order_h=0_i_def, & - element_order_v=0_i_def, & - rehabilitate=.true. ) - - end subroutine setUp - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine tearDown( this ) - - use config_loader_mod, only: final_configuration - - implicit none - - class(assign_coordinate_xyz_test_type), intent(inout) :: this - - call final_configuration() - - end subroutine tearDown - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @Test subroutine test_all( this ) use driver_coordinates_mod, only : assign_coordinate_xyz + use base_mesh_config_mod, only: geometry_planar, topology_fully_periodic + implicit none class(assign_coordinate_xyz_test_type), intent(inout) :: this @@ -82,6 +39,10 @@ contains real(kind=r_def), parameter :: tol = 1.0e-3_r_def, & one = 1.0_r_def + integer(i_def), parameter :: geometry = geometry_planar + integer(i_def), parameter :: topology = topology_fully_periodic + real(r_def), parameter :: scaled_radius = 1.0_r_def + integer(kind=i_def) :: nlayers, ndf, nverts, i, undf, ndf_pid, undf_pid integer(kind=i_def) :: map(1), map_pid(1) real(kind=r_def) :: x(1),y(1),z(1), dz(1), panel_id(1) @@ -114,8 +75,9 @@ contains call assign_coordinate_xyz( nlayers, ndf, nverts, undf, map, dz, x, y, z, & vertices_phys, nodal_coord, vertices_comp, & - 2.0_r_def, 0.0_r_def, panel_id, ndf_pid, & - undf_pid, map_pid ) + 2.0_r_def, 0.0_r_def, panel_id, & + geometry, topology, scaled_radius, & + ndf_pid, undf_pid, map_pid ) @assertEqual( one, x(1), tol ) @assertEqual( one, y(1), tol ) diff --git a/components/driver/unit-test/mesh/create_mesh_mod_test.pf b/components/driver/unit-test/mesh/create_mesh_mod_test.pf index fd8fe0108..26efbbabc 100644 --- a/components/driver/unit-test/mesh/create_mesh_mod_test.pf +++ b/components/driver/unit-test/mesh/create_mesh_mod_test.pf @@ -20,8 +20,6 @@ module create_mesh_mod_test use extrusion_mod, only : extrusion_type, & PRIME_EXTRUSION use extrusion_config_mod, only : METHOD_UNIFORM - use feign_config_mod, only : feign_multigrid_config, & - feign_partitioning_config use create_mesh_mod, only : create_extrusion, & create_mesh use panel_decomposition_mod, only : custom_decomposition_type @@ -53,13 +51,6 @@ contains global_mesh_collection = global_mesh_collection_type() local_mesh_collection = local_mesh_collection_type() - call feign_multigrid_config( chain_mesh_tags = [ 'dummy' ], & - multigrid_chain_nitems = 1_i_def, & - n_coarsesmooth = 1_i_def, & - n_postsmooth = 1_i_def, & - n_presmooth = 1_i_def, & - smooth_relaxation = 0.0_r_def ) - end subroutine setUp !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -172,18 +163,18 @@ contains max_stencil_depth, generate_inner_halos, & 0_i_def, 1_i_def) - call feign_partitioning_config( coarsen_multigrid_tiles = .false., & - generate_inner_halos = .true., & - inner_halo_tiles = .false., & - max_tiled_multigrid_level = 1_i_def, & - panel_decomposition = & - panel_decomposition_auto, & - panel_xproc = 1_i_def, & - panel_yproc = 1_i_def, & - partitioner = & - partitioner_planar, & - tile_size_x = 1_i_def, & - tile_size_y = 1_i_def ) +!!$ call feign_partitioning_config( coarsen_multigrid_tiles = .false., & +!!$ generate_inner_halos = .true., & +!!$ inner_halo_tiles = .false., & +!!$ max_tiled_multigrid_level = 1_i_def, & +!!$ panel_decomposition = & +!!$ panel_decomposition_auto, & +!!$ panel_xproc = 1_i_def, & +!!$ panel_yproc = 1_i_def, & +!!$ partitioner = & +!!$ partitioner_planar, & +!!$ tile_size_x = 1_i_def, & +!!$ tile_size_y = 1_i_def ) allocate( extrusion, source=create_extrusion( METHOD_UNIFORM, & 100.0_r_def, & @@ -193,7 +184,14 @@ contains ! Check that exactly one mesh is added to the collection @assertEqual( mesh_collection%n_meshes(), 0 ) - call create_mesh( mesh_name, extrusion ) + call create_mesh( mesh_name, extrusion, & + chain_mesh_tags=[ 'dummy' ], & + tile_size_x=1_i_def, & + tile_size_y=1_i_def, & + max_tiled_multigrid_level=1_i_def, & + inner_halo_tiles=.false., & + coarsen_multigrid_tiles=.false. ) + @assertEqual( mesh_collection%n_meshes(), 1 ) ! Check that mesh name is correct diff --git a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 index 39ccfe0fb..f8db4d5dc 100644 --- a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 +++ b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 @@ -13,6 +13,7 @@ !------------------------------------------------------------------------------ module sci_chi_transform_mod +use config_mod, only : config_type use constants_mod, only : r_def, i_def, l_def, & str_def, EPS, PI, rmdi use coord_transform_mod, only : alphabetar2xyz, & @@ -23,6 +24,7 @@ module sci_chi_transform_mod mesh_rotation_matrix, & schmidt_transform_xyz, & inverse_schmidt_transform_xyz +use driver_modeldb_mod, only : modeldb_type use log_mod, only : log_event, & log_scratch_space, & LOG_LEVEL_ERROR, & @@ -30,15 +32,12 @@ module sci_chi_transform_mod LOG_LEVEL_WARNING use matrix_invert_mod, only : matrix_invert_3x3 -use base_mesh_config_mod, only : geometry, & - geometry_spherical, & - geometry_planar, & - topology, & - topology_fully_periodic -use finite_element_config_mod, only : coord_system, & - coord_system_xyz, & - coord_system_native -use planet_config_mod, only : scaled_radius +! Configuration modules +use base_mesh_config_mod, only: geometry_spherical, & + geometry_planar, & + topology_fully_periodic +use finite_element_config_mod, only: coord_system_xyz, & + coord_system_native implicit none @@ -77,6 +76,7 @@ module sci_chi_transform_mod !------------------------------------------------------------------------------ !> @brief Initialise the coordinate transform information !! +!> @param[in] modeldb Model state object !> @param[in] mesh_collection Optional: a collection of meshes, which contain !! metadata used to determine the rotation matrix !! and stretching factors. @@ -90,18 +90,17 @@ module sci_chi_transform_mod !! argument, and ideally should only be used for !! unit-testing. !------------------------------------------------------------------------------ -subroutine init_chi_transforms( geometry, topology, & - mesh_collection, & +subroutine init_chi_transforms( modeldb, & + mesh_collection, & north_pole_arg, equator_lat_arg ) - use local_mesh_mod, only : local_mesh_type - use mesh_collection_mod, only : mesh_collection_type - use mesh_mod, only : mesh_type + use local_mesh_mod, only: local_mesh_type + use mesh_collection_mod, only: mesh_collection_type + use mesh_mod, only: mesh_type implicit none - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology + type(modeldb_type), intent(in) :: modeldb type(mesh_collection_type), optional, intent(in) :: mesh_collection real(kind=r_def), optional, intent(in) :: north_pole_arg(2) @@ -115,10 +114,15 @@ subroutine init_chi_transforms( geometry, topology, & real(kind=r_def) :: null_island(2) real(kind=r_def) :: equatorial_latitude + integer(i_def) :: geometry + integer(i_def) :: topology + + geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() + ! -------------------------------------------------------------------------- ! ! Extract stretching and rotation information from mesh ! -------------------------------------------------------------------------- ! - ! Begin by assuming no stretching and no rotation to_stretch = .false. to_rotate = .false. @@ -128,6 +132,12 @@ subroutine init_chi_transforms( geometry, topology, & null_island(2) = 0.0_r_def equatorial_latitude = 0.0_r_def + if ( .not. ( (geometry == geometry_spherical) .and. & + (topology == topology_fully_periodic) ) ) then + ! These transforms are only suitable mesh that allow pole rotation. + return + end if + if ( present(mesh_collection) .and. & (present(equator_lat_arg) .or. present(north_pole_arg)) ) then call log_event( & @@ -243,6 +253,7 @@ end subroutine final_chi_transforms !> will be added to the height to give the radius before the coordinates !> are transformed to (X,Y,Z) coordinates. !! +!! @param[in] modeldb Model state object !! @param[in] chi_1 The first coordinate field in !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in @@ -251,16 +262,28 @@ end subroutine final_chi_transforms !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- -subroutine chi2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) +subroutine chi2xyz(modeldb, chi_1, chi_2, chi_3, panel_id, x, y, z) implicit none + type(modeldb_type), intent(in) :: modeldb + integer(kind=i_def), intent(in) :: panel_id real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 real(kind=r_def), intent(out) :: x, y, z real(kind=r_def) :: xyz(3) + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() + coord_system = modeldb%config%finite_element%coord_system() + scaled_radius = modeldb%config%planet%scaled_radius() + if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then ! chi already uses (geocentric) Cartesian coordinates x = chi_1 @@ -333,16 +356,26 @@ end subroutine chi2xyz !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- -subroutine chir2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) +subroutine chir2xyz(modeldb, chi_1, chi_2, chi_3, panel_id, x, y, z) implicit none + type(modeldb_type), intent(in) :: modeldb + integer(kind=i_def), intent(in) :: panel_id real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 real(kind=r_def), intent(out) :: x, y, z real(kind=r_def) :: xyz(3) + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + + geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() + coord_system = modeldb%config%finite_element%coord_system() + if (coord_system == coord_system_xyz .or. geometry == geometry_planar) then ! chi already uses (geocentric) Cartesian coordinates x = chi_1 @@ -404,6 +437,7 @@ end subroutine chir2xyz !> @brief Transforms a coordinate field chi from any system into spherical polar !> (longitude, latitude, radius) coordinates !! +!! @param[in] modeldb Model state object !! @param[in] chi_1 The first coordinate field in !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in @@ -412,16 +446,28 @@ end subroutine chir2xyz !! @param[out] latitude The second coordinate field out (latitude) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2llr(chi_1, chi_2, chi_3, panel_id, lon, lat, radius) +subroutine chi2llr(modeldb, chi_1, chi_2, chi_3, panel_id, lon, lat, radius) implicit none + type(modeldb_type), intent(in) :: modeldb + integer(kind=i_def), intent(in) :: panel_id real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 real(kind=r_def), intent(out) :: lon, lat, radius real(kind=r_def) :: xyz(3) + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() + coord_system = modeldb%config%finite_element%coord_system() + scaled_radius = modeldb%config%planet%scaled_radius() + if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then ! chi uses (geocentric) Cartesian coordinates call xyz2llr(chi_1, chi_2, chi_3, lon, lat, radius) @@ -476,6 +522,7 @@ end subroutine chi2llr !> @brief Transforms a coordinate field chi from any system into *native* !! equiangular cubed sphere (alpha,beta,radius) coordinates !! +!! @param[in] modeldb Model state object !! @param[in] chi_1 The first coordinate field in !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in @@ -484,20 +531,32 @@ end subroutine chi2llr !! @param[out] beta The second coordinate field out (beta) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2abr(chi_1, chi_2, chi_3, panel_id, alpha, beta, radius) +subroutine chi2abr(modeldb, chi_1, chi_2, chi_3, panel_id, alpha, beta, radius) implicit none + type(modeldb_type), intent(in) :: modeldb + integer(kind=i_def), intent(in) :: panel_id real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 real(kind=r_def), intent(out) :: alpha, beta, radius real(kind=r_def) :: xyz(3) + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() + coord_system = modeldb%config%finite_element%coord_system() + scaled_radius = modeldb%config%planet%scaled_radius() + if (topology /= topology_fully_periodic .or. geometry /= geometry_spherical) then - call log_event( & - 'chi2abr can only be used on cubed-sphere meshes', LOG_LEVEL_ERROR & - ) + + call log_event( 'chi2abr can only be used on cubed-sphere meshes', & + LOG_LEVEL_ERROR ) else if (coord_system == coord_system_native) then alpha = chi_1 @@ -531,6 +590,7 @@ end subroutine chi2abr !! native Cartesian coordinates to the physical Cartesian coordinates !------------------------------------------------------------------------------- function get_mesh_rotation_matrix() result(rot_mat) + implicit none real(kind=r_def) :: rot_mat(3,3) @@ -543,6 +603,7 @@ end function get_mesh_rotation_matrix !! physical Cartesian coordinates to native Cartesian coordinates !------------------------------------------------------------------------------- function get_inverse_mesh_rotation_matrix() result(rot_mat) + implicit none real(kind=r_def) :: rot_mat(3,3) @@ -554,6 +615,7 @@ end function get_inverse_mesh_rotation_matrix !> @brief Returns the Schmidt transform stretch factor !------------------------------------------------------------------------------- function get_stretch_factor() result(stretch_factor_out) + implicit none real(kind=r_def) :: stretch_factor_out @@ -565,6 +627,7 @@ end function get_stretch_factor !> @brief Returns whether coordinates are rotated !------------------------------------------------------------------------------- function get_to_rotate() result(to_rotate_out) + implicit none logical(kind=l_def) :: to_rotate_out @@ -576,6 +639,7 @@ end function get_to_rotate !> @brief Returns whether coordinates are stretched !------------------------------------------------------------------------------- function get_to_stretch() result(to_stretch_out) + implicit none logical(kind=l_def) :: to_stretch_out diff --git a/components/science/source/temp b/components/science/source/temp new file mode 100644 index 000000000..25dd7829c --- /dev/null +++ b/components/science/source/temp @@ -0,0 +1,48 @@ + !! @param[in] coord_system Finite-element coordiante system enumeration. + !! @param[in] geometry Mesh geometry enumeration. + !! @param[in] topology Mesh topology enumeration. + !! @param[in] scaled_radius Scaled planetary radius. + + coord_system, & + geometry, & + topology, & + scaled_radius, & + + integer(kind=i_def), intent(in) :: coord_system + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + real(kind=r_def), intent(in) :: scaled_radius + +coord_system, geometry, topology, scaled_radius, & + +coord_system, & +geometry, & +topology, & +scaled_radius, & + +coord_system, geometry, & +topology, scaled_radius, & + + use base_mesh_config_mod, only: geometry, topology + use finite_element_config_mod, only: coord_system + use planet_config_mod, only: scaled_radius + + +integer(i_def), parameter :: coord_system +integer(i_def), parameter :: geometry +integer(i_def), parameter :: topology +real(r_def), parameter :: scaled_radius + + + + + + use base_mesh_config_mod, only: geometry, topology, & + geometry_spherical, & + geometry_planar + +geometry, topology, & + +geometry, topology + +imdi, imdi From bb966f59b8784d191cffa3f273bdc63a8bc54cf6 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Fri, 20 Mar 2026 11:53:25 +0000 Subject: [PATCH 02/44] Remove global config from init_fem and surrounding code --- .../source/driver/coupled_driver_mod.f90 | 2 +- .../source/driver/init_coupled_mod.X90 | 19 +- .../source/driver/io_demo_driver_mod.f90 | 2 +- .../driver/multifile_io/multifile_io_mod.F90 | 3 +- .../source/driver/lbc_demo_driver_mod.f90 | 2 +- .../driver/simple_diffusion_driver_mod.f90 | 2 +- .../source/driver/skeleton_driver_mod.f90 | 2 +- components/driver/source/driver_fem_mod.f90 | 86 ++++---- components/driver/source/driver_io_mod.F90 | 6 +- .../lfric_xios_context_test.f90 | 3 +- .../lfric_xios_cyclic_temporal_test.f90 | 3 +- .../lfric_xios_temporal_iodef_test.f90 | 3 +- .../lfric_xios_temporal_test.f90 | 3 +- .../lfric_xios_time_read_test.f90 | 3 +- .../source/lfric_xios_context_mod.f90 | 9 +- .../source/lfric_xios_setup_mod.x90 | 33 ++- .../algorithm/sci_geometric_constants_mod.x90 | 85 +++++--- .../algorithm/sci_mapping_constants_mod.x90 | 73 +++++-- .../fem/sci_gp_vector_rhs_kernel_mod.F90 | 3 +- .../kernel/geometry/sci_chi_transform_mod.F90 | 75 ++++--- .../sci_compute_latlon_kernel_mod.F90 | 33 ++- .../sci_nodal_xyz_coordinates_kernel_mod.F90 | 36 +++- ...sci_compute_map_u_operators_kernel_mod.F90 | 40 ++-- .../sci_compute_sample_u_ops_kernel_mod.F90 | 45 ++-- .../sci_convert_phys_to_hdiv_kernel_mod.F90 | 36 +++- ...i_project_ws_to_w1_operator_kernel_mod.F90 | 33 ++- .../sci_w3_to_w2_displacement_kernel_mod.F90 | 28 ++- .../kernel/geometry/chi_transform_mod_test.pf | 194 ++++++++++++------ .../compute_latlon_kernel_mod_test.pf | 40 ++-- .../nodal_xyz_coordinates_kernel_mod_test.pf | 42 ++-- ...compute_map_u_operators_kernel_mod_test.pf | 87 ++++---- .../compute_sample_u_ops_kernel_mod_test.pf | 99 +++++---- .../convert_phys_to_hdiv_kernel_mod_test.pf | 58 +++--- ...oject_ws_to_w1_operator_kernel_mod_test.pf | 52 +++-- .../w3_to_w2_displacement_kernel_mod_test.pf | 80 ++++---- 35 files changed, 868 insertions(+), 452 deletions(-) diff --git a/applications/coupled/source/driver/coupled_driver_mod.f90 b/applications/coupled/source/driver/coupled_driver_mod.f90 index 25799a019..4a82c3679 100644 --- a/applications/coupled/source/driver/coupled_driver_mod.f90 +++ b/applications/coupled/source/driver/coupled_driver_mod.f90 @@ -136,7 +136,7 @@ subroutine initialise( program_name, modeldb, calendar ) ! Build the FEM function spaces and coordinate fields - call init_fem( mesh_collection, chi_inventory, panel_id_inventory ) + call init_fem( modeldb, chi_inventory, panel_id_inventory ) ! Create and initialise prognostic fields mesh => mesh_collection%get_mesh(prime_mesh_name) diff --git a/applications/coupled/source/driver/init_coupled_mod.X90 b/applications/coupled/source/driver/init_coupled_mod.X90 index 3028d5a06..8715a45a2 100644 --- a/applications/coupled/source/driver/init_coupled_mod.X90 +++ b/applications/coupled/source/driver/init_coupled_mod.X90 @@ -76,6 +76,11 @@ module init_coupled_mod procedure(write_interface), pointer :: tmp_ptr integer(i_def) :: order_h, order_v + integer(i_def) :: coord_system + integer(i_def) :: geometry + integer(i_def) :: topology + real(r_def) :: scaled_radius + type(function_space_type), pointer :: fs call log_event( 'coupled: Initialising app ...', LOG_LEVEL_INFO ) @@ -83,8 +88,12 @@ module init_coupled_mod ! Get the name of the coupling component call modeldb%values%get_value("cpl_name", cpl_component_name) - order_h = modeldb%config%finite_element%element_order_h() - order_v = modeldb%config%finite_element%element_order_v() + order_h = modeldb%config%finite_element%element_order_h() + order_v = modeldb%config%finite_element%element_order_v() + coord_system = modeldb%config%finite_element%coord_system() + geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() + scaled_radius = modeldb%config%planet%scaled_radius() fs => function_space_collection%get_fs(mesh, order_h, order_v, W3) @@ -122,8 +131,10 @@ module init_coupled_mod call depository%get_field( trim(name), field_1_ptr) ! Initialise the values in the field that will be sent to the coupler. ! Set them to the longitude of the cell-centre (converted to degrees) - call invoke(compute_latlon_kernel_type(field_2, field_1_ptr, & - chi, panel_id), & + call invoke(compute_latlon_kernel_type(field_2, field_1_ptr, & + chi, panel_id, geometry, & + topology, coord_system, & + scaled_radius), & inc_a_times_X(radians_to_degrees, field_1_ptr)) ! Add that field to the coupling 2d "send" field collection abs_field_ptr => field_1_ptr diff --git a/applications/io_demo/source/driver/io_demo_driver_mod.f90 b/applications/io_demo/source/driver/io_demo_driver_mod.f90 index 2a9ebe515..c68622381 100644 --- a/applications/io_demo/source/driver/io_demo_driver_mod.f90 +++ b/applications/io_demo/source/driver/io_demo_driver_mod.f90 @@ -176,7 +176,7 @@ subroutine initialise(program_name, modeldb) !======================================================================= ! Build the FEM function spaces and coordinate fields !======================================================================= - call init_fem( mesh_collection, chi_inventory, panel_id_inventory ) + call init_fem( modeldb, chi_inventory, panel_id_inventory ) !======================================================================= ! Setup multifile reading diff --git a/applications/io_demo/source/driver/multifile_io/multifile_io_mod.F90 b/applications/io_demo/source/driver/multifile_io/multifile_io_mod.F90 index f15a5e764..78bb61e9e 100644 --- a/applications/io_demo/source/driver/multifile_io/multifile_io_mod.F90 +++ b/applications/io_demo/source/driver/multifile_io/multifile_io_mod.F90 @@ -159,7 +159,8 @@ subroutine step_multifile_io(modeldb, chi_inventory, panel_id_inventory) allocate(tmp_calendar, source=step_calendar_type(time_origin, time_start)) - call io_context%initialise_xios_context( modeldb%mpi%get_comm(), & + call io_context%initialise_xios_context( modeldb%config, & + modeldb%mpi%get_comm(), & chi, panel_id, & modeldb%clock, tmp_calendar, & before_close, & diff --git a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 index ce9a4a29d..6016b5508 100644 --- a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 +++ b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 @@ -205,7 +205,7 @@ subroutine initialise( program_name, modeldb) !======================================================================= ! Build the FEM function spaces and coordinate fields !======================================================================= - call init_fem( mesh_collection, chi_inventory, panel_id_inventory ) + call init_fem( modeldb, chi_inventory, panel_id_inventory ) !======================================================================= ! Setup general I/O system. diff --git a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 index 8a5506f3b..c73ffb310 100644 --- a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 +++ b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 @@ -166,7 +166,7 @@ subroutine initialise( program_name, modeldb) !======================================================================= ! 2.0 Build the FEM function spaces and coordinate fields !======================================================================= - call init_fem( mesh_collection, chi_inventory, panel_id_inventory ) + call init_fem( modeldb, chi_inventory, panel_id_inventory ) !======================================================================= diff --git a/applications/skeleton/source/driver/skeleton_driver_mod.f90 b/applications/skeleton/source/driver/skeleton_driver_mod.f90 index 7639444dd..2cd538829 100644 --- a/applications/skeleton/source/driver/skeleton_driver_mod.f90 +++ b/applications/skeleton/source/driver/skeleton_driver_mod.f90 @@ -160,7 +160,7 @@ subroutine initialise(program_name, modeldb) ! Build the FEM function spaces and coordinate fields !======================================================================= ! Create FEM specifics (function spaces and chi field) - call init_fem(mesh_collection, chi_inventory, panel_id_inventory) + call init_fem(modeldb, chi_inventory, panel_id_inventory) !======================================================================= ! Create and initialise prognostic fields diff --git a/components/driver/source/driver_fem_mod.f90 b/components/driver/source/driver_fem_mod.f90 index 7ba02690e..e0db7f443 100644 --- a/components/driver/source/driver_fem_mod.f90 +++ b/components/driver/source/driver_fem_mod.f90 @@ -15,8 +15,9 @@ module driver_fem_mod use sci_chi_transform_mod, only: init_chi_transforms, & final_chi_transforms use constants_mod, only: i_def, l_def, str_def + use driver_modeldb_mod, only: modeldb_type + use extrusion_mod, only: TWOD, PRIME_EXTRUSION - use finite_element_config_mod, only: coord_order use field_mod, only: field_type use fs_continuity_mod, only: W0, W2, W3, Wtheta, Wchi, W2v, W2h use function_space_mod, only: function_space_type @@ -35,9 +36,7 @@ module driver_fem_mod LOG_LEVEL_ERROR, & log_scratch_space use mesh_mod, only: mesh_type - use mesh_collection_mod, only: mesh_collection_type - - use base_mesh_config_mod, only: geometry, topology + use mesh_collection_mod, only: mesh_collection implicit none @@ -48,47 +47,55 @@ module driver_fem_mod !> @brief Initialises the coordinate fields (chi) and FEM components. !> - !> @param[in] mesh_collection Collection of all meshes to set up - !! coordinates for + !> @param[in] modeldb Model state object !> @param[in,out] chi_inventory Inventory object, containing all of !! the chi fields indexed by mesh !> @param[in,out] panel_id_inventory Inventory object, containing all of !! the fields with the ID of mesh panels - subroutine init_fem( mesh_collection, chi_inventory, panel_id_inventory ) + subroutine init_fem( modeldb, chi_inventory, panel_id_inventory ) implicit none ! Coordinate field - type(mesh_collection_type), intent(in) :: mesh_collection - type(inventory_by_mesh_type), intent(inout) :: chi_inventory - type(inventory_by_mesh_type), intent(inout) :: panel_id_inventory + type(modeldb_type), intent(in) :: modeldb + + type(inventory_by_mesh_type), intent(inout) :: chi_inventory + type(inventory_by_mesh_type), intent(inout) :: panel_id_inventory character(str_def), allocatable :: all_mesh_names(:) - type(mesh_type), pointer :: mesh => null() - type(mesh_type), pointer :: twod_mesh => null() + type(mesh_type), pointer :: mesh + type(mesh_type), pointer :: twod_mesh type(field_type) :: chi(3) type(field_type) :: panel_id - type(function_space_type), pointer :: fs => null() - integer(kind=i_def) :: chi_space, coord, i + type(function_space_type), pointer :: fs + integer(i_def) :: chi_space, coord, i character(str_def) :: mesh_name + integer(i_def) :: coord_order, geometry, topology + + call log_event( 'FEM specifics: creating function spaces...', & + log_level_info ) + + nullify(mesh, twod_mesh, fs) - call log_event( 'FEM specifics: creating function spaces...', log_level_info ) + coord_order = modeldb%config%finite_element%coord_order() + geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() ! ======================================================================== ! ! Initialise coordinates ! ======================================================================== ! ! Initialise coordinate transformations - call init_chi_transforms( geometry, topology, & - mesh_collection=mesh_collection ) + call init_chi_transforms( geometry, topology, mesh_collection=mesh_collection ) ! To loop through mesh collection, get all mesh names ! Then get mesh from collection using these names all_mesh_names = mesh_collection%get_mesh_names() - call chi_inventory%initialise(name="chi", table_len=SIZE(all_mesh_names)) - call panel_id_inventory%initialise(name="panel_id", table_len=SIZE(all_mesh_names)) + call chi_inventory%initialise(name="chi", table_len=size(all_mesh_names)) + call panel_id_inventory%initialise(name="panel_id", & + table_len=size(all_mesh_names)) ! ======================================================================== ! ! Loop through all 3D meshes @@ -104,24 +111,29 @@ subroutine init_fem( mesh_collection, chi_inventory, panel_id_inventory ) ! Initialise panel ID field object --------------------------------------- twod_mesh => mesh_collection%get_mesh(mesh, TWOD) fs => function_space_collection%get_fs(twod_mesh, 0, 0, W3) - call panel_id%initialise( vector_space = fs, halo_depth = twod_mesh%get_halo_depth() ) + call panel_id%initialise( vector_space=fs, & + halo_depth=twod_mesh%get_halo_depth() ) ! Initialise chi field object -------------------------------------------- if ( coord_order == 0 ) then chi_space = W0 write(log_scratch_space,'(A)') & - 'Computing W0 coordinate fields for ' // trim(mesh_name) // 'mesh' + 'Computing W0 coordinate fields for ' // & + trim(mesh_name) // 'mesh' call log_event( log_scratch_space, log_level_info ) else chi_space = Wchi write(log_scratch_space,'(A)') & - 'Computing Wchi coordinate fields for ' // trim(mesh_name) // 'mesh' + 'Computing Wchi coordinate fields for ' // & + trim(mesh_name) // 'mesh' call log_event( log_scratch_space, log_level_info ) end if - fs => function_space_collection%get_fs(mesh, coord_order, coord_order, chi_space) + fs => function_space_collection%get_fs( mesh, coord_order, & + coord_order, chi_space ) do coord = 1, size(chi) - call chi(coord)%initialise(vector_space = fs, halo_depth = twod_mesh%get_halo_depth() ) + call chi(coord)%initialise( vector_space=fs, & + halo_depth=twod_mesh%get_halo_depth() ) end do ! Set coordinate fields -------------------------------------------------- @@ -140,22 +152,24 @@ subroutine init_fem( mesh_collection, chi_inventory, panel_id_inventory ) end subroutine init_fem !> @brief Initialises the function space chains used in multigrid. - !> @param[in] mesh_collection Collection of all meshes to set up - !! coordinates for - !> @param[in] multigrid_mesh_names Names of the multigrid meshes - subroutine init_function_space_chains( mesh_collection, multigrid_mesh_names ) + !> @param[in] multigrid_mesh_names Names of the multigrid meshes + subroutine init_function_space_chains(multigrid_mesh_names) implicit none - type(mesh_collection_type), intent(in) :: mesh_collection - character(str_def), intent(in) :: multigrid_mesh_names(:) + character(str_def), intent(in) :: multigrid_mesh_names(:) + + type(mesh_type), pointer :: mesh + type(mesh_type), pointer :: twod_mesh + + type(function_space_type), pointer :: fs - type(mesh_type), pointer :: mesh => null() - type(mesh_type), pointer :: twod_mesh => null() - type(function_space_type), pointer :: fs => null() - integer(kind=i_def) :: i + integer(i_def) :: i + + nullify(mesh, twod_mesh, fs) - call log_event( 'FEM specifics: creating function space chains...', LOG_LEVEL_INFO ) + call log_event( 'FEM specifics: creating function space chains...', & + log_level_info ) ! ======================================================================== ! ! Create function space chains @@ -167,7 +181,7 @@ subroutine init_function_space_chains( mesh_collection, multigrid_mesh_names ) w2h_multigrid_function_space_chain = function_space_chain_type() wtheta_multigrid_function_space_chain = function_space_chain_type() - write(log_scratch_space,'(A,I1,A)') & + write(log_scratch_space,'(A,I1,A)') & 'Initialising MultiGrid ', size(multigrid_mesh_names), & '-level function space chain.' call log_event( log_scratch_space, LOG_LEVEL_INFO ) diff --git a/components/driver/source/driver_io_mod.F90 b/components/driver/source/driver_io_mod.F90 index 2beadda81..ba0d98b05 100644 --- a/components/driver/source/driver_io_mod.F90 +++ b/components/driver/source/driver_io_mod.F90 @@ -251,7 +251,8 @@ subroutine init_xios_io_context( context_name, & call alt_panel_id_ptr%copy_field_serial(alt_panel_ids(i)) end do - call io_context%initialise_xios_context( modeldb%mpi%get_comm(), & + call io_context%initialise_xios_context( modeldb%config, & + modeldb%mpi%get_comm(), & chi, panel_id, & modeldb%clock, & modeldb%calendar, & @@ -261,7 +262,8 @@ subroutine init_xios_io_context( context_name, & deallocate(alt_coords) deallocate(alt_panel_ids) else - call io_context%initialise_xios_context( modeldb%mpi%get_comm(), & + call io_context%initialise_xios_context( modeldb%config,& + modeldb%mpi%get_comm(), & chi, panel_id, & modeldb%clock, & modeldb%calendar, & diff --git a/components/lfric-xios/integration-test/lfric_xios_context_test.f90 b/components/lfric-xios/integration-test/lfric_xios_context_test.f90 index c2fbc4f59..cedb3edbd 100644 --- a/components/lfric-xios/integration-test/lfric_xios_context_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_context_test.f90 @@ -32,7 +32,8 @@ program lfric_xios_context_test allocate(io_context) call io_context%initialise( "test_io_context", 1, 10 ) - call io_context%initialise_xios_context( test_db%comm, & + call io_context%initialise_xios_context( test_db%config, & + test_db%comm, & test_db%chi, test_db%panel_id, & test_db%clock, test_db%calendar, & before_close ) diff --git a/components/lfric-xios/integration-test/lfric_xios_cyclic_temporal_test.f90 b/components/lfric-xios/integration-test/lfric_xios_cyclic_temporal_test.f90 index 03f062cbd..ec17738e4 100644 --- a/components/lfric-xios/integration-test/lfric_xios_cyclic_temporal_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_cyclic_temporal_test.f90 @@ -64,7 +64,8 @@ program lfric_xios_cyclic_temporal_test fields_in_file=test_db%temporal_fields ) ) before_close => null() - call io_context%initialise_xios_context( test_db%comm, & + call io_context%initialise_xios_context( test_db%config, & + test_db%comm, & test_db%chi, test_db%panel_id, & test_db%clock, test_db%calendar, & before_close ) diff --git a/components/lfric-xios/integration-test/lfric_xios_temporal_iodef_test.f90 b/components/lfric-xios/integration-test/lfric_xios_temporal_iodef_test.f90 index a2b8cac79..2689e3d27 100644 --- a/components/lfric-xios/integration-test/lfric_xios_temporal_iodef_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_temporal_iodef_test.f90 @@ -58,7 +58,8 @@ program lfric_xios_temporal_iodef_test fields_in_file=test_db%temporal_fields ) ) before_close => null() - call io_context%initialise_xios_context( test_db%comm, & + call io_context%initialise_xios_context( test_db%config, & + test_db%comm, & test_db%chi, test_db%panel_id, & test_db%clock, test_db%calendar, & before_close ) diff --git a/components/lfric-xios/integration-test/lfric_xios_temporal_test.f90 b/components/lfric-xios/integration-test/lfric_xios_temporal_test.f90 index 60df5997e..57bb0d047 100644 --- a/components/lfric-xios/integration-test/lfric_xios_temporal_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_temporal_test.f90 @@ -62,7 +62,8 @@ program lfric_xios_temporal_test fields_in_file=test_db%temporal_fields ) ) before_close => null() - call io_context%initialise_xios_context( test_db%comm, & + call io_context%initialise_xios_context( test_db%config, & + test_db%comm, & test_db%chi, test_db%panel_id, & test_db%clock, test_db%calendar, & before_close ) diff --git a/components/lfric-xios/integration-test/lfric_xios_time_read_test.f90 b/components/lfric-xios/integration-test/lfric_xios_time_read_test.f90 index c26d1c577..c108a2a99 100755 --- a/components/lfric-xios/integration-test/lfric_xios_time_read_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_time_read_test.f90 @@ -31,7 +31,8 @@ program lfric_xios_time_read_test allocate(io_context) call io_context%initialise( "test_io_context", 1, 10 ) - call io_context%initialise_xios_context( test_db%comm, & + call io_context%initialise_xios_context( test_db%config, & + test_db%comm, & test_db%chi, test_db%panel_id, & test_db%clock, test_db%calendar, & before_close ) diff --git a/components/lfric-xios/source/lfric_xios_context_mod.f90 b/components/lfric-xios/source/lfric_xios_context_mod.f90 index 9f951767d..7845afb0a 100644 --- a/components/lfric-xios/source/lfric_xios_context_mod.f90 +++ b/components/lfric-xios/source/lfric_xios_context_mod.f90 @@ -9,6 +9,7 @@ module lfric_xios_context_mod use calendar_mod, only : calendar_type use clock_mod, only : clock_type + use config_mod, only : config_type use constants_mod, only : i_def, & r_second, i_timestep, & l_def @@ -81,6 +82,7 @@ end subroutine initialise_lfric_xios_context !> @brief Set up an XIOS context. !> + !> @param [in] config Configuration object. !> @param [in] communicator MPI communicator used by context. !> @param [in] chi Array of coordinate fields !> @param [in] panel_id Panel ID field @@ -89,7 +91,8 @@ end subroutine initialise_lfric_xios_context !> @param [in] before_close Routine to be called before context closes !> @param [in] alt_coords Array of coordinate fields for alternative meshes !> @param [in] alt_panel_ids Panel ID fields for alternative meshes - subroutine initialise_xios_context( this, communicator, & + subroutine initialise_xios_context( this, & + config, communicator, & chi, panel_id, & model_clock, calendar, & before_close, & @@ -100,6 +103,8 @@ subroutine initialise_xios_context( this, communicator, & implicit none class(lfric_xios_context_type), intent(inout) :: this + + type(config_type), intent(in) :: config type(lfric_comm_type), intent(in) :: communicator type(field_type), intent(in) :: chi(:) type(field_type), intent(in) :: panel_id @@ -134,7 +139,7 @@ subroutine initialise_xios_context( this, communicator, & ! Run XIOS setup routines call init_xios_calendar(model_clock, calendar, zero_start, this%context_clock_step) - call init_xios_dimensions(chi, panel_id, alt_coords, alt_panel_ids) + call init_xios_dimensions(config, chi, panel_id, alt_coords, alt_panel_ids) if (this%filelist%get_length() > 0) call setup_xios_files(this%filelist) if (associated(before_close)) call before_close(model_clock) diff --git a/components/lfric-xios/source/lfric_xios_setup_mod.x90 b/components/lfric-xios/source/lfric_xios_setup_mod.x90 index 9c762d7bb..249d21083 100644 --- a/components/lfric-xios/source/lfric_xios_setup_mod.x90 +++ b/components/lfric-xios/source/lfric_xios_setup_mod.x90 @@ -10,6 +10,7 @@ module lfric_xios_setup_mod use calendar_mod, only: calendar_type use clock_mod, only: clock_type + use config_mod, only: config_type use constants_mod, only: i_def, i_halo_index, i_timestep, & r_def, l_def, str_def, & radians_to_degrees @@ -153,13 +154,16 @@ contains !! of XIOS dimensionality (domains, axes, etc) and initialised the !! corresponding XIOS objects. !> + !> @param[in] config Configuration object !> @param[in] chi Coordinate field !> @param[in] panel_id Field with IDs of mesh panels !> - subroutine init_xios_dimensions(chi, panel_id, alt_coords, alt_panel_ids) + subroutine init_xios_dimensions(config, chi, panel_id, alt_coords, alt_panel_ids) implicit none + type(config_type), intent(in) :: config + ! Arguments type(field_type), intent(in) :: chi(:) type(field_type), intent(in) :: panel_id @@ -170,12 +174,12 @@ contains type(mesh_type), pointer :: mesh => null() ! Initialise XIOS prime mesh - call init_xios_mesh( chi, panel_id, prime_mesh=.true. ) + call init_xios_mesh( config, chi, panel_id, prime_mesh=.true. ) ! Initialise additional meshes if (present(alt_coords) .and. present(alt_panel_ids)) then do i = 1, size(alt_panel_ids) - call init_xios_mesh( alt_coords(i,:), alt_panel_ids(i), prime_mesh=.false. ) + call init_xios_mesh( config, alt_coords(i,:), alt_panel_ids(i), prime_mesh=.false. ) end do end if @@ -193,15 +197,18 @@ contains !! of XIOS dimensionality (domains, axes, etc) and initialised the !! corresponding XIOS objects. !> + !> @param[in] config Configuration object !> @param[in] chi Coordinate field !> @param[in] panel_id Field with IDs of mesh panels !> @param[in] prime_mesh Logical flag denoting if the mesh is the primary !! I/O mesh !> - subroutine init_xios_mesh(chi, panel_id, prime_mesh) + subroutine init_xios_mesh(config, chi, panel_id, prime_mesh) implicit none + type(config_type), intent(in) :: config + ! Arguments type(field_type), intent(in) :: chi(:) type(field_type), intent(in) :: panel_id @@ -262,6 +269,16 @@ contains logical :: mesh_is_prime_mesh + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() + ! Set optional prime_mesh_flag if (present(prime_mesh)) then mesh_is_prime_mesh = prime_mesh @@ -277,7 +294,7 @@ contains r2d = radians_to_degrees else r2d = 1.0_r_def - endif + end if ! Set up fields to hold the output coordinates output_field_fs => function_space_collection%get_fs( mesh, 0, 0, W0 ) @@ -295,7 +312,7 @@ contains r2d = radians_to_degrees else r2d = 1.0_r_def - endif + end if ! Calculate the local size of a W2H fs in order to determine ! how many edge dofs for the current partition @@ -316,7 +333,9 @@ contains call sample_chi(i)%initialise( vector_space = output_field_fs ) end do ! Convert to (X,Y,Z) coordinates - call invoke(nodal_xyz_coordinates_kernel_type(sample_chi, chi, panel_id)) + call invoke(nodal_xyz_coordinates_kernel_type(sample_chi, chi, panel_id, & + geometry, topology, & + coord_system, scaled_radius)) else ! For planar geometries just re-use existing chi which are already (X,Y,Z) do i = 1,3 diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90 b/components/science/source/algorithm/sci_geometric_constants_mod.x90 index 524ee5622..51d23ff55 100644 --- a/components/science/source/algorithm/sci_geometric_constants_mod.x90 +++ b/components/science/source/algorithm/sci_geometric_constants_mod.x90 @@ -15,6 +15,7 @@ module sci_geometric_constants_mod ! Infrastructure + use config_mod, only: config_type use constants_mod, only: i_def, r_def, l_def, str_def use extrusion_mod, only: TWOD, PRIME_EXTRUSION use field_mod, only: field_type @@ -32,8 +33,8 @@ module sci_geometric_constants_mod tik, LPROF ! Configuration - use finite_element_config_mod, only: element_order_h, & - element_order_v + use base_mesh_config_mod, only: geometry_spherical + use finite_element_config_mod, only: coord_system_native implicit none @@ -134,6 +135,7 @@ contains ! ========================================================================== ! !> @brief Private routine for computing longitude and latitude fields + !> @param[in] config Configuration object !> @param[in,out] long_inventory Inventory containing longitude fields !> @param[in,out] lat_inventory Inventory containing latitude fields !> @param[in] mesh Mesh used to determine local mesh for @@ -142,15 +144,15 @@ contains !! longitude and latitude fields for !> @param[in] use_fe Flag to indicate whether to use finite !! element or finite volume cells - subroutine compute_latlon(long_inventory, lat_inventory, mesh, fs_id, use_fe) + subroutine compute_latlon(config, long_inventory, lat_inventory, & + mesh, fs_id, use_fe) - use base_mesh_config_mod, only: f_lat, geometry, & - geometry_spherical - use idealised_config_mod, only: f_lon - use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type + use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type implicit none + type(config_type), intent(in) :: config + type(inventory_by_local_mesh_type), intent(inout) :: long_inventory type(inventory_by_local_mesh_type), intent(inout) :: lat_inventory type(mesh_type), intent(in) :: mesh @@ -168,11 +170,28 @@ contains integer(kind=i_def) :: k_h, k_v integer(tik) :: id + integer(i_def) :: geometry, topology + integer(i_def) :: order_h, order_v + integer(i_def) :: coord_system + real(r_def) :: f_lat, f_lon + real(r_def) :: scaled_radius + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() + + f_lat = config%base_mesh%f_lat() + f_lon = config%idealised%f_lon() + if (use_fe) then - k_h = element_order_h - k_v = element_order_v + k_h = order_h + k_v = order_v else k_h = 0 k_v = 0 @@ -187,9 +206,11 @@ contains if ( geometry == geometry_spherical ) then chi => get_coordinates(mesh%get_id()) panel_id => get_panel_id(mesh%get_id()) - call invoke( compute_latlon_kernel_type(lat, long, chi, panel_id) ) + call invoke( compute_latlon_kernel_type(lat, long, chi, panel_id, & + geometry, topology, & + coord_system, scaled_radius) ) else - call invoke( setval_c(lat, f_lat), & + call invoke( setval_c(lat, f_lat), & setval_c(long, f_lon) ) end if @@ -302,16 +323,18 @@ contains end function get_coordinates !> @brief Returns a pointer to the extended coordinate field array + !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The coordinate field array - function get_extended_coordinates(mesh_id) result(extended_chi) + function get_extended_coordinates(coord_system, mesh_id) result(extended_chi) - use finite_element_config_mod, only: coord_system, coord_system_native use sci_extend_chi_field_kernel_mod, only: extend_chi_field_kernel_type implicit none + integer(kind=i_def), intent(in) :: coord_system integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(field_type), pointer :: extended_chi(:) logical(kind=l_def) :: constant_exists @@ -928,13 +951,16 @@ contains ! ========================================================================== ! !> @brief Returns a pointer to the longitude of finite element DoFs + !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the longitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The longitude field - function get_longitude_fe(space_id, mesh_id) result(long_ptr) + function get_longitude_fe(config, space_id, mesh_id) result(long_ptr) implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -983,8 +1009,8 @@ contains constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.true.) + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.true.) end if call long_inventory%get_field(local_mesh, long_ptr) @@ -992,13 +1018,16 @@ contains end function get_longitude_fe !> @brief Returns a pointer to the longitude of finite volume DoFs + !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the longitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The longitude field - function get_longitude_fv(space_id, mesh_id) result(long_ptr) + function get_longitude_fv(config, space_id, mesh_id) result(long_ptr) implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1041,8 +1070,8 @@ contains constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.false.) + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.false.) end if call long_inventory%get_field(local_mesh, long_ptr) @@ -1050,13 +1079,16 @@ contains end function get_longitude_fv !> @brief Returns a pointer to the latitude of finite element DoFs + !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the latitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The latitude field - function get_latitude_fe(space_id, mesh_id) result(lat_ptr) + function get_latitude_fe(config, space_id, mesh_id) result(lat_ptr) implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1105,8 +1137,8 @@ contains constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.true.) + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.true.) end if call lat_inventory%get_field(local_mesh, lat_ptr) @@ -1114,13 +1146,16 @@ contains end function get_latitude_fe !> @brief Returns a pointer to the latitude of finite volume DoFs + !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the latitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The latitude field - function get_latitude_fv(space_id, mesh_id) result(lat_ptr) + function get_latitude_fv(config, space_id, mesh_id) result(lat_ptr) implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1163,8 +1198,8 @@ contains constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.false.) + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.false.) end if call lat_inventory%get_field(local_mesh, lat_ptr) diff --git a/components/science/source/algorithm/sci_mapping_constants_mod.x90 b/components/science/source/algorithm/sci_mapping_constants_mod.x90 index ffa819aa1..7186fef8f 100644 --- a/components/science/source/algorithm/sci_mapping_constants_mod.x90 +++ b/components/science/source/algorithm/sci_mapping_constants_mod.x90 @@ -199,14 +199,17 @@ contains !> @brief Create the operators for projecting spherical components in !! (W3, W3, Wtheta) to a vector-valued field in W2 + !> @param[in] config Configuration object !> @param[in] mesh The mesh to compute the operators for - subroutine create_spherical_components_to_w2_projection(mesh) + subroutine create_spherical_components_to_w2_projection(config, mesh) use sci_compute_map_u_operators_kernel_mod, & only: compute_map_u_operators_kernel_type implicit none + type(config_type), intent(in) :: config + type(mesh_type), pointer, intent(in) :: mesh integer(kind=i_def) :: mesh_id type(function_space_type), pointer :: w2_fs @@ -248,20 +251,27 @@ contains u_lat_map, & u_up_map, & chi, panel_id, & + config%base_mesh%geometry(), & + config%base_mesh%topology(), & + config%finite_element%coord_system(), & + config%planet%scaled_radius(), & qr) ) end subroutine create_spherical_components_to_w2_projection !> @brief Create the operators for sampling spherical components in !! (W3, W3, Wtheta) to a vector-valued field in W2 + !> @param[in] config Configuration object !> @param[in] mesh The mesh to compute the operators for - subroutine create_spherical_components_to_w2_sample(mesh) + subroutine create_spherical_components_to_w2_sample(config, mesh) use sci_compute_sample_u_ops_kernel_mod, & only: compute_sample_u_ops_kernel_type implicit none + type(config_type), intent(in) :: config + type(mesh_type), pointer, intent(in) :: mesh integer(kind=i_def) :: mesh_id type(function_space_type), pointer :: w2_fs @@ -303,7 +313,11 @@ contains compute_sample_u_ops_kernel_type(u_lon_sample, & u_lat_sample, & u_up_sample, & - chi, panel_id) ) + chi, panel_id, & + config%base_mesh%geometry(), & + config%base_mesh%topology(), & + config%finite_element%coord_system(), & + config%planet%scaled_radius() ) ) if ( LPROF ) call stop_timing( id, 'runtime_constants.mapping' ) @@ -1008,12 +1022,15 @@ contains end function get_u_up_sample !> @brief Returns a pointer to the operator projection from lon dot to W1 + !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The projection operator - function get_project_lon_dot_to_w1(mesh_id) result(proj_op) + function get_project_lon_dot_to_w1(config, mesh_id) result(proj_op) implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(operator_type), pointer :: proj_op @@ -1054,7 +1071,12 @@ contains call invoke( name='proj_lon_dot_to_w1_op', & project_ws_to_w1_operator_kernel_type(proj_op, & chi, panel_id, & - xdirection, qr) ) + xdirection, & + config%base_mesh%geometry(), & + config%base_mesh%topology(), & + config%finite_element%coord_system(), & + config%planet%scaled_radius(), & + qr) ) if ( LPROF ) call stop_timing( id, 'runtime_constants.mapping' ) end if @@ -1065,12 +1087,15 @@ contains end function get_project_lon_dot_to_w1 !> @brief Returns a pointer to the operator projection from lat dot to W1 - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] config Configuration object + !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The projection operator - function get_project_lat_dot_to_w1(mesh_id) result(proj_op) + function get_project_lat_dot_to_w1(config, mesh_id) result(proj_op) implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(operator_type), pointer :: proj_op @@ -1111,7 +1136,12 @@ contains call invoke( name='proj_lat_dot_to_w1_op', & project_ws_to_w1_operator_kernel_type(proj_op, & chi, panel_id, & - ydirection, qr) ) + ydirection, & + config%base_mesh%geometry(), & + config%base_mesh%topology(), & + config%finite_element%coord_system(), & + config%planet%scaled_radius(), & + qr) ) if ( LPROF ) call stop_timing( id, 'runtime_constants.mapping' ) end if @@ -1122,12 +1152,15 @@ contains end function get_project_lat_dot_to_w1 !> @brief Returns a pointer to the operator projection from r dot to W1 - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] config Configuration object + !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The projection operator - function get_project_r_dot_to_w1(mesh_id) result(proj_op) + function get_project_r_dot_to_w1(config, mesh_id) result(proj_op) implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(operator_type), pointer :: proj_op @@ -1166,7 +1199,12 @@ contains call invoke( name='proj_r_dot_to_w1_op', & project_ws_to_w1_operator_kernel_type(proj_op, & chi, panel_id, & - zdirection, qr) ) + zdirection, & + config%base_mesh%geometry(), & + config%base_mesh%topology(), & + config%finite_element%coord_system(), & + config%planet%scaled_radius(), & + qr) ) if ( LPROF ) call stop_timing( id, 'runtime_constants.mapping' ) end if @@ -1177,14 +1215,17 @@ contains end function get_project_r_dot_to_w1 !> @brief Returns the displacement when averaging from W3 to W2 - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] config Configuration object + !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The displacement field used for correcting mappings from W3 to W2 - function get_w3_to_w2_displacement(mesh_id) result(w3_to_w2_displacement) + function get_w3_to_w2_displacement(config, mesh_id) result(w3_to_w2_displacement) use sci_w3_to_w2_displacement_kernel_mod, & only: w3_to_w2_displacement_kernel_type implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(local_mesh_type), pointer :: local_mesh @@ -1229,7 +1270,11 @@ contains call dummy_w3%initialise( w3_k0_fs ) call invoke( setval_c(w3_to_w2_displacement, 0.0_r_def), & w3_to_w2_displacement_kernel_type(w3_to_w2_displacement, & - chi, panel_id, dummy_w3) ) + chi, panel_id, dummy_w3, & + config%base_mesh%geometry(), & + config%base_mesh%topology(), & + config%finite_element%coord_system(), & + config%planet%scaled_radius() ) ) if ( LPROF ) call stop_timing( id, 'runtime_constants.mapping' ) end if diff --git a/components/science/source/kernel/fem/sci_gp_vector_rhs_kernel_mod.F90 b/components/science/source/kernel/fem/sci_gp_vector_rhs_kernel_mod.F90 index 0db2fbe49..38a827c21 100644 --- a/components/science/source/kernel/fem/sci_gp_vector_rhs_kernel_mod.F90 +++ b/components/science/source/kernel/fem/sci_gp_vector_rhs_kernel_mod.F90 @@ -220,7 +220,8 @@ subroutine gp_vector_rhs_code(nlayers, & end do ! Obtain (X,Y,Z) coordinates for converting components of u - call chi2xyz(coords(1), coords(2), coords(3), ipanel, & + call chi2xyz(coords(1), coords(2), coords(3), ipanel, & + geometry, topology, coord_system, scaled_radius, & x_at_quad(1), x_at_quad(2), x_at_quad(3)) u_physical(:) = cart2sphere_vector(x_at_quad, u_at_quad) diff --git a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 index 39ccfe0fb..f4a1bb555 100644 --- a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 +++ b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 @@ -30,15 +30,12 @@ module sci_chi_transform_mod LOG_LEVEL_WARNING use matrix_invert_mod, only : matrix_invert_3x3 -use base_mesh_config_mod, only : geometry, & - geometry_spherical, & - geometry_planar, & - topology, & - topology_fully_periodic -use finite_element_config_mod, only : coord_system, & - coord_system_xyz, & - coord_system_native -use planet_config_mod, only : scaled_radius +! Configuration modules +use base_mesh_config_mod, only: geometry_spherical, & + geometry_planar, & + topology_fully_periodic +use finite_element_config_mod, only: coord_system_xyz, & + coord_system_native implicit none @@ -90,13 +87,14 @@ module sci_chi_transform_mod !! argument, and ideally should only be used for !! unit-testing. !------------------------------------------------------------------------------ -subroutine init_chi_transforms( geometry, topology, & - mesh_collection, & +subroutine init_chi_transforms( geometry, & + topology, & + mesh_collection, & north_pole_arg, equator_lat_arg ) - use local_mesh_mod, only : local_mesh_type - use mesh_collection_mod, only : mesh_collection_type - use mesh_mod, only : mesh_type + use local_mesh_mod, only: local_mesh_type + use mesh_collection_mod, only: mesh_collection_type + use mesh_mod, only: mesh_type implicit none @@ -118,7 +116,6 @@ subroutine init_chi_transforms( geometry, topology, & ! -------------------------------------------------------------------------- ! ! Extract stretching and rotation information from mesh ! -------------------------------------------------------------------------- ! - ! Begin by assuming no stretching and no rotation to_stretch = .false. to_rotate = .false. @@ -187,7 +184,7 @@ subroutine init_chi_transforms( geometry, topology, & LOG_LEVEL_WARNING & ) end if - end if + end if ! present(mesh_collection) if (present(north_pole_arg)) north_pole = north_pole_arg if (present(equator_lat_arg)) equatorial_latitude = equator_lat_arg @@ -251,7 +248,9 @@ end subroutine final_chi_transforms !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- -subroutine chi2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) +subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, coord_system, scaled_radius, & + x, y, z ) implicit none @@ -261,6 +260,11 @@ subroutine chi2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) real(kind=r_def) :: xyz(3) + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then ! chi already uses (geocentric) Cartesian coordinates x = chi_1 @@ -333,7 +337,9 @@ end subroutine chi2xyz !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- -subroutine chir2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) +subroutine chir2xyz( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, coord_system, & + x, y, z ) implicit none @@ -343,6 +349,10 @@ subroutine chir2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) real(kind=r_def) :: xyz(3) + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + if (coord_system == coord_system_xyz .or. geometry == geometry_planar) then ! chi already uses (geocentric) Cartesian coordinates x = chi_1 @@ -412,7 +422,9 @@ end subroutine chir2xyz !! @param[out] latitude The second coordinate field out (latitude) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2llr(chi_1, chi_2, chi_3, panel_id, lon, lat, radius) +subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, coord_system, scaled_radius, & + lon, lat, radius ) implicit none @@ -422,6 +434,11 @@ subroutine chi2llr(chi_1, chi_2, chi_3, panel_id, lon, lat, radius) real(kind=r_def) :: xyz(3) + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then ! chi uses (geocentric) Cartesian coordinates call xyz2llr(chi_1, chi_2, chi_3, lon, lat, radius) @@ -484,7 +501,9 @@ end subroutine chi2llr !! @param[out] beta The second coordinate field out (beta) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2abr(chi_1, chi_2, chi_3, panel_id, alpha, beta, radius) +subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, coord_system, scaled_radius, & + alpha, beta, radius ) implicit none @@ -494,10 +513,15 @@ subroutine chi2abr(chi_1, chi_2, chi_3, panel_id, alpha, beta, radius) real(kind=r_def) :: xyz(3) + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + if (topology /= topology_fully_periodic .or. geometry /= geometry_spherical) then - call log_event( & - 'chi2abr can only be used on cubed-sphere meshes', LOG_LEVEL_ERROR & - ) + + call log_event( 'chi2abr can only be used on cubed-sphere meshes', & + LOG_LEVEL_ERROR ) else if (coord_system == coord_system_native) then alpha = chi_1 @@ -531,6 +555,7 @@ end subroutine chi2abr !! native Cartesian coordinates to the physical Cartesian coordinates !------------------------------------------------------------------------------- function get_mesh_rotation_matrix() result(rot_mat) + implicit none real(kind=r_def) :: rot_mat(3,3) @@ -543,6 +568,7 @@ end function get_mesh_rotation_matrix !! physical Cartesian coordinates to native Cartesian coordinates !------------------------------------------------------------------------------- function get_inverse_mesh_rotation_matrix() result(rot_mat) + implicit none real(kind=r_def) :: rot_mat(3,3) @@ -554,6 +580,7 @@ end function get_inverse_mesh_rotation_matrix !> @brief Returns the Schmidt transform stretch factor !------------------------------------------------------------------------------- function get_stretch_factor() result(stretch_factor_out) + implicit none real(kind=r_def) :: stretch_factor_out @@ -565,6 +592,7 @@ end function get_stretch_factor !> @brief Returns whether coordinates are rotated !------------------------------------------------------------------------------- function get_to_rotate() result(to_rotate_out) + implicit none logical(kind=l_def) :: to_rotate_out @@ -576,6 +604,7 @@ end function get_to_rotate !> @brief Returns whether coordinates are stretched !------------------------------------------------------------------------------- function get_to_stretch() result(to_stretch_out) + implicit none logical(kind=l_def) :: to_stretch_out diff --git a/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 b/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 index 1ca3f2776..bac76055b 100644 --- a/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 @@ -8,9 +8,10 @@ module sci_compute_latlon_kernel_mod use argument_mod, only: arg_type, func_type, & - GH_FIELD, GH_REAL, & + GH_FIELD, GH_SCALAR, & + GH_INTEGER, GH_REAL, & GH_WRITE, GH_READ, & - ANY_SPACE_1, & + ANY_SPACE_1, & ANY_DISCONTINUOUS_SPACE_3, & ANY_SPACE_9, GH_BASIS, & CELL_COLUMN, GH_EVALUATOR @@ -29,12 +30,17 @@ module sci_compute_latlon_kernel_mod !> type, public, extends(kernel_type) :: compute_latlon_kernel_type private - type(arg_type) :: meta_args(4) = (/ & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & + type(arg_type) :: meta_args(8) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & + arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & 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, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius /) + type(func_type) :: meta_funcs(1) = (/ & func_type(ANY_SPACE_9, GH_BASIS) & /) @@ -61,6 +67,10 @@ module sci_compute_latlon_kernel_mod !> @param[in] chi_2 Second component of the coordinate field !> @param[in] chi_3 Third component of the coordinate field !> @param[in] panel_id A field giving the ID for mesh panels +!> @param[in] geometry +!> @param[in] topology +!> @param[in] coord_system +!> @param[in] scaled_radius !> @param[in] ndf_x Number of degrees of freedom per cell for height !> @param[in] undf_x Number of unique degrees of freedom for height !> @param[in] map_x Dofmap for the cell at the base of the column for height @@ -75,6 +85,8 @@ subroutine compute_latlon_code(nlayers, & latitude, longitude, & chi_1, chi_2, chi_3, & panel_id, & + geometry, topology, & + coord_system, scaled_radius, & ndf_x, undf_x, map_x, & ndf_chi, undf_chi, map_chi, & basis_chi, & @@ -93,6 +105,11 @@ subroutine compute_latlon_code(nlayers, & 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 + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + integer(kind=i_def), intent(in) :: coord_system + real(kind=r_def), intent(in) :: scaled_radius + integer(kind=i_def), dimension(ndf_x), intent(in) :: map_x integer(kind=i_def), dimension(ndf_chi), intent(in) :: map_chi integer(kind=i_def), dimension(ndf_pid), intent(in) :: map_pid @@ -112,7 +129,9 @@ subroutine compute_latlon_code(nlayers, & coords(2) = coords(2) + chi_2(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) coords(3) = coords(3) + chi_3(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) end do - call chi2llr(coords(1), coords(2), coords(3), ipanel, lon, lat, radius) + call chi2llr(coords(1), coords(2), coords(3), ipanel, & + geometry, topology, coord_system, scaled_radius, & + lon, lat, radius) latitude(map_x(df_x) + k) = lat longitude(map_x(df_x) + k) = lon end do diff --git a/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 b/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 index c3558e2d9..c4155b3dd 100644 --- a/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 @@ -11,8 +11,9 @@ module sci_nodal_xyz_coordinates_kernel_mod use kernel_mod, only : kernel_type use argument_mod, only : arg_type, func_type, & - GH_FIELD, GH_WRITE, & - GH_READ, GH_REAL, & + GH_SCALAR, GH_FIELD, & + GH_WRITE, GH_READ, & + GH_REAL, GH_INTEGER, & ANY_SPACE_9, ANY_SPACE_1, & ANY_DISCONTINUOUS_SPACE_3, & GH_BASIS, CELL_COLUMN, & @@ -28,10 +29,14 @@ module sci_nodal_xyz_coordinates_kernel_mod ! The type declaration for the kernel. Contains the metadata needed by the Psy layer type, public, extends(kernel_type) :: nodal_xyz_coordinates_kernel_type private - type(arg_type) :: meta_args(3) = (/ & - arg_type(GH_FIELD*3, GH_REAL, GH_WRITE, ANY_SPACE_1), & - 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(arg_type) :: meta_args(7) = (/ & + arg_type(GH_FIELD*3, GH_REAL, GH_WRITE, ANY_SPACE_1), & + 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_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius /) type(func_type) :: meta_funcs(1) = (/ & func_type(ANY_SPACE_9, GH_BASIS) & @@ -73,6 +78,8 @@ subroutine nodal_xyz_coordinates_code(nlayers, & nodal_x, nodal_y, nodal_z, & chi1, chi2, chi3, & panel_id, & + geometry, topology, & + coord_system, scaled_radius, & ndf_x, undf_x, map_x, & ndf_chi, undf_chi, map_chi, & basis_chi, & @@ -92,6 +99,11 @@ subroutine nodal_xyz_coordinates_code(nlayers, & real(kind=r_def), dimension(undf_pid), intent(in) :: panel_id real(kind=r_def), dimension(1,ndf_chi,ndf_x), intent(in) :: basis_chi + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + ! Internal variables integer(kind=i_def) :: df_x, df_chi, k, ipanel real(kind=r_def) :: coords(3) @@ -107,11 +119,13 @@ subroutine nodal_xyz_coordinates_code(nlayers, & coords(3) = coords(3) + chi3(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) end do - call chi2xyz(coords(1), coords(2), & - coords(3), ipanel, & - nodal_x(map_x(df_x)+k), & - nodal_y(map_x(df_x)+k), & - nodal_z(map_x(df_x)+k) ) + call chi2xyz( coords(1), coords(2), & + coords(3), ipanel, & + geometry, topology, & + coord_system, scaled_radius, & + nodal_x(map_x(df_x)+k), & + nodal_y(map_x(df_x)+k), & + nodal_z(map_x(df_x)+k) ) end do end do diff --git a/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 index a78f203d4..1cb26d73c 100644 --- a/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 @@ -16,7 +16,8 @@ module sci_compute_map_u_operators_kernel_mod use argument_mod, only : arg_type, func_type, & - GH_FIELD, GH_REAL, & + GH_FIELD, GH_SCALAR, & + GH_REAL, GH_INTEGER, & GH_OPERATOR, & GH_INC, GH_READ, GH_WRITE, & ANY_SPACE_9, & @@ -40,13 +41,17 @@ module sci_compute_map_u_operators_kernel_mod !> type, public, extends(kernel_type) :: compute_map_u_operators_kernel_type private - type(arg_type) :: meta_args(5) = (/ & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, W3), & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, W3), & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, WTHETA), & - 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(arg_type) :: meta_args(9) = (/ & + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, W3), & + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, W3), & + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, WTHETA), & + 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_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius + /) type(func_type) :: meta_funcs(4) = (/ & func_type(W2, GH_BASIS), & func_type(W3, GH_BASIS), & @@ -104,6 +109,8 @@ subroutine compute_map_u_operators_code(cell, nlayers, ncell_3d_1, & u_lon_op, ncell_3d_2, u_lat_op, & ncell_3d_3, u_up_op, & chi_sph_1, chi_sph_2, chi_sph_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & ndf_w2, basis_w2, & ndf_w3, basis_w3, & ndf_wt, basis_wt, & @@ -117,11 +124,7 @@ subroutine compute_map_u_operators_code(cell, nlayers, ncell_3d_1, & use sci_coordinate_jacobian_mod, only : coordinate_jacobian use coord_transform_mod, only : sphere2cart_vector - use finite_element_config_mod, only: coord_system - use base_mesh_config_mod, only: geometry, topology, & - geometry_spherical, & - geometry_planar - use planet_config_mod, only: scaled_radius + use base_mesh_config_mod, only: geometry_spherical, geometry_planar implicit none @@ -151,6 +154,11 @@ subroutine compute_map_u_operators_code(cell, nlayers, ncell_3d_1, & real(kind=r_def), dimension(nqp_h), intent(in) :: wqp_h real(kind=r_def), dimension(nqp_v), intent(in) :: wqp_v + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + ! Internal variables integer(kind=i_def) :: df, df2, df3, dft integer(kind=i_def) :: k, ik, qp1, qp2, ipanel @@ -208,8 +216,10 @@ subroutine compute_map_u_operators_code(cell, nlayers, ncell_3d_1, & llr(:) = 0.0_r_def - call chi2llr(coords(1), coords(2), coords(3), & - ipanel, llr(1), llr(2), llr(3)) + call chi2llr( coords(1), coords(2), coords(3), & + ipanel, geometry, topology, & + coord_system, scaled_radius, & + llr(1), llr(2), llr(3) ) end if diff --git a/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 index 4bfbb79e1..eb446602c 100644 --- a/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 @@ -15,7 +15,8 @@ module sci_compute_sample_u_ops_kernel_mod use argument_mod, only : arg_type, func_type, & - GH_FIELD, GH_REAL, & + GH_FIELD, GH_SCALAR, & + GH_REAL, GH_INTEGER, & GH_OPERATOR, & GH_INC, GH_READ, GH_WRITE, & ANY_DISCONTINUOUS_SPACE_3, & @@ -32,11 +33,7 @@ module sci_compute_sample_u_ops_kernel_mod use coord_transform_mod, only : sphere2cart_vector use reference_element_mod, only : W, S, N, E, T, B - use finite_element_config_mod, only: coord_system - use base_mesh_config_mod, only: geometry, topology, & - geometry_spherical, & - geometry_planar - use planet_config_mod, only: scaled_radius + use base_mesh_config_mod, only: geometry_spherical, geometry_planar implicit none @@ -50,18 +47,22 @@ module sci_compute_sample_u_ops_kernel_mod !> type, public, extends(kernel_type) :: compute_sample_u_ops_kernel_type private - type(arg_type) :: meta_args(5) = (/ & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, W3), & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, W3), & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, WTHETA), & - arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & - arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3) & + type(arg_type) :: meta_args(9) = (/ & + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, W3), & + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, W3), & + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, WTHETA), & + arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius /) - type(func_type) :: meta_funcs(1) = (/ & - func_type(Wchi, GH_BASIS, GH_DIFF_BASIS) & + type(func_type) :: meta_funcs(1) = (/ & + func_type(Wchi, GH_BASIS, GH_DIFF_BASIS) & /) - type(reference_element_data_type), dimension(1) :: & - meta_reference_element = & + type(reference_element_data_type), dimension(1) :: & + meta_reference_element = & (/ reference_element_data_type(normals_to_faces) /) integer :: operates_on = CELL_COLUMN integer :: gh_shape = GH_EVALUATOR @@ -110,6 +111,8 @@ subroutine compute_sample_u_ops_code( col, nlayers, & ncell_3d_3, u_rad_op, & chi1, chi2, chi3, & panel_id, & + geometry, topology, & + coord_system, scaled_radius, & ndf_w2b, ndf_w3, ndf_wt, & ndf_chi, undf_chi, map_chi, & chi_basis, chi_diff_basis, & @@ -143,6 +146,11 @@ subroutine compute_sample_u_ops_code( col, nlayers, & real(kind=r_def), dimension(ncell_3d_2,ndf_w2b,ndf_w3), intent(inout) :: u_lat_op real(kind=r_def), dimension(ncell_3d_3,ndf_w2b,ndf_wt), intent(inout) :: u_rad_op + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + integer(kind=i_def), intent(in) :: coord_system + real(kind=r_def), intent(in) :: scaled_radius + ! Internal variables integer(kind=i_def) :: df_w2, df_wt, df_chi, k, ipanel, cell_3d real(kind=r_def), dimension(3,3,ndf_w2b) :: jacobian, jac_inv @@ -249,8 +257,9 @@ subroutine compute_sample_u_ops_code( col, nlayers, & end do ! Calculate (lon,lat,r) coordinates for W2 points in this cell - call chi2llr(chi1_w2(df_w2), chi2_w2(df_w2), chi3_w2(df_w2), ipanel, & - llr(1), llr(2), llr(3)) + call chi2llr( chi1_w2(df_w2), chi2_w2(df_w2), chi3_w2(df_w2), ipanel, & + geometry, topology, coord_system, scaled_radius, & + llr(1), llr(2), llr(3) ) ! Rotate (lon,lat,r) unit vectors to (X,Y,Z) coordinates lon_vector_xyz(df_w2,:) = sphere2cart_vector(lon_vector_llr, llr) diff --git a/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 index fece67189..000da1b41 100644 --- a/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 @@ -10,9 +10,10 @@ module sci_convert_phys_to_hdiv_kernel_mod use argument_mod, only : arg_type, func_type, & - GH_FIELD, GH_REAL, & + GH_FIELD, GH_SCALAR, & + GH_REAL, GH_INTEGER, & GH_WRITE, GH_READ, & - ANY_SPACE_9, GH_SCALAR, & + ANY_SPACE_9, & ANY_DISCONTINUOUS_SPACE_3, & GH_BASIS, GH_DIFF_BASIS, & CELL_COLUMN, GH_EVALUATOR, & @@ -21,6 +22,8 @@ module sci_convert_phys_to_hdiv_kernel_mod use fs_continuity_mod, only : W2 use kernel_mod, only : kernel_type + use base_mesh_config_mod, only: geometry_spherical + implicit none private @@ -33,14 +36,17 @@ module sci_convert_phys_to_hdiv_kernel_mod !> type, public, extends(kernel_type) :: convert_phys_to_hdiv_kernel_type private - type(arg_type) :: meta_args(7) = (/ & + type(arg_type) :: meta_args(10) = (/ & arg_type(GH_FIELD, GH_REAL, GH_WRITE, W2), & arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & 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_SCALAR, GH_INTEGER, GH_READ) & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius /) type(func_type) :: meta_funcs(2) = (/ & func_type(W2, GH_BASIS), & @@ -93,6 +99,10 @@ subroutine convert_phys_to_hdiv_code( nlayers, & chi_3, & panel_id, & geometry, & + + topology, & + coord_system, & + scaled_radius, & ndf_w2, & undf_w2, & map_w2, & @@ -111,18 +121,13 @@ subroutine convert_phys_to_hdiv_code( nlayers, & pointwise_coordinate_jacobian_inverse use coord_transform_mod, only : sphere2cart_vector - use base_mesh_config_mod, only: topology, & - geometry_spherical - use finite_element_config_mod, only: coord_system - use planet_config_mod, only: scaled_radius - implicit none ! Arguments integer(kind=i_def), intent(in) :: nlayers integer(kind=i_def), intent(in) :: ndf_w2, ndf_pid, ndf_chi integer(kind=i_def), intent(in) :: undf_w2, undf_pid, undf_chi - integer(kind=i_def), intent(in) :: geometry +! integer(kind=i_def), intent(in) :: geometry integer(kind=i_def), intent(in) :: map_w2(ndf_w2) integer(kind=i_def), intent(in) :: map_chi(ndf_chi) @@ -141,6 +146,11 @@ subroutine convert_phys_to_hdiv_code( nlayers, & real(kind=r_def), intent(in) :: chi_2(undf_chi) real(kind=r_def), intent(in) :: chi_3(undf_chi) + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + ! Internal variables integer(kind=i_def) :: df_w2, df_chi, k, ipanel real(kind=r_def) :: detj @@ -195,7 +205,11 @@ subroutine convert_phys_to_hdiv_code( nlayers, & ! Convert coordinates from whatever coordinate system the model uses ! into spherical-polar coordinates call chi2llr(coords(1), coords(2), coords(3), & - ipanel, llr(1), llr(2), llr(3)) + ipanel, geometry,& + topology,& + coord_system,& + scaled_radius,& +llr(1), llr(2), llr(3)) u_spherical(1) = u_lon(map_w2(df_w2) + k) u_spherical(2) = u_lat(map_w2(df_w2) + k) diff --git a/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 index 607c2782b..1a7e95f85 100644 --- a/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 @@ -26,6 +26,8 @@ module sci_project_ws_to_w1_operator_kernel_mod use fs_continuity_mod, only : W1, Wchi use log_mod, only : log_event, LOG_LEVEL_ERROR +use base_mesh_config_mod, only: geometry_spherical, geometry_planar + implicit none private @@ -35,12 +37,16 @@ module sci_project_ws_to_w1_operator_kernel_mod !> The type declaration for the kernel. Contains the metadata needed by the PSy layer type, public, extends(kernel_type) :: project_ws_to_w1_operator_kernel_type private - type(arg_type) :: meta_args(4) = (/ & + type(arg_type) :: meta_args(8) = (/ & arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W1, ANY_DISCONTINUOUS_SPACE_1), & arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & - arg_type(GH_SCALAR, GH_INTEGER, GH_READ) & - /) + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius + /) type(func_type) :: meta_funcs(3) = (/ & func_type(W1, GH_BASIS), & func_type(ANY_DISCONTINUOUS_SPACE_1, GH_BASIS), & @@ -95,6 +101,10 @@ subroutine project_ws_to_w1_operator_code( cell, nlayers, & chi1, chi2, chi3, & panel_id, & direction, & + geometry, & + topology, & + coord_system, & + scaled_radius, & ndf_w1, basis_w1, & ndf_ws, basis_ws, & ndf_wx, undf_wx, map_wx, & @@ -107,12 +117,6 @@ subroutine project_ws_to_w1_operator_code( cell, nlayers, & use sci_chi_transform_mod, only: chi2llr use coord_transform_mod, only: sphere2cart_vector - use base_mesh_config_mod, only: geometry, topology, & - geometry_spherical, & - geometry_planar - use finite_element_config_mod, only: coord_system - use planet_config_mod, only: scaled_radius - implicit none ! Arguments @@ -136,6 +140,11 @@ subroutine project_ws_to_w1_operator_code( cell, nlayers, & real(kind=r_def), intent(in) :: wqp_h(nqp_h) real(kind=r_def), intent(in) :: wqp_v(nqp_v) + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + ! Internal variables integer(kind=i_def) :: df_x, df_s, df_1, ik, k, qp_h, qp_v real(kind=r_def), dimension(ndf_wx) :: chi1_e, chi2_e, chi3_e @@ -173,7 +182,11 @@ subroutine project_ws_to_w1_operator_code( cell, nlayers, & llr(:) = 0.0_r_def call chi2llr(coords(1), coords(2), coords(3), & - ipanel, llr(1), llr(2), llr(3)) + ipanel, geometry,& + topology,& + coord_system,& + scaled_radius,& +llr(1), llr(2), llr(3)) end if call pointwise_coordinate_jacobian(coord_system, geometry, & diff --git a/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 index 64cc4ad24..b813cb189 100644 --- a/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 @@ -12,7 +12,8 @@ module sci_w3_to_w2_displacement_kernel_mod use argument_mod, only : arg_type, func_type, & - GH_FIELD, GH_REAL, & + GH_FIELD, GH_SCALAR, & + GH_REAL, GH_INTEGER, & GH_READ, GH_INC, & ANY_DISCONTINUOUS_SPACE_3, & GH_BASIS, GH_EVALUATOR, & @@ -33,11 +34,15 @@ module sci_w3_to_w2_displacement_kernel_mod !> The type declaration for the kernel. Contains the metadata needed by the PSy layer type, public, extends(kernel_type) :: w3_to_w2_displacement_kernel_type private - type(arg_type) :: meta_args(4) = (/ & + type(arg_type) :: meta_args(8) = (/ & arg_type(GH_FIELD, GH_REAL, GH_INC, W2H), & arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & - arg_type(GH_FIELD, GH_REAL, GH_READ, W3) & + arg_type(GH_FIELD, GH_REAL, GH_READ, W3), & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & + arg_type(GH_SCALAR, GH_REAL, GH_READ) & /) type(func_type) :: meta_funcs(1) = (/ & func_type(Wchi, GH_BASIS) & @@ -88,6 +93,10 @@ subroutine w3_to_w2_displacement_code( nlayers, & chi_3, & panel_id, & dummy_w3, & + geometry, & + topology, & + coord_system, & + scaled_radius,& ndf_w2h, & undf_w2h, & map_w2h, & @@ -127,6 +136,11 @@ subroutine w3_to_w2_displacement_code( nlayers, & real(kind=r_def), intent(in) :: basis_chi_w2h(1,ndf_chi,ndf_w2h) real(kind=r_def), intent(in) :: basis_chi_w3(1,ndf_chi,ndf_w3) + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + integer(kind=i_def), intent(in) :: coord_system + real(kind=r_def), intent(in) :: scaled_radius + ! Vertical cell index integer(kind=i_def) :: df_w2h, df_w3, df_chi integer(kind=i_def) :: ipanel @@ -157,6 +171,10 @@ subroutine w3_to_w2_displacement_code( nlayers, & basis_chi_w3(1,df_chi,df_w3) * chi_3(map_chi(df_chi)) end do call chi2abr(chi1_at_dof, chi2_at_dof, chi3_at_dof, ipanel, & + geometry, & + topology, & + coord_system, & + scaled_radius,& alpha_w3, beta_w3, dummy_r) ! W2H points --------------------------------------------------------------- @@ -175,6 +193,10 @@ subroutine w3_to_w2_displacement_code( nlayers, & basis_chi_w2h(1,df_chi,df_w2h) * chi_3(map_chi(df_chi)) end do call chi2abr(chi1_at_dof, chi2_at_dof, chi3_at_dof, ipanel, & + geometry, & + topology, & + coord_system, & + scaled_radius,& alpha_w2h(df_w2h), beta_w2h(df_w2h), dummy_r) end do diff --git a/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf b/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf index fd1f60bbd..6e63f65d9 100644 --- a/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf @@ -8,7 +8,15 @@ module chi_transform_mod_test use, intrinsic :: iso_fortran_env, only : real64 - use constants_mod, only : i_def, r_def, str_long, PI + use constants_mod, only : i_def, r_def, str_long, PI, rmdi + + use base_mesh_config_mod, only: geometry_spherical, & + geometry_planar, & + topology_fully_periodic, & + topology_non_periodic + + use finite_element_config_mod, only: coord_system_native, & + coord_system_xyz use funit @@ -44,6 +52,13 @@ module chi_transform_mod_test real(r_def) :: target_chi_1 real(r_def) :: target_chi_2 real(r_def) :: target_chi_3 + + + integer(i_def) :: src_coord_system + integer(i_def) :: topology + integer(i_def) :: geometry + real(r_def) :: scaled_radius + contains procedure setUp procedure tearDown @@ -51,7 +66,6 @@ module chi_transform_mod_test end type chi_transform_mod_test_type ! Add my own parameters for the different coordinate system cases - ! This is done here because it is before the feign_config is initialised integer(i_def), parameter :: ABH = 1 integer(i_def), parameter :: LLH = 2 integer(i_def), parameter :: XYZ = 3 @@ -90,30 +104,30 @@ contains class( chi_parameters_type ), intent( in ) :: this character(:), allocatable :: output_string - character(str_long) :: source_string, target_string + character(:), allocatable :: source_string, target_string select case ( this%source_coord_system ) case ( XYZ ) - write( source_string, '(A)') 'XYZ' + source_string = 'XYZ' case ( LLH ) - write( source_string, '(A)') 'LLH' + source_string = 'LLH' case ( ABH ) - write( source_string, '(A)') 'ABH' + source_string = 'ABH' case ( LLH_rot ) - write( source_string, '(A)') 'LLH rot' + source_string = 'LLH rot' case ( ABH_stretch_rot ) - write( source_string, '(A)') 'ABH stretch+rot' + source_string = 'ABH stretch+rot' end select select case ( this%target_coord_system ) case ( XYZ ) - write( target_string, '(A)') 'XYZ' + target_string = 'XYZ' case ( LLH ) - write( target_string, '(A)') 'LLH' + target_string = 'LLH' case ( ABH ) - write( target_string, '(A)') 'ABH' + target_string = 'ABH' case ( R2XYZ ) - write( target_string, '(A)') 'R2XYZ' + target_string = 'R2XYZ' end select output_string = trim( source_string // '2' // target_string ) @@ -193,13 +207,13 @@ contains chi_parameters_type(LLH, XYZ, panel_id, & lon, lat, height, & X, Y, Z), & - chi_parameters_type(LLH_rot, LLH, panel_id, & + chi_parameters_type(LLH_rot, LLH, panel_id, &!!!!!!!F lon_rot, lat_rot, height, & lon, lat, radius), & - chi_parameters_type(LLH_rot, XYZ, panel_id, & + chi_parameters_type(LLH_rot, XYZ, panel_id, &!!!! F lon_rot, lat_rot, height, & X, Y, Z), & - chi_parameters_type(XYZ, ABH, panel_id, & + chi_parameters_type(XYZ, ABH, panel_id, &!! Abort X, Y, Z, & alpha, beta, radius), & chi_parameters_type(XYZ, LLH, panel_id, & @@ -221,82 +235,90 @@ contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine setUp( this ) - use base_mesh_config_mod, only : geometry_spherical, & - geometry_planar, & - topology_fully_periodic, & - topology_non_periodic - use extrusion_config_mod, only : method_uniform, & - stretching_method_linear - use finite_element_config_mod, only : cellshape_quadrilateral, & - coord_system_native, & - coord_system_xyz - use feign_config_mod, only : feign_base_mesh_config, & - feign_extrusion_config, & - feign_finite_element_config, & - feign_planet_config - use sci_chi_transform_mod, only : init_chi_transforms +!!$ use feign_config_mod, only : feign_base_mesh_config, & +!!$ feign_extrusion_config, & +!!$ feign_finite_element_config, & +!!$ feign_planet_config + + use sci_chi_transform_mod, only: init_chi_transforms + +!!$ use base_mesh_config_mod, only: geometry_spherical, & +!!$ geometry_planar, & +!!$ topology_fully_periodic, & +!!$ topology_non_periodic +!!$ +!!$ use finite_element_config_mod, only: coord_system_native, & +!!$ coord_system_xyz implicit none class(chi_transform_mod_test_type), intent(inout) :: this - integer(i_def) :: coord_system, topology +! integer(i_def) :: coord_system, topology real(r_def) :: north_pole(2), equatorial_latitude - call feign_extrusion_config( method=method_uniform, & - planet_radius=planet_radius, & - domain_height=10.0_r_def, & - number_of_layers=5_i_def, & - stretching_method=stretching_method_linear, & - stretching_height=15.0_r_def, & - eta_values=(/0.5_r_def/) ) +!!$ call feign_extrusion_config( method=method_uniform, & +!!$ planet_radius=planet_radius, & +!!$ domain_height=10.0_r_def, & +!!$ number_of_layers=5_i_def, & +!!$ stretching_method=stretching_method_linear, & +!!$ stretching_height=15.0_r_def, & +!!$ eta_values=(/0.5_r_def/) ) select case ( this%source_coord_system ) case ( XYZ ) - coord_system = coord_system_xyz - topology = topology_fully_periodic + this%src_coord_system = coord_system_xyz + this%topology = topology_fully_periodic + case ( LLH, LLH_rot ) - coord_system = coord_system_native - topology = topology_non_periodic + this%src_coord_system = coord_system_native + this%topology = topology_non_periodic +! this%topology = topology_fully_periodic + case ( ABH, ABH_stretch_rot ) - coord_system = coord_system_native - topology = topology_fully_periodic + this%src_coord_system = coord_system_native + this%topology = topology_fully_periodic end select - call feign_base_mesh_config( file_prefix='foo', & - prime_mesh_name='unit_test', & - geometry=geometry_spherical, & - prepartitioned=.false., & - topology=topology, & - fplane=.false., f_lat_deg=0.0_r_def ) + this%geometry = geometry_spherical + this%scaled_radius = planet_radius*scaling + +!!$ call feign_base_mesh_config( file_prefix='foo', & +!!$ prime_mesh_name='unit_test', & +!!$ geometry=geometry_spherical, & +!!$ prepartitioned=.false., & +!!$ topology=topology, & +!!$ fplane=.false., f_lat_deg=0.0_r_def ) - call feign_finite_element_config( & - cellshape=cellshape_quadrilateral, & - element_order_h=0_i_def, & - element_order_v=0_i_def, & - rehabilitate=.true., & - coord_order=0_i_def, & - coord_system=coord_system ) +!!$ call feign_finite_element_config( & +!!$ cellshape=cellshape_quadrilateral, & +!!$ element_order_h=0_i_def, & +!!$ element_order_v=0_i_def, & +!!$ rehabilitate=.true., & +!!$ coord_order=0_i_def, & +!!$ coord_system=coord_system ) - call feign_planet_config( scaling_factor=scaling ) +!! call feign_planet_config( scaling_factor=scaling ) if ( this%source_coord_system == LLH_rot ) then north_pole(1) = PI/2.0_r_def north_pole(2) = 0.0_r_def - call init_chi_transforms(geometry_spherical, & - topology, & + call init_chi_transforms(this%geometry, & + this%topology, & north_pole_arg=north_pole) else if ( this%source_coord_system == ABH_stretch_rot ) then north_pole(1) = -PI/2.0_r_def north_pole(2) = 0.0_r_def equatorial_latitude = PI/6.0_r_def - call init_chi_transforms(geometry_spherical, & - topology, & + call init_chi_transforms(this%geometry, & + this%topology, & north_pole_arg=north_pole, & equator_lat_arg=equatorial_latitude) else ! Non-rotated or stretched case - call init_chi_transforms(geometry_spherical, topology) + call init_chi_transforms(this%geometry, & + this%topology) + end if end subroutine setUp @@ -321,7 +343,17 @@ contains subroutine test_all( this ) use sci_chi_transform_mod, only : chi2abr, chi2llr, chi2xyz, chir2xyz - use finite_element_config_mod, only : coord_system +!!$ use finite_element_config_mod, only : coord_system +!!$ use base_mesh_config_mod, only : geometry_spherical, & +!!$ geometry_planar, & +!!$ topology_fully_periodic, & +!!$ topology_non_periodic +!!$ use extrusion_config_mod, only : method_uniform, & +!!$ stretching_method_linear +!!$ use finite_element_config_mod, only : cellshape_quadrilateral, & +!!$ coord_system_native, & +!!$ coord_system_xyz + implicit none @@ -329,19 +361,47 @@ contains real(kind=r_def) :: tol, new_coord_1, new_coord_2, new_coord_3 +!!$ integer(i_def), parameter :: geometry +!!$ integer(i_def), parameter :: topology +!!$ integer(i_def), parameter :: coord_system +!!$ real(r_def), parameter :: scaled_radius + select case ( this%target_coord_system ) case ( ABH ) +print*,'debug: chump' call chi2abr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, & + this%geometry, & + this%topology, & + this%src_coord_system, & + this%scaled_radius, & + new_coord_1, new_coord_2, new_coord_3 ) case ( LLH ) +print*,'debug: welly' call chi2llr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, & + this%geometry, & + this%topology, & + this%src_coord_system, & + this%scaled_radius, & + new_coord_1, new_coord_2, new_coord_3 ) case ( XYZ ) +print*,'debug: wanger' call chi2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, & + this%geometry, & + this%topology, & + this%src_coord_system, & + this%scaled_radius, & + new_coord_1, new_coord_2, new_coord_3 ) case ( R2XYZ ) +print*,'debug: chimp' call chir2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, & + this%geometry, & + this%topology, & + this%src_coord_system, & + new_coord_1, new_coord_2, new_coord_3 ) end select ! Check if answers are correct diff --git a/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf b/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf index ee65c0293..4dc22f61a 100644 --- a/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf @@ -6,7 +6,7 @@ module compute_latlon_kernel_mod_test - use constants_mod, only : i_def, r_def, pi, imdi + use constants_mod, only : i_def, r_def, pi, imdi, rmdi use get_unit_test_m3x3_dofmap_mod, & only : get_w3_m3x3_dofmap, get_wchi_m3x3_dofmap use get_unit_test_m3x3_q3x3x3_sizes_mod, & @@ -35,27 +35,23 @@ contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine setUp( this ) - use sci_chi_transform_mod, only : init_chi_transforms - use feign_config_mod, only : feign_finite_element_config - use finite_element_config_mod, only : cellshape_quadrilateral, & - coord_system_xyz - - - use extrusion_config_mod, only: method_uniform + use sci_chi_transform_mod, only: init_chi_transforms +! use feign_config_mod, only : feign_finite_element_config +! use extrusion_config_mod, only: method_uniform implicit none class(compute_latlon_kernel_test_type), intent(inout) :: this - integer(kind=i_def) :: nlayers + ! integer(kind=i_def) :: nlayers - call feign_finite_element_config( & - cellshape=cellshape_quadrilateral, & - coord_order=0_i_def, & - coord_system=coord_system_xyz, & - element_order_h=0_i_def, & - element_order_v=0_i_def, & - rehabilitate=.true. ) +!!$ call feign_finite_element_config( & +!!$ cellshape=cellshape_quadrilateral, & +!!$ coord_order=0_i_def, & +!!$ coord_system=coord_system_xyz, & +!!$ element_order_h=0_i_def, & +!!$ element_order_v=0_i_def, & +!!$ rehabilitate=.true. ) call init_chi_transforms(imdi, imdi) @@ -72,7 +68,7 @@ contains class(compute_latlon_kernel_test_type), intent(inout) :: this ! Finalise namelists - call final_configuration() + ! call final_configuration() call final_chi_transforms() end subroutine tearDown @@ -82,6 +78,7 @@ contains subroutine test_all( this ) use sci_compute_latlon_kernel_mod, only: compute_latlon_code + use finite_element_config_mod, only: coord_system_xyz implicit none @@ -100,6 +97,11 @@ contains real(r_def), allocatable :: latitude(:), longitude(:) real(r_def), allocatable :: lat_answer(:), lon_answer(:) + integer(i_def), parameter :: geometry = imdi + integer(i_def), parameter :: topology = imdi + integer(i_def), parameter :: coord_system = coord_system_xyz + real(r_def), parameter :: scaled_radius = rmdi + call get_w3_m3x3_q3x3x3_size( ndf_w3, undf_w3, unused, & unused, unused, unused, & unused, nlayers=nlayers) @@ -131,6 +133,10 @@ contains latitude, longitude, & chi_1, chi_2, chi_3, & panel_id, & + geometry, & + topology, & + coord_system, & + scaled_radius, & ndf_w3, undf_w3, map_w3(:,1), & ndf_chi, undf_chi, map_chi(:,1), & basis_chi(:,:,1,:), & diff --git a/components/science/unit-test/kernel/geometry/nodal_xyz_coordinates_kernel_mod_test.pf b/components/science/unit-test/kernel/geometry/nodal_xyz_coordinates_kernel_mod_test.pf index 01bccfc8e..d646a31ce 100644 --- a/components/science/unit-test/kernel/geometry/nodal_xyz_coordinates_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/nodal_xyz_coordinates_kernel_mod_test.pf @@ -6,7 +6,7 @@ module nodal_xyz_coordinates_kernel_mod_test - use constants_mod, only : i_def, r_def, imdi + use constants_mod, only : i_def, r_def, imdi, rmdi use get_unit_test_m3x3_q3x3x3_sizes_mod, only : get_w0_m3x3_q3x3x3_size, & get_w2_m3x3_q3x3x3_size, & @@ -36,30 +36,27 @@ module nodal_xyz_coordinates_kernel_mod_test procedure test_all end type nodal_xyz_coordinates_test_type - integer(i_def), parameter :: element_order_h = 0 - integer(i_def), parameter :: element_order_v = 0 - contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine setUp( this ) - use sci_chi_transform_mod, only : init_chi_transforms - use feign_config_mod, only : feign_finite_element_config - use finite_element_config_mod, only : cellshape_quadrilateral, & - coord_system_xyz + use sci_chi_transform_mod, only: init_chi_transforms +! use feign_config_mod, only : feign_finite_element_config +! use finite_element_config_mod, only : cellshape_quadrilateral, & +! coord_system_xyz implicit none class(nodal_xyz_coordinates_test_type), intent(inout) :: this - call feign_finite_element_config( & - cellshape=cellshape_quadrilateral, & - coord_order=0_i_def, & - coord_system=coord_system_xyz, & - element_order_h=0_i_def, & - element_order_v=0_i_def, & - rehabilitate=.true. ) +!!$ call feign_finite_element_config( & +!!$ cellshape=cellshape_quadrilateral, & +!!$ coord_order=0_i_def, & +!!$ coord_system=coord_system_xyz, & +!!$ element_order_h=0_i_def, & +!!$ element_order_v=0_i_def, & +!!$ rehabilitate=.true. ) call init_chi_transforms(imdi, imdi) @@ -86,6 +83,7 @@ contains subroutine test_all( this ) use sci_nodal_xyz_coordinates_kernel_mod, only: nodal_xyz_coordinates_code + use finite_element_config_mod, only: coord_system_xyz implicit none @@ -96,6 +94,14 @@ contains real(r_def), parameter :: dz = 2000.0_r_def real(r_def), parameter :: tol = 1.0e-6_r_def +! integer(i_def), parameter :: element_order_h = 0 +! integer(i_def), parameter :: element_order_v = 0 + + integer(i_def), parameter :: geometry = imdi + integer(i_def), parameter :: topology = imdi + integer(i_def), parameter :: coord_system = coord_system_xyz + real(r_def), parameter :: scaled_radius = rmdi + ! Fields real(r_def), allocatable :: nodal1(:), nodal2(:), nodal3(:) real(r_def), allocatable :: chi1(:), chi2(:), chi3(:), panel_id(:) @@ -120,6 +126,8 @@ contains integer(kind=i_def) :: dim_space, dim_space_diff integer(kind=i_def) :: nqp_h, nqp_v + + nlayers = 3 call get_w0_m3x3_q3x3x3_size( ndf_w0, undf_w0, ncells, & dim_space, dim_space_diff, & @@ -171,6 +179,10 @@ contains chi2, & chi3, & panel_id, & + geometry, & + topology, & + coord_system, & + scaled_radius, & ndf_w2, undf_w2, & map_w2(:,cell), & ndf_w0, undf_w0, & diff --git a/components/science/unit-test/kernel/inter_function_space/compute_map_u_operators_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/compute_map_u_operators_kernel_mod_test.pf index 2a5c4dd49..5e4757a1f 100644 --- a/components/science/unit-test/kernel/inter_function_space/compute_map_u_operators_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/inter_function_space/compute_map_u_operators_kernel_mod_test.pf @@ -9,12 +9,15 @@ module compute_map_u_operators_kernel_mod_test use constants_mod, only : i_def, pi, r_def use funit + use base_mesh_config_mod, only: geometry_spherical, topology_non_periodic + use finite_element_config_mod, only: coord_system_native + implicit none private public :: set_up, tear_down, test_all - real(r_def), parameter :: planet_radius = 6000000.0_r_def +! real(r_def), parameter :: planet_radius = 6000000.0_r_def contains @@ -22,44 +25,44 @@ contains @before subroutine set_up() - use base_mesh_config_mod, only : geometry_spherical, & - topology_non_periodic - use extrusion_config_mod, only : method_uniform, & - stretching_method_linear +! use base_mesh_config_mod, only : geometry_spherical, & +! topology_non_periodic +! use extrusion_config_mod, only : method_uniform, & +! stretching_method_linear use sci_chi_transform_mod, only : init_chi_transforms - use finite_element_config_mod, only : cellshape_quadrilateral, & - coord_system_native - use feign_config_mod, only : feign_extrusion_config, & - feign_finite_element_config, & - feign_base_mesh_config, & - feign_planet_config +! use finite_element_config_mod, only : &!cellshape_quadrilateral, & +! coord_system_native +!!$ use feign_config_mod, only : feign_extrusion_config, & +!!$ feign_finite_element_config, & +!!$ feign_base_mesh_config, & +!!$ feign_planet_config implicit none - call feign_base_mesh_config( file_prefix='foo', & - prime_mesh_name='unit_test', & - geometry=geometry_spherical, & - prepartitioned=.false., & - topology=topology_non_periodic, & - fplane=.false., f_lat_deg=0.0_r_def ) - - call feign_extrusion_config( method=method_uniform, & - planet_radius=planet_radius, & - domain_height=10.0_r_def, & - number_of_layers=4_i_def, & - stretching_height=0.5_r_def, & - stretching_method=stretching_method_linear, & - eta_values=(/0.5_r_def/) ) - - call feign_finite_element_config( & - cellshape=cellshape_quadrilateral, & - element_order_h=0_i_def, & - element_order_v=0_i_def, & - rehabilitate=.true., & - coord_order = 0_i_def, & - coord_system=coord_system_native ) - - call feign_planet_config( scaling_factor=1.0_r_def ) +!!$ call feign_base_mesh_config( file_prefix='foo', & +!!$ prime_mesh_name='unit_test', & +!!$ geometry=geometry_spherical, & +!!$ prepartitioned=.false., & +!!$ topology=topology_non_periodic, & +!!$ fplane=.false., f_lat_deg=0.0_r_def ) +!!$ +!!$ call feign_extrusion_config( method=method_uniform, & +!!$ planet_radius=planet_radius, & +!!$ domain_height=10.0_r_def, & +!!$ number_of_layers=4_i_def, & +!!$ stretching_height=0.5_r_def, & +!!$ stretching_method=stretching_method_linear, & +!!$ eta_values=(/0.5_r_def/) ) +!!$ +!!$ call feign_finite_element_config( & +!!$ cellshape=cellshape_quadrilateral, & +!!$ element_order_h=0_i_def, & +!!$ element_order_v=0_i_def, & +!!$ rehabilitate=.true., & +!!$ coord_order = 0_i_def, & +!!$ coord_system=coord_system_native ) +!!$ +!!$ call feign_planet_config( scaling_factor=1.0_r_def ) call init_chi_transforms(geometry_spherical,topology_non_periodic) @@ -114,13 +117,21 @@ contains only : get_gaussian_q3x3x3_quadrature_weights_xy, & get_gaussian_q3x3x3_quadrature_weights_z - implicit none + implicit none + + real(r_def), parameter :: planet_radius = 6000000.0_r_def + real(r_def), parameter :: scaling = 1.0_r_def real(r_def), parameter :: tol = 1.0e-3_r_def real(r_def), parameter :: dlon = 1.0_r_def/planet_radius, & dlat = 1.0_r_def/planet_radius, & dz = 1.0_r_def + integer(i_def), parameter :: geometry = geometry_spherical + integer(i_def), parameter :: topology = topology_non_periodic + integer(i_def), parameter :: coord_system = coord_system_native + real(r_def), parameter :: scaled_radius = scaling*planet_radius + real(r_def) :: answer integer(i_def) :: cell, ncells, ncell_3d @@ -227,6 +238,10 @@ contains chi_data(:,2), & chi_data(:,3), & panel_id_data, & +geometry,& + topology,& + coord_system,& + scaled_radius,& ndf_w2, basis_w2, & ndf_w3, basis_w3, & ndf_wt, basis_wt, & diff --git a/components/science/unit-test/kernel/inter_function_space/compute_sample_u_ops_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/compute_sample_u_ops_kernel_mod_test.pf index f5fda906e..9fa16010b 100644 --- a/components/science/unit-test/kernel/inter_function_space/compute_sample_u_ops_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/inter_function_space/compute_sample_u_ops_kernel_mod_test.pf @@ -10,13 +10,27 @@ module compute_sample_u_ops_kernel_mod_test use reference_element_mod, only : W, S, E, N, B, T use funit + + use base_mesh_config_mod, only: geometry_spherical, & + topology_non_periodic + use finite_element_config_mod, only: coord_system_native + +!!$ use extrusion_config_mod, only : method_uniform, & +!!$ stretching_method_linear +!!$ use finite_element_config_mod, only : cellshape_quadrilateral, & +!!$ coord_system_native +!!$ use feign_config_mod, only : feign_base_mesh_config, & +!!$ feign_extrusion_config, & +!!$ feign_finite_element_config, & +!!$ feign_planet_config + implicit none private public :: set_up, tear_down, test_all - real(r_def), parameter :: radius = 6000000.0_r_def - real(r_def), parameter :: scaling = 1.0_r_def +! real(r_def), parameter :: radius = 6000000.0_r_def real(r_def), +! parameter :: scaling = 1.0_r_def contains @@ -24,44 +38,44 @@ contains @before subroutine set_up() - use base_mesh_config_mod, only : geometry_spherical, & - topology_non_periodic - use extrusion_config_mod, only : method_uniform, & - stretching_method_linear - use finite_element_config_mod, only : cellshape_quadrilateral, & - coord_system_native - use feign_config_mod, only : feign_base_mesh_config, & - feign_extrusion_config, & - feign_finite_element_config, & - feign_planet_config +!!$ use base_mesh_config_mod, only : geometry_spherical, & +!!$ topology_non_periodic +!!$ use extrusion_config_mod, only : method_uniform, & +!!$ stretching_method_linear +!!$ use finite_element_config_mod, only : cellshape_quadrilateral, & +!!$ coord_system_native +!!$ use feign_config_mod, only : feign_base_mesh_config, & +!!$ feign_extrusion_config, & +!!$ feign_finite_element_config, & +!!$ feign_planet_config use sci_chi_transform_mod, only : init_chi_transforms implicit none - call feign_base_mesh_config( file_prefix='foo', & - prime_mesh_name='unit_test', & - geometry=geometry_spherical, & - prepartitioned=.false., & - topology=topology_non_periodic, & - fplane=.false., f_lat_deg=0.0_r_def ) - - call feign_extrusion_config( method=method_uniform, & - planet_radius=radius, & - domain_height=10.0_r_def, & - number_of_layers=5_i_def, & - stretching_method=stretching_method_linear, & - stretching_height=15.0_r_def, & - eta_values=(/0.5_r_def/) ) - - call feign_finite_element_config( & - cellshape=cellshape_quadrilateral, & - element_order_h=0_i_def, & - element_order_v=0_i_def, & - rehabilitate=.true., & - coord_order = 0_i_def, & - coord_system=coord_system_native ) - - call feign_planet_config( scaling_factor=scaling ) +!!$ call feign_base_mesh_config( file_prefix='foo', & +!!$ prime_mesh_name='unit_test', & +!!$ geometry=geometry_spherical, & +!!$ prepartitioned=.false., & +!!$ topology=topology_non_periodic, & +!!$ fplane=.false., f_lat_deg=0.0_r_def ) +!!$ +!!$ call feign_extrusion_config( method=method_uniform, & +!!$ planet_radius=radius, & +!!$ domain_height=10.0_r_def, & +!!$ number_of_layers=5_i_def, & +!!$ stretching_method=stretching_method_linear, & +!!$ stretching_height=15.0_r_def, & +!!$ eta_values=(/0.5_r_def/) ) +!!$ +!!$ call feign_finite_element_config( & +!!$ cellshape=cellshape_quadrilateral, & +!!$ element_order_h=0_i_def, & +!!$ element_order_v=0_i_def, & +!!$ rehabilitate=.true., & +!!$ coord_order = 0_i_def, & +!!$ coord_system=coord_system_native ) +!!$ +!!$ call feign_planet_config( scaling_factor=scaling ) call init_chi_transforms(geometry_spherical, topology_non_periodic) @@ -102,6 +116,7 @@ contains implicit none + real(r_def), parameter :: radius = 6000000.0_r_def real(r_def), parameter :: tol = 1.0e-2_r_def real(r_def), parameter :: dlon = 2.0_r_def/radius real(r_def), parameter :: dlat = 3.0_r_def/radius @@ -117,6 +132,14 @@ contains real(r_def), parameter :: du_lat0_dz = -0.5_r_def real(r_def), parameter :: du_up0_dz = 0.001_r_def + + real(r_def), parameter :: scaling = 1.0_r_def + + integer(i_def),parameter :: geometry = geometry_spherical + integer(i_def),parameter :: topology = topology_non_periodic + integer(i_def),parameter :: coord_system = coord_system_native + real(r_def), parameter :: scaled_radius = scaling*radius + integer(i_def) :: cell, ncols_x, ncols_y, ncols_2d, ncells_3d integer(i_def) :: nlayers, k, nfaces @@ -275,6 +298,10 @@ contains chi_data(:,2), & chi_data(:,3), & panel_id_data, & +geometry,& +topology,& +coord_system,& +scaled_radius,& ndf_w2b, ndf_w3, ndf_wt, & ndf_wchi, undf_wchi, map_wchi(:,cell), & basis_wchi, diff_basis_wchi, & diff --git a/components/science/unit-test/kernel/inter_function_space/convert_phys_to_hdiv_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/convert_phys_to_hdiv_kernel_mod_test.pf index 247e482e9..f376c68bf 100644 --- a/components/science/unit-test/kernel/inter_function_space/convert_phys_to_hdiv_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/inter_function_space/convert_phys_to_hdiv_kernel_mod_test.pf @@ -7,9 +7,12 @@ !! W2 wind field module convert_phys_to_hdiv_kernel_mod_test - use constants_mod, only : i_def, r_def + use constants_mod, only: i_def, r_def, rmdi use funit + use base_mesh_config_mod, only: geometry_planar, topology_fully_periodic + use finite_element_config_mod, only: coord_system_xyz + implicit none private @@ -29,32 +32,32 @@ contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine setUp( this ) - use base_mesh_config_mod, only : geometry_planar, & - topology_fully_periodic +!!$ use base_mesh_config_mod, only : geometry_planar, & +!!$ topology_fully_periodic use sci_chi_transform_mod, only : init_chi_transforms - use finite_element_config_mod, only : cellshape_quadrilateral, & - coord_system_xyz - use feign_config_mod, only : feign_finite_element_config, & - feign_base_mesh_config +!!$ use finite_element_config_mod, only : cellshape_quadrilateral, & +!!$ coord_system_xyz +!!$ use feign_config_mod, only : feign_finite_element_config, & +!!$ feign_base_mesh_config implicit none class(convert_phys_to_hdiv_test_type), intent(inout) :: this - call feign_base_mesh_config( file_prefix='foo', & - prime_mesh_name='unit_test', & - geometry=geometry_planar, & - prepartitioned=.false., & - topology=topology_fully_periodic, & - fplane=.false., f_lat_deg=0.0_r_def ) - - call feign_finite_element_config( & - cellshape=cellshape_quadrilateral, & - coord_order=0_i_def, & - coord_system=coord_system_xyz, & - element_order_h=0_i_def, & - element_order_v=0_i_def, & - rehabilitate=.true. ) +!!$ call feign_base_mesh_config( file_prefix='foo', & +!!$ prime_mesh_name='unit_test', & +!!$ geometry=geometry_planar, & +!!$ prepartitioned=.false., & +!!$ topology=topology_fully_periodic, & +!!$ fplane=.false., f_lat_deg=0.0_r_def ) + +!!$ call feign_finite_element_config( & +!!$ cellshape=cellshape_quadrilateral, & +!!$ coord_order=0_i_def, & +!!$ coord_system=coord_system_xyz, & +!!$ element_order_h=0_i_def, & +!!$ element_order_v=0_i_def, & +!!$ rehabilitate=.true. ) call init_chi_transforms(geometry_planar, topology_fully_periodic) @@ -94,9 +97,8 @@ contains get_w2_w2nodal_basis use get_unit_test_3x3x3_chi_mod, only: get_w0_3x3x3_field - use base_mesh_config_mod, only: geometry_planar - implicit none + implicit none class(convert_phys_to_hdiv_test_type), intent(inout) :: this @@ -108,6 +110,11 @@ contains real(r_def), parameter :: u_meridional = 3.0_r_def real(r_def), parameter :: u_radial = 0.4_r_def + integer(i_def), parameter :: geometry = geometry_planar + integer(i_def), parameter :: topology = topology_fully_periodic + integer(i_def), parameter :: coord_system = coord_system_xyz + real(r_def), parameter :: scaled_radius = rmdi + real(r_def) :: answer integer(i_def) :: cell @@ -192,7 +199,10 @@ contains chi_data(:,2), & chi_data(:,3), & panel_id_data, & - geometry_planar, & + geometry, & + topology, & + coord_system, & + scaled_radius,& ndf_w2, undf_w2, & map_w2(:,cell), basis_w2, & ndf_w0, undf_w0, & diff --git a/components/science/unit-test/kernel/inter_function_space/project_ws_to_w1_operator_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/project_ws_to_w1_operator_kernel_mod_test.pf index 3c8c17e91..17ca183a6 100644 --- a/components/science/unit-test/kernel/inter_function_space/project_ws_to_w1_operator_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/inter_function_space/project_ws_to_w1_operator_kernel_mod_test.pf @@ -7,7 +7,7 @@ !> Test the projection from a scalar space to W1 module project_ws_to_w1_operator_kernel_mod_test - use constants_mod, only : i_def, r_def + use constants_mod, only : i_def, r_def, rmdi use funit use get_unit_test_q3x3x3_quadrature_mod, only : get_gaussian_q3x3x3_quadrature_weights_xy, & get_gaussian_q3x3x3_quadrature_weights_z @@ -23,6 +23,9 @@ module project_ws_to_w1_operator_kernel_mod_test get_w3_m3x3_dofmap use get_unit_test_3x3x3_chi_mod, only : get_w0_3x3x3_field + use base_mesh_config_mod, only: geometry_planar, topology_fully_periodic + use finite_element_config_mod, only: coord_system_xyz + implicit none private @@ -42,31 +45,31 @@ contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine setUp( this ) - use finite_element_config_mod, only : cellshape_quadrilateral, & - coord_system_xyz - use feign_config_mod, only : feign_finite_element_config - use base_mesh_config_mod, only : geometry_planar, & - topology_fully_periodic - use feign_config_mod, only : feign_base_mesh_config +!!$ use finite_element_config_mod, only : cellshape_quadrilateral, & +!!$ coord_system_xyz +!!$ use feign_config_mod, only : feign_finite_element_config +!!$ use base_mesh_config_mod, only : geometry_planar, & +!!$ topology_fully_periodic +!!$ use feign_config_mod, only : feign_base_mesh_config use sci_chi_transform_mod, only : init_chi_transforms implicit none class(project_ws_to_w1_operator_test_type), intent(inout) :: this - call feign_base_mesh_config( file_prefix='foo', & - prime_mesh_name='unit_test', & - geometry=geometry_planar, & - prepartitioned=.false., & - topology=topology_fully_periodic, & - fplane=.false., f_lat_deg=0.0_r_def ) - - call feign_finite_element_config( cellshape=cellshape_quadrilateral, & - coord_order=0_i_def, & - element_order_h=0_i_def, & - element_order_v=0_i_def, & - rehabilitate=.true., & - coord_system=coord_system_xyz ) +!!$ call feign_base_mesh_config( file_prefix='foo', & +!!$ prime_mesh_name='unit_test', & +!!$ geometry=geometry_planar, & +!!$ prepartitioned=.false., & +!!$ topology=topology_fully_periodic, & +!!$ fplane=.false., f_lat_deg=0.0_r_def ) +!!$ +!!$ call feign_finite_element_config( cellshape=cellshape_quadrilateral, & +!!$ coord_order=0_i_def, & +!!$ element_order_h=0_i_def, & +!!$ element_order_v=0_i_def, & +!!$ rehabilitate=.true., & +!!$ coord_system=coord_system_xyz ) call init_chi_transforms(geometry_planar,topology_fully_periodic) @@ -100,6 +103,11 @@ contains real(kind=r_def), parameter :: tol = 1.0e-6_r_def + integer(i_def), parameter :: geometry = geometry_planar + integer(i_def), parameter :: topology = topology_fully_periodic + integer(i_def), parameter :: coord_system = coord_system_xyz + real(r_def), parameter :: scaled_radius = rmdi + ! Mesh integer(i_def) :: nlayers, ncells, ncell_3d, cell, icell integer(i_def) :: ndf_w0, undf_w0, ndf_w1, undf_w1 @@ -210,6 +218,10 @@ contains chi1, chi2, chi3, & panel_id, & direction, & + geometry, & + topology, & + coord_system, & + scaled_radius,& ndf_w1, & basis_w1, & ndf_w3, & diff --git a/components/science/unit-test/kernel/inter_function_space/w3_to_w2_displacement_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/w3_to_w2_displacement_kernel_mod_test.pf index c24a3b329..9d4ac6272 100644 --- a/components/science/unit-test/kernel/inter_function_space/w3_to_w2_displacement_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/inter_function_space/w3_to_w2_displacement_kernel_mod_test.pf @@ -11,6 +11,13 @@ module w3_to_w2_displacement_kernel_mod_test use reference_element_mod, only: S, E, N, W use funit + use base_mesh_config_mod, only : geometry_spherical, & + topology_fully_periodic +!!$ use extrusion_config_mod, only : method_uniform, & +!!$ stretching_method_linear + use finite_element_config_mod, only : &!cellshape_quadrilateral, & + coord_system_native + implicit none private @@ -22,44 +29,34 @@ contains @before subroutine set_up() - use base_mesh_config_mod, only : geometry_spherical, & - topology_fully_periodic - use extrusion_config_mod, only : method_uniform, & - stretching_method_linear - use finite_element_config_mod, only : cellshape_quadrilateral, & - coord_system_native - use feign_config_mod, only : feign_base_mesh_config, & - feign_extrusion_config, & - feign_finite_element_config, & - feign_planet_config use sci_chi_transform_mod, only : init_chi_transforms implicit none - call feign_base_mesh_config( file_prefix='foo', & - prime_mesh_name='unit_test', & - geometry=geometry_spherical, & - prepartitioned=.false., & - topology=topology_fully_periodic, & - fplane=.false., f_lat_deg=0.0_r_def ) - - call feign_extrusion_config( method=method_uniform, & - planet_radius=1900000.0_r_def, & - domain_height=10.0_r_def, & - number_of_layers=5_i_def, & - stretching_method=stretching_method_linear, & - stretching_height=15.0_r_def, & - eta_values=(/0.5_r_def/) ) - - call feign_finite_element_config( & - cellshape=cellshape_quadrilateral, & - element_order_h=0_i_def, & - element_order_v=0_i_def, & - rehabilitate=.true., & - coord_order = 0_i_def, & - coord_system=coord_system_native ) - - call feign_planet_config( scaling_factor=1.0_r_def ) +!!$ call feign_base_mesh_config( file_prefix='foo', & +!!$ prime_mesh_name='unit_test', & +!!$ geometry=geometry_spherical, & +!!$ prepartitioned=.false., & +!!$ topology=topology_fully_periodic, & +!!$ fplane=.false., f_lat_deg=0.0_r_def ) + +!!$ call feign_extrusion_config( method=method_uniform, & +!!$ planet_radius=1900000.0_r_def, & +!!$ domain_height=10.0_r_def, & +!!$ number_of_layers=5_i_def, & +!!$ stretching_method=stretching_method_linear, & +!!$ stretching_height=15.0_r_def, & +!!$ eta_values=(/0.5_r_def/) ) + +!!$ call feign_finite_element_config( & +!!$ cellshape=cellshape_quadrilateral, & +!!$ element_order_h=0_i_def, & +!!$ element_order_v=0_i_def, & +!!$ rehabilitate=.true., & +!!$ coord_order = 0_i_def, & +!!$ coord_system=coord_system_native ) + +! call feign_planet_config( scaling_factor=1.0_r_def ) call init_chi_transforms(geometry_spherical, topology_fully_periodic) @@ -84,8 +81,8 @@ contains subroutine test_all() use sci_w3_to_w2_displacement_kernel_mod, only: w3_to_w2_displacement_code - use get_unit_test_w2hnodal_basis_mod, only: get_wchi_w2hnodal_basis - use get_unit_test_w3nodal_basis_mod, only: get_wchi_w3nodal_basis + use get_unit_test_w2hnodal_basis_mod, only: get_wchi_w2hnodal_basis + use get_unit_test_w3nodal_basis_mod, only: get_wchi_w3nodal_basis implicit none @@ -96,6 +93,11 @@ contains real(r_def), parameter :: beta0 = PI/6.0_r_def real(r_def), parameter :: dz = 2.0_r_def + integer(i_def), parameter :: geometry = geometry_spherical + integer(i_def), parameter :: topology = topology_fully_periodic + integer(i_def), parameter :: coord_system = coord_system_native + real(r_def), parameter :: scaled_radius = 1900000.0_r_def + ! Non-periodic 3x3x3 domain integer(i_def), parameter :: ncells = 2 integer(i_def), parameter :: nlayers = 1 @@ -120,7 +122,7 @@ contains real(r_def) :: dummy_w3(undf_w3) real(r_def) :: answer, phi - integer(i_def) :: df_w2h, cell + integer(i_def) :: cell ! ------------------------------------------------------------------------ ! ! Make DoF maps @@ -177,6 +179,10 @@ contains chi_1, chi_2, chi_3, & panel_id, & dummy_w3, & + geometry, & + topology, & + coord_system, & + scaled_radius,& ndf_w2h, undf_w2h, map_w2h(:,cell), & ndf_chi, undf_chi, map_chi(:,cell), & basis_chi_w2h, basis_chi_w3, & From 15b9dda5d237ce53b06a32ae91616fe4528fc034 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Fri, 20 Mar 2026 20:32:57 +0000 Subject: [PATCH 03/44] Commit changes that mean this branch is clear of chi_tranform_mod --- components/driver/source/driver_io_mod.F90 | 4 +- .../source/lfric_xios_setup_mod.x90 | 6 +- .../algorithm/sci_geometric_constants_mod.x90 | 10 +- .../algorithm/sci_mapping_constants_mod.x90 | 1 + .../kernel/geometry/sci_chi_transform_mod.F90 | 18 ++++ .../sci_nodal_xyz_coordinates_kernel_mod.F90 | 4 + ...sci_compute_map_u_operators_kernel_mod.F90 | 8 +- .../sci_compute_sample_u_ops_kernel_mod.F90 | 4 + .../sci_convert_phys_to_hdiv_kernel_mod.F90 | 27 +++-- ...i_project_ws_to_w1_operator_kernel_mod.F90 | 29 +++--- .../sci_w3_to_w2_displacement_kernel_mod.F90 | 42 ++++---- .../kernel/geometry/chi_transform_mod_test.pf | 99 +++---------------- .../compute_latlon_kernel_mod_test.pf | 48 +++------ ...coordinate_jacobian_alphabetaz_mod_test.pf | 10 +- .../coordinate_jacobian_lonlatz_mod_test.pf | 10 +- .../native_jacobian_alphabetaz_mod_test.pf | 2 - .../native_jacobian_lonlatz_mod_test.pf | 2 - .../nodal_xyz_coordinates_kernel_mod_test.pf | 58 +++-------- ...compute_map_u_operators_kernel_mod_test.pf | 59 +++-------- .../compute_sample_u_ops_kernel_mod_test.pf | 63 ++---------- .../convert_phys_to_hdiv_kernel_mod_test.pf | 68 ++++--------- ...oject_ws_to_w1_operator_kernel_mod_test.pf | 65 +++--------- .../w3_to_w2_displacement_kernel_mod_test.pf | 52 +++------- 23 files changed, 203 insertions(+), 486 deletions(-) diff --git a/components/driver/source/driver_io_mod.F90 b/components/driver/source/driver_io_mod.F90 index ba0d98b05..d1301dbba 100644 --- a/components/driver/source/driver_io_mod.F90 +++ b/components/driver/source/driver_io_mod.F90 @@ -262,8 +262,8 @@ subroutine init_xios_io_context( context_name, & deallocate(alt_coords) deallocate(alt_panel_ids) else - call io_context%initialise_xios_context( modeldb%config,& - modeldb%mpi%get_comm(), & + call io_context%initialise_xios_context( modeldb%config, & + modeldb%mpi%get_comm(), & chi, panel_id, & modeldb%clock, & modeldb%calendar, & diff --git a/components/lfric-xios/source/lfric_xios_setup_mod.x90 b/components/lfric-xios/source/lfric_xios_setup_mod.x90 index 249d21083..ee1a5881d 100644 --- a/components/lfric-xios/source/lfric_xios_setup_mod.x90 +++ b/components/lfric-xios/source/lfric_xios_setup_mod.x90 @@ -174,12 +174,14 @@ contains type(mesh_type), pointer :: mesh => null() ! Initialise XIOS prime mesh - call init_xios_mesh( config, chi, panel_id, prime_mesh=.true. ) + call init_xios_mesh(config, chi, panel_id, prime_mesh=.true.) ! Initialise additional meshes if (present(alt_coords) .and. present(alt_panel_ids)) then do i = 1, size(alt_panel_ids) - call init_xios_mesh( config, alt_coords(i,:), alt_panel_ids(i), prime_mesh=.false. ) + call init_xios_mesh( config, alt_coords(i,:), & + alt_panel_ids(i), & + prime_mesh=.false. ) end do end if diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90 b/components/science/source/algorithm/sci_geometric_constants_mod.x90 index ad11561cb..3d6efe65f 100644 --- a/components/science/source/algorithm/sci_geometric_constants_mod.x90 +++ b/components/science/source/algorithm/sci_geometric_constants_mod.x90 @@ -326,13 +326,13 @@ contains !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The coordinate field array - function get_extended_coordinates(coord_system, mesh_id) result(extended_chi) + function get_extended_coordinates(config, mesh_id) result(extended_chi) use sci_extend_chi_field_kernel_mod, only: extend_chi_field_kernel_type implicit none - integer(kind=i_def), intent(in) :: coord_system + type(config_type), intent(in) :: config integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -342,7 +342,11 @@ contains type(field_type), pointer :: chi(:) type(field_type), pointer :: panel_id type(function_space_type), pointer :: wchi_fs - integer(tik) :: id + + integer(tik) :: id + integer(i_def) :: coord_system + + coord_system = config%finite_element%coord_system() ! Initialise inventory if this is the first time getting this constant if (.not. extended_chi_inventory%is_initialised()) then diff --git a/components/science/source/algorithm/sci_mapping_constants_mod.x90 b/components/science/source/algorithm/sci_mapping_constants_mod.x90 index 7186fef8f..ff1e0e0c6 100644 --- a/components/science/source/algorithm/sci_mapping_constants_mod.x90 +++ b/components/science/source/algorithm/sci_mapping_constants_mod.x90 @@ -15,6 +15,7 @@ module sci_mapping_constants_mod ! Infrastructure + use config_mod, only: config_type use constants_mod, only: i_def, r_def, l_def, str_def use copy_field_alg_mod, only: copy_field use extrusion_mod, only: PRIME_EXTRUSION, & diff --git a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 index f4a1bb555..3cc55ec22 100644 --- a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 +++ b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 @@ -74,6 +74,8 @@ module sci_chi_transform_mod !------------------------------------------------------------------------------ !> @brief Initialise the coordinate transform information !! +!> @param[in] geometry +!> @param[in] topology !> @param[in] mesh_collection Optional: a collection of meshes, which contain !! metadata used to determine the rotation matrix !! and stretching factors. @@ -244,6 +246,11 @@ end subroutine final_chi_transforms !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius +!! @param[in] panel_id The mesh panel ID !! @param[out] x The first coordinate field out (global Cartesian X) !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) @@ -333,6 +340,9 @@ end subroutine chi2xyz !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system !! @param[out] x The first coordinate field out (global Cartesian X) !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) @@ -418,6 +428,10 @@ end subroutine chir2xyz !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius !! @param[out] longitude The first coordinate field out (longitude) !! @param[out] latitude The second coordinate field out (latitude) !! @param[out] radius The third coordinate field out (radius) @@ -497,6 +511,10 @@ end subroutine chi2llr !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius !! @param[out] alpha The first coordinate field out (alpha) !! @param[out] beta The second coordinate field out (beta) !! @param[out] radius The third coordinate field out (radius) diff --git a/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 b/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 index c4155b3dd..965ecacff 100644 --- a/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 @@ -63,6 +63,10 @@ module sci_nodal_xyz_coordinates_kernel_mod !> @param[in] chi2 Coordinates in the second direction !> @param[in] chi3 Coordinates in the third direction !> @param[in] panel_id A field giving the ID for mesh panels. +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius !> @param[in] ndf_x Number of degrees of freedom per cell for the output field !> @param[in] undf_x Number of unique degrees of freedom for the output field !> @param[in] map_x Dofmap for the output field diff --git a/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 index 1cb26d73c..48d850335 100644 --- a/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 @@ -29,6 +29,8 @@ module sci_compute_map_u_operators_kernel_mod use kernel_mod, only : kernel_type use log_mod, only : log_event, LOG_LEVEL_ERROR, LOG_LEVEL_INFO + use base_mesh_config_mod, only: geometry_spherical, geometry_planar + implicit none private @@ -85,6 +87,10 @@ module sci_compute_map_u_operators_kernel_mod !! @param[in] chi_sph_2 2nd coordinate in spherical Wchi !! @param[in] chi_sph_3 3rd coordinate in spherical Wchi !! @param[in] panel_id Field giving the ID for mesh panels +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius !! @param[in] ndf_w2 Number of degrees of freedom per cell for w2 !! @param[in] basis_w2 W2 basis functions evaluated at quadrature points !! @param[in] ndf_w3 Number of degrees of freedom per cell for w3 @@ -124,8 +130,6 @@ subroutine compute_map_u_operators_code(cell, nlayers, ncell_3d_1, & use sci_coordinate_jacobian_mod, only : coordinate_jacobian use coord_transform_mod, only : sphere2cart_vector - use base_mesh_config_mod, only: geometry_spherical, geometry_planar - implicit none ! Arguments diff --git a/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 index eb446602c..52c665ca2 100644 --- a/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 @@ -90,6 +90,10 @@ module sci_compute_sample_u_ops_kernel_mod !> @param[in] chi2 Coordinates in the second direction !> @param[in] chi3 Coordinates in the third direction !> @param[in] panel_id A field giving the ID for mesh panels +!> @param[in] geometry +!> @param[in] topology +!> @param[in] coord_system +!> @param[in] scaled_radius !> @param[in] ndf_w2b Number of DoFs per cell for broken W2 !> @param[in] ndf_w3 Number of DoFs per cell for W3 !> @param[in] ndf_wt Number of DoFs per cell for Wtheta diff --git a/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 index 000da1b41..287012515 100644 --- a/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 @@ -43,10 +43,10 @@ module sci_convert_phys_to_hdiv_kernel_mod arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & 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_SCALAR, GH_INTEGER, GH_READ), &! geometry - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system - arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius /) type(func_type) :: meta_funcs(2) = (/ & func_type(W2, GH_BASIS), & @@ -76,6 +76,9 @@ module sci_convert_phys_to_hdiv_kernel_mod !> @param[in] chi_3 3rd coordinate field !> @param[in] panel_id Field giving the ID for mesh panels !> @param[in] geometry Integer indicating the domain geometry +!> @param[in] topology +!> @param[in] coord_system +!> @param[in] scaled_radius !> @param[in] ndf_w2 Number of DoFs per cell for W2 !> @param[in] undf_w2 Number of DoFs for W2 for this partition !> @param[in] map_w2 Map of DoFs for lowest-layer cells for W2 @@ -99,10 +102,9 @@ subroutine convert_phys_to_hdiv_code( nlayers, & chi_3, & panel_id, & geometry, & - - topology, & - coord_system, & - scaled_radius, & + topology, & + coord_system, & + scaled_radius, & ndf_w2, & undf_w2, & map_w2, & @@ -127,7 +129,6 @@ subroutine convert_phys_to_hdiv_code( nlayers, & integer(kind=i_def), intent(in) :: nlayers integer(kind=i_def), intent(in) :: ndf_w2, ndf_pid, ndf_chi integer(kind=i_def), intent(in) :: undf_w2, undf_pid, undf_chi -! integer(kind=i_def), intent(in) :: geometry integer(kind=i_def), intent(in) :: map_w2(ndf_w2) integer(kind=i_def), intent(in) :: map_chi(ndf_chi) @@ -205,11 +206,9 @@ subroutine convert_phys_to_hdiv_code( nlayers, & ! Convert coordinates from whatever coordinate system the model uses ! into spherical-polar coordinates call chi2llr(coords(1), coords(2), coords(3), & - ipanel, geometry,& - topology,& - coord_system,& - scaled_radius,& -llr(1), llr(2), llr(3)) + ipanel, geometry, topology, & + coord_system, scaled_radius, & + llr(1), llr(2), llr(3)) u_spherical(1) = u_lon(map_w2(df_w2) + k) u_spherical(2) = u_lat(map_w2(df_w2) + k) diff --git a/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 index 1a7e95f85..ad8221c4f 100644 --- a/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 @@ -42,10 +42,10 @@ module sci_project_ws_to_w1_operator_kernel_mod arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system - arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius /) type(func_type) :: meta_funcs(3) = (/ & func_type(W1, GH_BASIS), & @@ -79,6 +79,10 @@ module sci_project_ws_to_w1_operator_kernel_mod !> @param[in] chi3 3rd coordinate field in Wchi !> @param[in] panel_id Field giving the ID for mesh panels. !> @param[in] direction Index of the vector component (1,2 or 3) to project +!> @param[in] geometry +!> @param[in] topology +!> @param[in] coord_system +!> @param[in] scaled_radius !> @param[in] ndf_w1 Number of degrees of freedom per cell for vector space !> @param[in] basis_w1 Basis functions for the vector space at quadrature points !> @param[in] ndf_ws Number of degrees of freedom per cell for scalar space @@ -101,10 +105,10 @@ subroutine project_ws_to_w1_operator_code( cell, nlayers, & chi1, chi2, chi3, & panel_id, & direction, & - geometry, & - topology, & - coord_system, & - scaled_radius, & + geometry, & + topology, & + coord_system, & + scaled_radius, & ndf_w1, basis_w1, & ndf_ws, basis_ws, & ndf_wx, undf_wx, map_wx, & @@ -181,12 +185,9 @@ subroutine project_ws_to_w1_operator_code( cell, nlayers, & llr(:) = 0.0_r_def - call chi2llr(coords(1), coords(2), coords(3), & - ipanel, geometry,& - topology,& - coord_system,& - scaled_radius,& -llr(1), llr(2), llr(3)) + call chi2llr(coords(1), coords(2), coords(3), ipanel, & + geometry, topology, coord_system, scaled_radius, & + llr(1), llr(2), llr(3)) end if call pointwise_coordinate_jacobian(coord_system, geometry, & diff --git a/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 index b813cb189..ea65d9e3b 100644 --- a/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 @@ -39,10 +39,10 @@ module sci_w3_to_w2_displacement_kernel_mod arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & arg_type(GH_FIELD, GH_REAL, GH_READ, W3), & - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & - arg_type(GH_SCALAR, GH_REAL, GH_READ) & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius /) type(func_type) :: meta_funcs(1) = (/ & func_type(Wchi, GH_BASIS) & @@ -72,6 +72,10 @@ module sci_w3_to_w2_displacement_kernel_mod !> @param[in] chi_3 The third coordinate field !> @param[in] panel_id ID for panels of the underlying mesh !> @param[in] dummy_w3 An unused dummy field in W3 + !> @param[in] geometry + !> @param[in] topology + !> @param[in] coord_system + !> @param[in] scaled_radius !> @param[in] ndf_w2h Number of DoFs for W2H per cell !> @param[in] undf_w2h Number of unique DoFs for W2H per partition !> @param[in] map_w2h The DoF map for bottom layer cells for W2H @@ -93,10 +97,10 @@ subroutine w3_to_w2_displacement_code( nlayers, & chi_3, & panel_id, & dummy_w3, & - geometry, & - topology, & - coord_system, & - scaled_radius,& + geometry, & + topology, & + coord_system, & + scaled_radius, & ndf_w2h, & undf_w2h, & map_w2h, & @@ -136,10 +140,10 @@ subroutine w3_to_w2_displacement_code( nlayers, & real(kind=r_def), intent(in) :: basis_chi_w2h(1,ndf_chi,ndf_w2h) real(kind=r_def), intent(in) :: basis_chi_w3(1,ndf_chi,ndf_w3) - integer(kind=i_def), intent(in) :: geometry - integer(kind=i_def), intent(in) :: topology - integer(kind=i_def), intent(in) :: coord_system - real(kind=r_def), intent(in) :: scaled_radius + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + integer(kind=i_def), intent(in) :: coord_system + real(kind=r_def), intent(in) :: scaled_radius ! Vertical cell index integer(kind=i_def) :: df_w2h, df_w3, df_chi @@ -170,11 +174,8 @@ subroutine w3_to_w2_displacement_code( nlayers, & chi3_at_dof = chi3_at_dof + & basis_chi_w3(1,df_chi,df_w3) * chi_3(map_chi(df_chi)) end do - call chi2abr(chi1_at_dof, chi2_at_dof, chi3_at_dof, ipanel, & - geometry, & - topology, & - coord_system, & - scaled_radius,& + call chi2abr(chi1_at_dof, chi2_at_dof, chi3_at_dof, ipanel, & + geometry, topology, coord_system, scaled_radius, & alpha_w3, beta_w3, dummy_r) ! W2H points --------------------------------------------------------------- @@ -192,11 +193,8 @@ subroutine w3_to_w2_displacement_code( nlayers, & chi3_at_dof = chi3_at_dof + & basis_chi_w2h(1,df_chi,df_w2h) * chi_3(map_chi(df_chi)) end do - call chi2abr(chi1_at_dof, chi2_at_dof, chi3_at_dof, ipanel, & - geometry, & - topology, & - coord_system, & - scaled_radius,& + call chi2abr(chi1_at_dof, chi2_at_dof, chi3_at_dof, ipanel, & + geometry, topology, coord_system, scaled_radius, & alpha_w2h(df_w2h), beta_w2h(df_w2h), dummy_r) end do diff --git a/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf b/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf index 6e63f65d9..e8e50e1ea 100644 --- a/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf @@ -53,7 +53,6 @@ module chi_transform_mod_test real(r_def) :: target_chi_2 real(r_def) :: target_chi_3 - integer(i_def) :: src_coord_system integer(i_def) :: topology integer(i_def) :: geometry @@ -207,13 +206,13 @@ contains chi_parameters_type(LLH, XYZ, panel_id, & lon, lat, height, & X, Y, Z), & - chi_parameters_type(LLH_rot, LLH, panel_id, &!!!!!!!F + chi_parameters_type(LLH_rot, LLH, panel_id, & lon_rot, lat_rot, height, & lon, lat, radius), & - chi_parameters_type(LLH_rot, XYZ, panel_id, &!!!! F + chi_parameters_type(LLH_rot, XYZ, panel_id, & lon_rot, lat_rot, height, & X, Y, Z), & - chi_parameters_type(XYZ, ABH, panel_id, &!! Abort + chi_parameters_type(XYZ, ABH, panel_id, & X, Y, Z, & alpha, beta, radius), & chi_parameters_type(XYZ, LLH, panel_id, & @@ -235,36 +234,14 @@ contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine setUp( this ) -!!$ use feign_config_mod, only : feign_base_mesh_config, & -!!$ feign_extrusion_config, & -!!$ feign_finite_element_config, & -!!$ feign_planet_config - use sci_chi_transform_mod, only: init_chi_transforms -!!$ use base_mesh_config_mod, only: geometry_spherical, & -!!$ geometry_planar, & -!!$ topology_fully_periodic, & -!!$ topology_non_periodic -!!$ -!!$ use finite_element_config_mod, only: coord_system_native, & -!!$ coord_system_xyz - implicit none class(chi_transform_mod_test_type), intent(inout) :: this -! integer(i_def) :: coord_system, topology real(r_def) :: north_pole(2), equatorial_latitude -!!$ call feign_extrusion_config( method=method_uniform, & -!!$ planet_radius=planet_radius, & -!!$ domain_height=10.0_r_def, & -!!$ number_of_layers=5_i_def, & -!!$ stretching_method=stretching_method_linear, & -!!$ stretching_height=15.0_r_def, & -!!$ eta_values=(/0.5_r_def/) ) - select case ( this%source_coord_system ) case ( XYZ ) this%src_coord_system = coord_system_xyz @@ -280,25 +257,8 @@ contains this%topology = topology_fully_periodic end select - this%geometry = geometry_spherical - this%scaled_radius = planet_radius*scaling - -!!$ call feign_base_mesh_config( file_prefix='foo', & -!!$ prime_mesh_name='unit_test', & -!!$ geometry=geometry_spherical, & -!!$ prepartitioned=.false., & -!!$ topology=topology, & -!!$ fplane=.false., f_lat_deg=0.0_r_def ) - -!!$ call feign_finite_element_config( & -!!$ cellshape=cellshape_quadrilateral, & -!!$ element_order_h=0_i_def, & -!!$ element_order_v=0_i_def, & -!!$ rehabilitate=.true., & -!!$ coord_order=0_i_def, & -!!$ coord_system=coord_system ) - -!! call feign_planet_config( scaling_factor=scaling ) + this%geometry = geometry_spherical + this%scaled_radius = planet_radius*scaling if ( this%source_coord_system == LLH_rot ) then north_pole(1) = PI/2.0_r_def @@ -343,17 +303,6 @@ contains subroutine test_all( this ) use sci_chi_transform_mod, only : chi2abr, chi2llr, chi2xyz, chir2xyz -!!$ use finite_element_config_mod, only : coord_system -!!$ use base_mesh_config_mod, only : geometry_spherical, & -!!$ geometry_planar, & -!!$ topology_fully_periodic, & -!!$ topology_non_periodic -!!$ use extrusion_config_mod, only : method_uniform, & -!!$ stretching_method_linear -!!$ use finite_element_config_mod, only : cellshape_quadrilateral, & -!!$ coord_system_native, & -!!$ coord_system_xyz - implicit none @@ -361,46 +310,26 @@ contains real(kind=r_def) :: tol, new_coord_1, new_coord_2, new_coord_3 -!!$ integer(i_def), parameter :: geometry -!!$ integer(i_def), parameter :: topology -!!$ integer(i_def), parameter :: coord_system -!!$ real(r_def), parameter :: scaled_radius - select case ( this%target_coord_system ) case ( ABH ) -print*,'debug: chump' call chi2abr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, & - this%geometry, & - this%topology, & - this%src_coord_system, & - this%scaled_radius, & - new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, this%scaled_radius, & + new_coord_1, new_coord_2, new_coord_3) case ( LLH ) -print*,'debug: welly' call chi2llr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, & - this%geometry, & - this%topology, & - this%src_coord_system, & - this%scaled_radius, & + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, this%scaled_radius, & new_coord_1, new_coord_2, new_coord_3 ) case ( XYZ ) -print*,'debug: wanger' call chi2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, & - this%geometry, & - this%topology, & - this%src_coord_system, & - this%scaled_radius, & + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, this%scaled_radius, & new_coord_1, new_coord_2, new_coord_3 ) case ( R2XYZ ) -print*,'debug: chimp' call chir2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, & - this%geometry, & - this%topology, & - this%src_coord_system, & + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, & new_coord_1, new_coord_2, new_coord_3 ) end select diff --git a/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf b/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf index 4dc22f61a..0610fed4e 100644 --- a/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf @@ -16,74 +16,48 @@ module compute_latlon_kernel_mod_test use funit + use finite_element_config_mod, only: coord_system_xyz + implicit none private - public test_all + public :: set_up, tear_down, test_all - @TestCase - type, extends(TestCase), public :: compute_latlon_kernel_test_type - private - contains - procedure setUp - procedure tearDown - procedure test_all - end type compute_latlon_kernel_test_type contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine setUp( this ) + @before + subroutine set_up() - use sci_chi_transform_mod, only: init_chi_transforms -! use feign_config_mod, only : feign_finite_element_config -! use extrusion_config_mod, only: method_uniform + use sci_chi_transform_mod, only: init_chi_transforms implicit none - class(compute_latlon_kernel_test_type), intent(inout) :: this - - ! integer(kind=i_def) :: nlayers - -!!$ call feign_finite_element_config( & -!!$ cellshape=cellshape_quadrilateral, & -!!$ coord_order=0_i_def, & -!!$ coord_system=coord_system_xyz, & -!!$ element_order_h=0_i_def, & -!!$ element_order_v=0_i_def, & -!!$ rehabilitate=.true. ) - call init_chi_transforms(imdi, imdi) - end subroutine setUp + end subroutine set_up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine tearDown( this ) + @after + subroutine tear_down() use sci_chi_transform_mod, only: final_chi_transforms - use config_loader_mod, only: final_configuration implicit none - class(compute_latlon_kernel_test_type), intent(inout) :: this - - ! Finalise namelists - ! call final_configuration() call final_chi_transforms() - end subroutine tearDown + end subroutine tear_down !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @Test - subroutine test_all( this ) + subroutine test_all() use sci_compute_latlon_kernel_mod, only: compute_latlon_code - use finite_element_config_mod, only: coord_system_xyz implicit none - class(compute_latlon_kernel_test_type), intent(inout) :: this - real(r_def), parameter :: tol = 1.0e-12_r_def integer(i_def), parameter :: nlayers = 1 integer(i_def) :: k, df_w3 diff --git a/components/science/unit-test/kernel/geometry/coordinate_jacobian_alphabetaz_mod_test.pf b/components/science/unit-test/kernel/geometry/coordinate_jacobian_alphabetaz_mod_test.pf index 756a4c84b..ae1aa557a 100644 --- a/components/science/unit-test/kernel/geometry/coordinate_jacobian_alphabetaz_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/coordinate_jacobian_alphabetaz_mod_test.pf @@ -8,11 +8,11 @@ module coordinate_jacobian_alphabetaz_mod_test use funit - use constants_mod, only : r_def, i_def + use constants_mod, only: r_def, i_def - use base_mesh_config_mod, only : geometry_spherical, & - topology_fully_periodic - use finite_element_config_mod, only : coord_system_native + use base_mesh_config_mod, only: geometry_spherical, & + topology_fully_periodic + use finite_element_config_mod, only: coord_system_native implicit none @@ -38,12 +38,10 @@ contains @after subroutine tear_down() - use config_loader_mod, only: final_configuration use sci_chi_transform_mod, only: final_chi_transforms implicit none - call final_configuration() call final_chi_transforms() end subroutine tear_down diff --git a/components/science/unit-test/kernel/geometry/coordinate_jacobian_lonlatz_mod_test.pf b/components/science/unit-test/kernel/geometry/coordinate_jacobian_lonlatz_mod_test.pf index 3d717c8b0..e4a2c021f 100644 --- a/components/science/unit-test/kernel/geometry/coordinate_jacobian_lonlatz_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/coordinate_jacobian_lonlatz_mod_test.pf @@ -10,6 +10,10 @@ module coordinate_jacobian_lonlatz_mod_test use funit use constants_mod, only : r_def, i_def, PI + use base_mesh_config_mod, only: geometry_spherical, & + topology_non_periodic + use finite_element_config_mod, only: coord_system_native + implicit none public :: set_up, tear_down, test_all @@ -30,12 +34,10 @@ contains @after subroutine tear_down() - use config_loader_mod, only: final_configuration use sci_chi_transform_mod, only: final_chi_transforms implicit none - call final_configuration() call final_chi_transforms() end subroutine tear_down @@ -52,10 +54,6 @@ contains pointwise_coordinate_jacobian, & pointwise_coordinate_jacobian_inverse - use base_mesh_config_mod, only: geometry_spherical, & - topology_non_periodic - use finite_element_config_mod, only: coord_system_native - implicit none real(kind=r_def), parameter :: tol = 1.0e-12_r_def ! r_def 64bit diff --git a/components/science/unit-test/kernel/geometry/native_jacobian_alphabetaz_mod_test.pf b/components/science/unit-test/kernel/geometry/native_jacobian_alphabetaz_mod_test.pf index 53aed1296..162bc1642 100644 --- a/components/science/unit-test/kernel/geometry/native_jacobian_alphabetaz_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/native_jacobian_alphabetaz_mod_test.pf @@ -37,12 +37,10 @@ contains @after subroutine tear_down() - use config_loader_mod, only: final_configuration use sci_chi_transform_mod, only: final_chi_transforms implicit none - call final_configuration() call final_chi_transforms() end subroutine tear_down diff --git a/components/science/unit-test/kernel/geometry/native_jacobian_lonlatz_mod_test.pf b/components/science/unit-test/kernel/geometry/native_jacobian_lonlatz_mod_test.pf index e63daeeab..53ed27607 100644 --- a/components/science/unit-test/kernel/geometry/native_jacobian_lonlatz_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/native_jacobian_lonlatz_mod_test.pf @@ -38,12 +38,10 @@ contains @after subroutine tear_down() - use config_loader_mod, only: final_configuration use sci_chi_transform_mod, only: final_chi_transforms implicit none - call final_configuration() call final_chi_transforms() end subroutine tear_down diff --git a/components/science/unit-test/kernel/geometry/nodal_xyz_coordinates_kernel_mod_test.pf b/components/science/unit-test/kernel/geometry/nodal_xyz_coordinates_kernel_mod_test.pf index d646a31ce..ed263deff 100644 --- a/components/science/unit-test/kernel/geometry/nodal_xyz_coordinates_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/nodal_xyz_coordinates_kernel_mod_test.pf @@ -20,83 +20,55 @@ module nodal_xyz_coordinates_kernel_mod_test use get_unit_test_3x3x3_chi_mod, only : get_w0_3x3x3_field + use finite_element_config_mod, only: coord_system_xyz + use funit implicit none private - public :: test_all + public :: set_up, tear_down, test_all - @TestCase - type, extends(TestCase), public :: nodal_xyz_coordinates_test_type - private - contains - procedure setUp - procedure tearDown - procedure test_all - end type nodal_xyz_coordinates_test_type contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine setUp( this ) + @before + subroutine set_up() use sci_chi_transform_mod, only: init_chi_transforms -! use feign_config_mod, only : feign_finite_element_config -! use finite_element_config_mod, only : cellshape_quadrilateral, & -! coord_system_xyz implicit none - class(nodal_xyz_coordinates_test_type), intent(inout) :: this - -!!$ call feign_finite_element_config( & -!!$ cellshape=cellshape_quadrilateral, & -!!$ coord_order=0_i_def, & -!!$ coord_system=coord_system_xyz, & -!!$ element_order_h=0_i_def, & -!!$ element_order_v=0_i_def, & -!!$ rehabilitate=.true. ) - call init_chi_transforms(imdi, imdi) - end subroutine setUp + end subroutine set_up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine tearDown( this ) + @after + subroutine tear_down() use sci_chi_transform_mod, only: final_chi_transforms - use config_loader_mod, only: final_configuration implicit none - class(nodal_xyz_coordinates_test_type), intent(inout) :: this - - ! Finalise namelists - call final_configuration() call final_chi_transforms() - end subroutine tearDown + end subroutine tear_down !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @Test - subroutine test_all( this ) + subroutine test_all() use sci_nodal_xyz_coordinates_kernel_mod, only: nodal_xyz_coordinates_code - use finite_element_config_mod, only: coord_system_xyz implicit none - class(nodal_xyz_coordinates_test_type), intent(inout) :: this - real(r_def), parameter :: dx = 6000.0_r_def real(r_def), parameter :: dy = 1000.0_r_def real(r_def), parameter :: dz = 2000.0_r_def real(r_def), parameter :: tol = 1.0e-6_r_def -! integer(i_def), parameter :: element_order_h = 0 -! integer(i_def), parameter :: element_order_v = 0 - integer(i_def), parameter :: geometry = imdi integer(i_def), parameter :: topology = imdi integer(i_def), parameter :: coord_system = coord_system_xyz @@ -126,8 +98,6 @@ contains integer(kind=i_def) :: dim_space, dim_space_diff integer(kind=i_def) :: nqp_h, nqp_v - - nlayers = 3 call get_w0_m3x3_q3x3x3_size( ndf_w0, undf_w0, ncells, & dim_space, dim_space_diff, & @@ -179,10 +149,10 @@ contains chi2, & chi3, & panel_id, & - geometry, & - topology, & - coord_system, & - scaled_radius, & + geometry, & + topology, & + coord_system, & + scaled_radius, & ndf_w2, undf_w2, & map_w2(:,cell), & ndf_w0, undf_w0, & diff --git a/components/science/unit-test/kernel/inter_function_space/compute_map_u_operators_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/compute_map_u_operators_kernel_mod_test.pf index 5e4757a1f..5686d794b 100644 --- a/components/science/unit-test/kernel/inter_function_space/compute_map_u_operators_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/inter_function_space/compute_map_u_operators_kernel_mod_test.pf @@ -7,63 +7,30 @@ module compute_map_u_operators_kernel_mod_test use constants_mod, only : i_def, pi, r_def - use funit - use base_mesh_config_mod, only: geometry_spherical, topology_non_periodic + use base_mesh_config_mod, only: geometry_spherical, & + topology_non_periodic use finite_element_config_mod, only: coord_system_native + use funit + + + implicit none private public :: set_up, tear_down, test_all -! real(r_def), parameter :: planet_radius = 6000000.0_r_def - contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @before subroutine set_up() -! use base_mesh_config_mod, only : geometry_spherical, & -! topology_non_periodic -! use extrusion_config_mod, only : method_uniform, & -! stretching_method_linear - use sci_chi_transform_mod, only : init_chi_transforms -! use finite_element_config_mod, only : &!cellshape_quadrilateral, & -! coord_system_native -!!$ use feign_config_mod, only : feign_extrusion_config, & -!!$ feign_finite_element_config, & -!!$ feign_base_mesh_config, & -!!$ feign_planet_config + use sci_chi_transform_mod, only: init_chi_transforms implicit none -!!$ call feign_base_mesh_config( file_prefix='foo', & -!!$ prime_mesh_name='unit_test', & -!!$ geometry=geometry_spherical, & -!!$ prepartitioned=.false., & -!!$ topology=topology_non_periodic, & -!!$ fplane=.false., f_lat_deg=0.0_r_def ) -!!$ -!!$ call feign_extrusion_config( method=method_uniform, & -!!$ planet_radius=planet_radius, & -!!$ domain_height=10.0_r_def, & -!!$ number_of_layers=4_i_def, & -!!$ stretching_height=0.5_r_def, & -!!$ stretching_method=stretching_method_linear, & -!!$ eta_values=(/0.5_r_def/) ) -!!$ -!!$ call feign_finite_element_config( & -!!$ cellshape=cellshape_quadrilateral, & -!!$ element_order_h=0_i_def, & -!!$ element_order_v=0_i_def, & -!!$ rehabilitate=.true., & -!!$ coord_order = 0_i_def, & -!!$ coord_system=coord_system_native ) -!!$ -!!$ call feign_planet_config( scaling_factor=1.0_r_def ) - call init_chi_transforms(geometry_spherical,topology_non_periodic) end subroutine set_up @@ -72,12 +39,10 @@ contains @after subroutine tear_down() - use config_loader_mod, only: final_configuration use sci_chi_transform_mod, only: final_chi_transforms implicit none - call final_configuration() call final_chi_transforms() end subroutine tear_down @@ -231,17 +196,17 @@ contains u_up_data(:) = 0.0_r_def panel_id_data(:) = 1.0_r_def - call compute_map_u_operators_code( cell, nlayers, ncell_3d, & + call compute_map_u_operators_code( cell, nlayers, ncell_3d, & u_lon_map, ncell_3d, u_lat_map, & ncell_3d, u_up_map, & chi_data(:,1), & chi_data(:,2), & chi_data(:,3), & panel_id_data, & -geometry,& - topology,& - coord_system,& - scaled_radius,& + geometry, & + topology, & + coord_system, & + scaled_radius, & ndf_w2, basis_w2, & ndf_w3, basis_w3, & ndf_wt, basis_wt, & diff --git a/components/science/unit-test/kernel/inter_function_space/compute_sample_u_ops_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/compute_sample_u_ops_kernel_mod_test.pf index 9fa16010b..3778ec60b 100644 --- a/components/science/unit-test/kernel/inter_function_space/compute_sample_u_ops_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/inter_function_space/compute_sample_u_ops_kernel_mod_test.pf @@ -8,75 +8,28 @@ module compute_sample_u_ops_kernel_mod_test use constants_mod, only : i_def, r_def use reference_element_mod, only : W, S, E, N, B, T - use funit - use base_mesh_config_mod, only: geometry_spherical, & topology_non_periodic use finite_element_config_mod, only: coord_system_native -!!$ use extrusion_config_mod, only : method_uniform, & -!!$ stretching_method_linear -!!$ use finite_element_config_mod, only : cellshape_quadrilateral, & -!!$ coord_system_native -!!$ use feign_config_mod, only : feign_base_mesh_config, & -!!$ feign_extrusion_config, & -!!$ feign_finite_element_config, & -!!$ feign_planet_config + use funit implicit none private public :: set_up, tear_down, test_all -! real(r_def), parameter :: radius = 6000000.0_r_def real(r_def), -! parameter :: scaling = 1.0_r_def - contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @before subroutine set_up() -!!$ use base_mesh_config_mod, only : geometry_spherical, & -!!$ topology_non_periodic -!!$ use extrusion_config_mod, only : method_uniform, & -!!$ stretching_method_linear -!!$ use finite_element_config_mod, only : cellshape_quadrilateral, & -!!$ coord_system_native -!!$ use feign_config_mod, only : feign_base_mesh_config, & -!!$ feign_extrusion_config, & -!!$ feign_finite_element_config, & -!!$ feign_planet_config - use sci_chi_transform_mod, only : init_chi_transforms + use sci_chi_transform_mod, only: init_chi_transforms implicit none -!!$ call feign_base_mesh_config( file_prefix='foo', & -!!$ prime_mesh_name='unit_test', & -!!$ geometry=geometry_spherical, & -!!$ prepartitioned=.false., & -!!$ topology=topology_non_periodic, & -!!$ fplane=.false., f_lat_deg=0.0_r_def ) -!!$ -!!$ call feign_extrusion_config( method=method_uniform, & -!!$ planet_radius=radius, & -!!$ domain_height=10.0_r_def, & -!!$ number_of_layers=5_i_def, & -!!$ stretching_method=stretching_method_linear, & -!!$ stretching_height=15.0_r_def, & -!!$ eta_values=(/0.5_r_def/) ) -!!$ -!!$ call feign_finite_element_config( & -!!$ cellshape=cellshape_quadrilateral, & -!!$ element_order_h=0_i_def, & -!!$ element_order_v=0_i_def, & -!!$ rehabilitate=.true., & -!!$ coord_order = 0_i_def, & -!!$ coord_system=coord_system_native ) -!!$ -!!$ call feign_planet_config( scaling_factor=scaling ) - call init_chi_transforms(geometry_spherical, topology_non_periodic) end subroutine set_up @@ -85,12 +38,10 @@ contains @after subroutine tear_down() - use config_loader_mod, only: final_configuration use sci_chi_transform_mod, only: final_chi_transforms implicit none - call final_configuration() call final_chi_transforms() end subroutine tear_down @@ -138,7 +89,7 @@ contains integer(i_def),parameter :: geometry = geometry_spherical integer(i_def),parameter :: topology = topology_non_periodic integer(i_def),parameter :: coord_system = coord_system_native - real(r_def), parameter :: scaled_radius = scaling*radius + real(r_def), parameter :: scaled_radius = scaling*radius integer(i_def) :: cell, ncols_x, ncols_y, ncols_2d, ncells_3d @@ -298,10 +249,10 @@ contains chi_data(:,2), & chi_data(:,3), & panel_id_data, & -geometry,& -topology,& -coord_system,& -scaled_radius,& + geometry, & + topology, & + coord_system, & + scaled_radius, & ndf_w2b, ndf_w3, ndf_wt, & ndf_wchi, undf_wchi, map_wchi(:,cell), & basis_wchi, diff_basis_wchi, & diff --git a/components/science/unit-test/kernel/inter_function_space/convert_phys_to_hdiv_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/convert_phys_to_hdiv_kernel_mod_test.pf index f376c68bf..571181d93 100644 --- a/components/science/unit-test/kernel/inter_function_space/convert_phys_to_hdiv_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/inter_function_space/convert_phys_to_hdiv_kernel_mod_test.pf @@ -8,79 +8,47 @@ module convert_phys_to_hdiv_kernel_mod_test use constants_mod, only: i_def, r_def, rmdi - use funit - use base_mesh_config_mod, only: geometry_planar, topology_fully_periodic + use base_mesh_config_mod, only: geometry_planar, & + topology_fully_periodic use finite_element_config_mod, only: coord_system_xyz + use funit + implicit none private - public :: convert_phys_to_hdiv_test_type, test_all - - @TestCase - type, extends(TestCase) :: convert_phys_to_hdiv_test_type - private - contains - procedure setUp - procedure tearDown - procedure test_all - end type convert_phys_to_hdiv_test_type + public :: set_up, tear_down, test_all contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine setUp( this ) + @before + subroutine set_up() -!!$ use base_mesh_config_mod, only : geometry_planar, & -!!$ topology_fully_periodic - use sci_chi_transform_mod, only : init_chi_transforms -!!$ use finite_element_config_mod, only : cellshape_quadrilateral, & -!!$ coord_system_xyz -!!$ use feign_config_mod, only : feign_finite_element_config, & -!!$ feign_base_mesh_config + use sci_chi_transform_mod, only: init_chi_transforms implicit none - class(convert_phys_to_hdiv_test_type), intent(inout) :: this - -!!$ call feign_base_mesh_config( file_prefix='foo', & -!!$ prime_mesh_name='unit_test', & -!!$ geometry=geometry_planar, & -!!$ prepartitioned=.false., & -!!$ topology=topology_fully_periodic, & -!!$ fplane=.false., f_lat_deg=0.0_r_def ) - -!!$ call feign_finite_element_config( & -!!$ cellshape=cellshape_quadrilateral, & -!!$ coord_order=0_i_def, & -!!$ coord_system=coord_system_xyz, & -!!$ element_order_h=0_i_def, & -!!$ element_order_v=0_i_def, & -!!$ rehabilitate=.true. ) - call init_chi_transforms(geometry_planar, topology_fully_periodic) - end subroutine setUp + end subroutine set_up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine tearDown( this ) + @after + subroutine tear_down() - use config_loader_mod, only: final_configuration use sci_chi_transform_mod, only: final_chi_transforms implicit none - class(convert_phys_to_hdiv_test_type), intent(inout) :: this - - call final_configuration() call final_chi_transforms() - end subroutine tearDown + end subroutine tear_down !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @Test - subroutine test_all( this ) + subroutine test_all() use sci_convert_phys_to_hdiv_kernel_mod, only : convert_phys_to_hdiv_code @@ -100,8 +68,6 @@ contains implicit none - class(convert_phys_to_hdiv_test_type), intent(inout) :: this - real(r_def), parameter :: tol = 1.0e-3_r_def real(r_def), parameter :: dx = 6000.0_r_def real(r_def), parameter :: dy = 1000.0_r_def @@ -199,10 +165,10 @@ contains chi_data(:,2), & chi_data(:,3), & panel_id_data, & - geometry, & - topology, & - coord_system, & - scaled_radius,& + geometry, & + topology, & + coord_system, & + scaled_radius, & ndf_w2, undf_w2, & map_w2(:,cell), basis_w2, & ndf_w0, undf_w0, & diff --git a/components/science/unit-test/kernel/inter_function_space/project_ws_to_w1_operator_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/project_ws_to_w1_operator_kernel_mod_test.pf index 17ca183a6..5f1d0f284 100644 --- a/components/science/unit-test/kernel/inter_function_space/project_ws_to_w1_operator_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/inter_function_space/project_ws_to_w1_operator_kernel_mod_test.pf @@ -23,84 +23,49 @@ module project_ws_to_w1_operator_kernel_mod_test get_w3_m3x3_dofmap use get_unit_test_3x3x3_chi_mod, only : get_w0_3x3x3_field - use base_mesh_config_mod, only: geometry_planar, topology_fully_periodic + use base_mesh_config_mod, only: geometry_planar, & + topology_fully_periodic use finite_element_config_mod, only: coord_system_xyz implicit none private - public :: test_all - - @TestCase - type, extends(TestCase), public :: project_ws_to_w1_operator_test_type - private - contains - procedure setUp - procedure tearDown - procedure test_all - end type project_ws_to_w1_operator_test_type + public :: set_up, tear_down, test_all contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine setUp( this ) + @before + subroutine set_up() -!!$ use finite_element_config_mod, only : cellshape_quadrilateral, & -!!$ coord_system_xyz -!!$ use feign_config_mod, only : feign_finite_element_config -!!$ use base_mesh_config_mod, only : geometry_planar, & -!!$ topology_fully_periodic -!!$ use feign_config_mod, only : feign_base_mesh_config - use sci_chi_transform_mod, only : init_chi_transforms + use sci_chi_transform_mod, only: init_chi_transforms implicit none - class(project_ws_to_w1_operator_test_type), intent(inout) :: this - -!!$ call feign_base_mesh_config( file_prefix='foo', & -!!$ prime_mesh_name='unit_test', & -!!$ geometry=geometry_planar, & -!!$ prepartitioned=.false., & -!!$ topology=topology_fully_periodic, & -!!$ fplane=.false., f_lat_deg=0.0_r_def ) -!!$ -!!$ call feign_finite_element_config( cellshape=cellshape_quadrilateral, & -!!$ coord_order=0_i_def, & -!!$ element_order_h=0_i_def, & -!!$ element_order_v=0_i_def, & -!!$ rehabilitate=.true., & -!!$ coord_system=coord_system_xyz ) - call init_chi_transforms(geometry_planar,topology_fully_periodic) - end subroutine setUp + end subroutine set_up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine tearDown( this ) + @after + subroutine tear_down() - use config_loader_mod, only: final_configuration use sci_chi_transform_mod, only: final_chi_transforms implicit none - class(project_ws_to_w1_operator_test_type), intent(inout) :: this - - call final_configuration() call final_chi_transforms() - end subroutine tearDown + end subroutine tear_down !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @Test - subroutine test_all( this ) + subroutine test_all() use sci_project_ws_to_w1_operator_kernel_mod, only : project_ws_to_w1_operator_code implicit none - class(project_ws_to_w1_operator_test_type), intent(inout) :: this - real(kind=r_def), parameter :: tol = 1.0e-6_r_def integer(i_def), parameter :: geometry = geometry_planar @@ -218,10 +183,10 @@ contains chi1, chi2, chi3, & panel_id, & direction, & - geometry, & - topology, & - coord_system, & - scaled_radius,& + geometry, & + topology, & + coord_system, & + scaled_radius, & ndf_w1, & basis_w1, & ndf_w3, & diff --git a/components/science/unit-test/kernel/inter_function_space/w3_to_w2_displacement_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/w3_to_w2_displacement_kernel_mod_test.pf index 9d4ac6272..6d01ea321 100644 --- a/components/science/unit-test/kernel/inter_function_space/w3_to_w2_displacement_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/inter_function_space/w3_to_w2_displacement_kernel_mod_test.pf @@ -7,16 +7,15 @@ !> Test the kernel to compute errors in W3 to W2 averaging module w3_to_w2_displacement_kernel_mod_test - use constants_mod, only: i_def, r_def, PI, l_def - use reference_element_mod, only: S, E, N, W - use funit + use constants_mod, only: i_def, r_def, PI, l_def + use reference_element_mod, only: S, E, N, W + + use base_mesh_config_mod, only: geometry_spherical, & + topology_fully_periodic + use finite_element_config_mod, only: coord_system_native + + use funit - use base_mesh_config_mod, only : geometry_spherical, & - topology_fully_periodic -!!$ use extrusion_config_mod, only : method_uniform, & -!!$ stretching_method_linear - use finite_element_config_mod, only : &!cellshape_quadrilateral, & - coord_system_native implicit none @@ -29,35 +28,10 @@ contains @before subroutine set_up() - use sci_chi_transform_mod, only : init_chi_transforms + use sci_chi_transform_mod, only: init_chi_transforms implicit none -!!$ call feign_base_mesh_config( file_prefix='foo', & -!!$ prime_mesh_name='unit_test', & -!!$ geometry=geometry_spherical, & -!!$ prepartitioned=.false., & -!!$ topology=topology_fully_periodic, & -!!$ fplane=.false., f_lat_deg=0.0_r_def ) - -!!$ call feign_extrusion_config( method=method_uniform, & -!!$ planet_radius=1900000.0_r_def, & -!!$ domain_height=10.0_r_def, & -!!$ number_of_layers=5_i_def, & -!!$ stretching_method=stretching_method_linear, & -!!$ stretching_height=15.0_r_def, & -!!$ eta_values=(/0.5_r_def/) ) - -!!$ call feign_finite_element_config( & -!!$ cellshape=cellshape_quadrilateral, & -!!$ element_order_h=0_i_def, & -!!$ element_order_v=0_i_def, & -!!$ rehabilitate=.true., & -!!$ coord_order = 0_i_def, & -!!$ coord_system=coord_system_native ) - -! call feign_planet_config( scaling_factor=1.0_r_def ) - call init_chi_transforms(geometry_spherical, topology_fully_periodic) end subroutine set_up @@ -66,12 +40,10 @@ contains @after subroutine tear_down() - use config_loader_mod, only: final_configuration use sci_chi_transform_mod, only: final_chi_transforms implicit none - call final_configuration() call final_chi_transforms() end subroutine tear_down @@ -179,10 +151,8 @@ contains chi_1, chi_2, chi_3, & panel_id, & dummy_w3, & - geometry, & - topology, & - coord_system, & - scaled_radius,& + geometry, topology, & + coord_system, scaled_radius, & ndf_w2h, undf_w2h, map_w2h(:,cell), & ndf_chi, undf_chi, map_chi(:,cell), & basis_chi_w2h, basis_chi_w3, & From 27de4c4a1f5e1877eccdc0d893d2eb06c9b2ca8a Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Sun, 22 Mar 2026 20:33:10 +0000 Subject: [PATCH 04/44] Clean out rest of driver --- .../coupled/example/configuration_glo.nml | 2 +- .../coupled/example/configuration_lam.nml | 2 +- .../source/driver/coupled_driver_mod.f90 | 2 +- .../io_demo/example/configuration.nml | 2 +- .../source/driver/io_demo_driver_mod.f90 | 2 +- .../source/driver/lbc_demo_driver_mod.f90 | 2 +- .../example/configuration.nml | 2 +- .../driver/simple_diffusion_driver_mod.f90 | 2 +- .../skeleton/example/configuration.nml | 2 +- .../source/driver/skeleton_driver_mod.f90 | 2 +- .../lfric-driver/HEAD/rose-meta.conf | 3 + .../driver/source/driver_coordinates_mod.F90 | 16 +- .../driver/source/driver_counter_mod.f90 | 26 +-- components/driver/source/driver_fem_mod.f90 | 17 +- components/driver/source/driver_mesh_mod.f90 | 57 +------ .../driver/source/mesh/create_mesh_mod.f90 | 4 +- .../assign_coordinate_xyz_mod_test.pf | 17 +- .../unit-test/mesh/create_mesh_mod_test.pf | 16 +- .../algorithm/sci_mapping_constants_mod.x90 | 152 ++++++++++++------ .../kernel/geometry/sci_chi_transform_mod.F90 | 15 +- .../sci_w3_to_w2_displacement_kernel_mod.F90 | 2 +- rose-stem/app/coupled/rose-app.conf | 6 +- rose-stem/app/io_demo/rose-app.conf | 6 +- rose-stem/app/lbc_demo/rose-app.conf | 6 +- rose-stem/app/simple_diffusion/rose-app.conf | 6 +- rose-stem/app/skeleton/rose-app.conf | 6 +- 26 files changed, 182 insertions(+), 193 deletions(-) diff --git a/applications/coupled/example/configuration_glo.nml b/applications/coupled/example/configuration_glo.nml index 5fa82561d..b2d2bb1f5 100644 --- a/applications/coupled/example/configuration_glo.nml +++ b/applications/coupled/example/configuration_glo.nml @@ -60,7 +60,7 @@ coord_system='native' panel_decomposition = 'auto', tile_size_x=1, tile_size_y=1, - inner_halo_tile=.false. + inner_halo_tiles=.false. / &planet diff --git a/applications/coupled/example/configuration_lam.nml b/applications/coupled/example/configuration_lam.nml index 3ce0701b3..a584cfa73 100644 --- a/applications/coupled/example/configuration_lam.nml +++ b/applications/coupled/example/configuration_lam.nml @@ -59,7 +59,7 @@ coord_system='native' panel_decomposition = 'auto', tile_size_x=1, tile_size_y=1, - inner_halo_tile=.false. + inner_halo_tiles=.false. / &planet diff --git a/applications/coupled/source/driver/coupled_driver_mod.f90 b/applications/coupled/source/driver/coupled_driver_mod.f90 index 04e741e6e..c94fa4b0c 100644 --- a/applications/coupled/source/driver/coupled_driver_mod.f90 +++ b/applications/coupled/source/driver/coupled_driver_mod.f90 @@ -154,7 +154,7 @@ subroutine initialise( program_name, modeldb, calendar ) ! Build the FEM function spaces and coordinate fields - call init_fem( modeldb, chi_inventory, panel_id_inventory ) + call init_fem( modeldb%config, chi_inventory, panel_id_inventory ) ! Create and initialise prognostic fields mesh => mesh_collection%get_mesh(prime_mesh_name) diff --git a/applications/io_demo/example/configuration.nml b/applications/io_demo/example/configuration.nml index 7dc9aea32..c11b9072d 100644 --- a/applications/io_demo/example/configuration.nml +++ b/applications/io_demo/example/configuration.nml @@ -79,7 +79,7 @@ coord_system='native' panel_decomposition = 'auto', tile_size_x=1, tile_size_y=1, - inner_halo_tile=.false. + inner_halo_tiles=.false. / &planet diff --git a/applications/io_demo/source/driver/io_demo_driver_mod.f90 b/applications/io_demo/source/driver/io_demo_driver_mod.f90 index 152809967..f26f3be0a 100644 --- a/applications/io_demo/source/driver/io_demo_driver_mod.f90 +++ b/applications/io_demo/source/driver/io_demo_driver_mod.f90 @@ -194,7 +194,7 @@ subroutine initialise(program_name, modeldb) !======================================================================= ! Build the FEM function spaces and coordinate fields !======================================================================= - call init_fem( modeldb, chi_inventory, panel_id_inventory ) + call init_fem( modeldb%config, chi_inventory, panel_id_inventory ) !======================================================================= ! Setup multifile reading diff --git a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 index 59d8b55b6..c9b126878 100644 --- a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 +++ b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 @@ -220,7 +220,7 @@ subroutine initialise( program_name, modeldb) !======================================================================= ! Build the FEM function spaces and coordinate fields !======================================================================= - call init_fem( modeldb, chi_inventory, panel_id_inventory ) + call init_fem( modeldb%config, chi_inventory, panel_id_inventory ) !======================================================================= ! Setup general I/O system. diff --git a/applications/simple_diffusion/example/configuration.nml b/applications/simple_diffusion/example/configuration.nml index 2280e1452..e32c05b0a 100644 --- a/applications/simple_diffusion/example/configuration.nml +++ b/applications/simple_diffusion/example/configuration.nml @@ -60,7 +60,7 @@ coord_system='native' panel_decomposition = 'auto', tile_size_x=1, tile_size_y=1, - inner_halo_tile=.false. + inner_halo_tiles=.false. / &planet diff --git a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 index 73c7d28f7..4812c5af5 100644 --- a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 +++ b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 @@ -183,7 +183,7 @@ subroutine initialise( program_name, modeldb) !======================================================================= ! 2.0 Build the FEM function spaces and coordinate fields !======================================================================= - call init_fem( modeldb, chi_inventory, panel_id_inventory ) + call init_fem( modeldb%config, chi_inventory, panel_id_inventory ) !======================================================================= diff --git a/applications/skeleton/example/configuration.nml b/applications/skeleton/example/configuration.nml index 2a2205611..2041e3701 100644 --- a/applications/skeleton/example/configuration.nml +++ b/applications/skeleton/example/configuration.nml @@ -60,7 +60,7 @@ coord_system='native' panel_decomposition = 'auto', tile_size_x=1, tile_size_y=1, - inner_halo_tile=.false. + inner_halo_tiles=.false. / &planet diff --git a/applications/skeleton/source/driver/skeleton_driver_mod.f90 b/applications/skeleton/source/driver/skeleton_driver_mod.f90 index 9dca0517e..2498bb0ee 100644 --- a/applications/skeleton/source/driver/skeleton_driver_mod.f90 +++ b/applications/skeleton/source/driver/skeleton_driver_mod.f90 @@ -178,7 +178,7 @@ subroutine initialise(program_name, modeldb) ! Build the FEM function spaces and coordinate fields !======================================================================= ! Create FEM specifics (function spaces and chi field) - call init_fem(modeldb, chi_inventory, panel_id_inventory) + call init_fem(modeldb%config, chi_inventory, panel_id_inventory) !======================================================================= ! Create and initialise prognostic fields diff --git a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf index 04eb3c874..db689407e 100644 --- a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf @@ -692,6 +692,7 @@ description=Tile inner halos separately from partition interior. help=Tiling inner halos separately from the partition interior guarantees =that tiles never cross the boundary between interior and inner halo, =which can be useful when overlapping communication and computation. +!kind=default sort-key=Panel-A08 type=logical @@ -776,6 +777,7 @@ help=Tiling reorders computation of cells in the horizontal mesh to maximise =meshes and where mesh partitions have a rectangular shape. Tiles sizes =along partition borders are automatically adjusted to fit, but sizes that =are larger than partition dimensions are not accepted. +!kind=default range=1: sort-key=Panel-A06 type=integer @@ -788,6 +790,7 @@ help=Tiling reorders computation of cells in the horizontal mesh to maximise =meshes and where mesh partitions have a rectangular shape. Tiles sizes =along partition borders are automatically adjusted to fit, but sizes that =are larger than partition dimensions are not accepted. +!kind=default range=1: sort-key=Panel-A07 type=integer diff --git a/components/driver/source/driver_coordinates_mod.F90 b/components/driver/source/driver_coordinates_mod.F90 index 092c997a9..52cec5fc0 100644 --- a/components/driver/source/driver_coordinates_mod.F90 +++ b/components/driver/source/driver_coordinates_mod.F90 @@ -7,10 +7,10 @@ !> @brief Module to assign the values of the coordinates of the mesh to a field. module driver_coordinates_mod + use config_mod, only: config_type use constants_mod, only: r_def, i_def, l_def, & radians_to_degrees, & i_halo_index, eps, pi - use driver_modeldb_mod, only: modeldb_type use log_mod, only: log_event, log_scratch_space, & log_level_error use coord_transform_mod, only: xyz2llr, llr2xyz, identify_panel, & @@ -52,11 +52,11 @@ module driver_coordinates_mod !! from the mesh generator and then 'assign_coordinate' on a column by !! column basis. !> - !> @param[in] modeldb Model state object + !> @param[in] config Configuration object !> @param[in,out] chi Model coordinate array of size 3 of fields !> @param[in] panel_id Field giving the ID of mesh panels !> @param[in] mesh Mesh on which this field is attached - subroutine assign_coordinate_field(modeldb, chi, panel_id, mesh) + subroutine assign_coordinate_field(config, chi, panel_id, mesh) use domain_mod, only: domain_type use field_mod, only: field_type, field_proxy_type @@ -69,7 +69,7 @@ subroutine assign_coordinate_field(modeldb, chi, panel_id, mesh) implicit none - type(modeldb_type), intent(in) :: modeldb + type(config_type), intent(in) :: config type( field_type ), intent( inout ) :: chi(3) type( field_type ), intent( inout ) :: panel_id @@ -113,10 +113,10 @@ subroutine assign_coordinate_field(modeldb, chi, panel_id, mesh) integer(i_def) :: coord_system real(r_def) :: scaled_radius - geometry = modeldb%config%base_mesh%geometry() - topology = modeldb%config%base_mesh%topology() - coord_system = modeldb%config%finite_element%coord_system() - scaled_radius = modeldb%config%planet%scaled_radius() + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() nullify( map, map_pid, dof_coords, reference_element ) diff --git a/components/driver/source/driver_counter_mod.f90 b/components/driver/source/driver_counter_mod.f90 index 41b255c7b..5853e98de 100644 --- a/components/driver/source/driver_counter_mod.f90 +++ b/components/driver/source/driver_counter_mod.f90 @@ -7,9 +7,9 @@ !> module driver_counter_mod - use count_mod, only: count_type, halo_calls - use driver_modeldb_mod, only: modeldb_type - use timer_mod, only: timer, output_timer, init_timer + use config_mod, only: config_type + use count_mod, only: count_type, halo_calls + use timer_mod, only: timer, output_timer, init_timer implicit none @@ -23,18 +23,19 @@ module driver_counter_mod !> As well as initialising the system a "top level" counter is set up !? for tracking halo calls. !> + !> @param[in] config Configuration object !> @param[in] identifier Top level halo name. !> - subroutine init_counters( modeldb, identifier ) + subroutine init_counters(config, identifier) implicit none - type(modeldb_type), intent(in) :: modeldb - character(*), intent(in) :: identifier + type(config_type), intent(in) :: config + character(*), intent(in) :: identifier logical(l_def) :: subroutine_counters - subroutine_counters = modeldb%config%io%subroutine_counters() + subroutine_counters = config%io%subroutine_counters() if ( subroutine_counters ) then allocate( halo_calls, source=count_type('halo_calls') ) @@ -52,20 +53,21 @@ end subroutine init_counters !> @todo Reconsider the existance of the simple counter system once the !> profiler is integrated. !> + !> @param[in] config Configuration object !> @param[in] identifier Top level counter name. !> - subroutine final_counters(modeldb, identifier ) + subroutine final_counters(config, identifier) implicit none - type(modeldb_type), intent(in) :: modeldb - character(*), intent(in) :: identifier + type(config_type), intent(in) :: config + character(*), intent(in) :: identifier logical(l_def) :: subroutine_counters character(str_def) :: counter_output_suffix - subroutine_counters = modeldb%config%io%subroutine_counters() - counter_output_suffix = modeldb%config%io%counter_output_suffix() + subroutine_counters = config%io%subroutine_counters() + counter_output_suffix = config%io%counter_output_suffix() if (subroutine_counters) then call halo_calls%counter( identifier ) diff --git a/components/driver/source/driver_fem_mod.f90 b/components/driver/source/driver_fem_mod.f90 index 86255f7a4..f61ba507a 100644 --- a/components/driver/source/driver_fem_mod.f90 +++ b/components/driver/source/driver_fem_mod.f90 @@ -14,9 +14,8 @@ module driver_fem_mod use sci_chi_transform_mod, only: init_chi_transforms, & final_chi_transforms + use config_mod, only: config_type use constants_mod, only: i_def, l_def, str_def - use driver_modeldb_mod, only: modeldb_type - use extrusion_mod, only: TWOD, PRIME_EXTRUSION use field_mod, only: field_type use fs_continuity_mod, only: W0, W2, W3, Wtheta, Wchi, W2v, W2h @@ -47,17 +46,17 @@ module driver_fem_mod !> @brief Initialises the coordinate fields (chi) and FEM components. !> - !> @param[in] modeldb Model state object + !> @param[in] config Configuration object !> @param[in,out] chi_inventory Inventory object, containing all of !! the chi fields indexed by mesh !> @param[in,out] panel_id_inventory Inventory object, containing all of !! the fields with the ID of mesh panels - subroutine init_fem( modeldb, chi_inventory, panel_id_inventory ) + subroutine init_fem(config, chi_inventory, panel_id_inventory) implicit none ! Coordinate field - type(modeldb_type), intent(in) :: modeldb + type(config_type), intent(in) :: config type(inventory_by_mesh_type), intent(inout) :: chi_inventory type(inventory_by_mesh_type), intent(inout) :: panel_id_inventory @@ -78,9 +77,9 @@ subroutine init_fem( modeldb, chi_inventory, panel_id_inventory ) nullify(mesh, twod_mesh, fs) - coord_order = modeldb%config%finite_element%coord_order() - geometry = modeldb%config%base_mesh%geometry() - topology = modeldb%config%base_mesh%topology() + coord_order = config%finite_element%coord_order() + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() ! ======================================================================== ! ! Initialise coordinates @@ -137,7 +136,7 @@ subroutine init_fem( modeldb, chi_inventory, panel_id_inventory ) end do ! Set coordinate fields -------------------------------------------------- - call assign_coordinate_field(modeldb, chi, panel_id, mesh) + call assign_coordinate_field(config, chi, panel_id, mesh) ! Add fields to inventory call chi_inventory%copy_field_array(chi, mesh) diff --git a/components/driver/source/driver_mesh_mod.f90 b/components/driver/source/driver_mesh_mod.f90 index eb83b9754..dc524efcf 100644 --- a/components/driver/source/driver_mesh_mod.f90 +++ b/components/driver/source/driver_mesh_mod.f90 @@ -116,14 +116,6 @@ subroutine init_mesh( config, & character(str_def), optional, intent(in) :: alt_names(:) - ! Optional, tile_size which overrides settings in configuration - ! Only here to provide continuity with multigrid tiling. - ! Should be removed in future as application/user should be - ! responsible for setting the correctly desired tiling - !option in the config object - - - ! Parameters character(len=9), parameter :: routine_name = 'init_mesh' @@ -139,14 +131,6 @@ subroutine init_mesh( config, & integer :: topology integer :: mesh_selection -!!$ ! Multigrid related -!!$ character(str_def), allocatable :: chain_mesh_tags(:) - -!!$ logical(l_def) :: coarsen_multigrid_tiles -! integer(i_def) :: tile_size(2) -!!$ integer(i_def) :: tile_size_y -!!$ integer(i_def) :: max_tiled_multigrid_level - ! Local variables character(str_def), allocatable :: names(:) character(str_def), allocatable :: tmp_mesh_names(:) @@ -160,44 +144,13 @@ subroutine init_mesh( config, & character(str_def) :: fmt_str, number_str integer(i_def) :: i, n_digit -!!$ integer(i_def) :: tile_size_x -!!$ integer(i_def) :: tile_size_y -!!$ integer(i_def) :: tiling(2) !============================================================================ ! Extract configuration variables !============================================================================ - prepartitioned = config%base_mesh%prepartitioned() - file_prefix = config%base_mesh%file_prefix() - cellshape = config%finite_element%cellshape() - -!!$ if (prepartitioned) then -!!$ tile_size_x = 1 -!!$ tile_size_y = 1 -!!$ inner_halo_tiles = .false. -!!$ else -!!$ tile_size_x = config%partitioning%tile_size_x() -!!$ tile_size_y = config%partitioning%tile_size_y() -!!$ inner_halo_tiles = config%partitioning%inner_halo_tiles() -!!$ end if -!!$ -!!$ if (present(tile_size)) then -!!$ tiling = tile_size -!!$ else -!!$ tiling = [tile_size_x, tile_size_y] -!!$ end if -! tile_size(:) = 1 -! if ( tile_size_x /= imdi ) tile_size(1) = tile_size_x -! if ( tile_size_y /= imdi ) tile_size(2) = tile_size_y - - - ! Temporary extraction, These configuration varaibles need - ! to be refactored out. -!!$ chain_mesh_tags = config%multigrid% chain_mesh_tags() -!!$ inner_halo_tiles = config%partitioning%inner_halo_tiles() - -!!$ max_tiled_multigrid_level = config%partitioning%max_tiled_multigrid_level() -!!$ coarsen_multigrid_tiles = config%partitioning%coarsen_multigrid_tiles() + prepartitioned = config%base_mesh%prepartitioned() + file_prefix = config%base_mesh%file_prefix() + cellshape = config%finite_element%cellshape() if ( .not. prepartitioned ) then generate_inner_halos = config%partitioning%generate_inner_halos() @@ -379,10 +332,6 @@ subroutine init_mesh( config, & end if ! prepartitioned -!!$ inner_halo_tiles = config%partitioning%inner_halo_tiles() -!!$ tile_size(1) = config%partitioning%tile_size_x() -!!$ tile_size(2) = config%partitioning%tile_size_y() - !============================================================================ ! 3.0 Extrude the specified meshes from local mesh objects into ! mesh objects on the given extrusion. diff --git a/components/driver/source/mesh/create_mesh_mod.f90 b/components/driver/source/mesh/create_mesh_mod.f90 index 41e908da6..bc80bedb5 100644 --- a/components/driver/source/mesh/create_mesh_mod.f90 +++ b/components/driver/source/mesh/create_mesh_mod.f90 @@ -6,7 +6,6 @@ !> @brief Functions/Routines related to creating a module create_mesh_mod -! use config_mod, only: config_type use constants_mod, only: i_def, str_def, r_def, l_def, imdi, & str_max_filename use log_mod, only: log_event, & @@ -93,9 +92,10 @@ end function create_extrusion !! held in the application local_mesh_collection and the !! specified extrusion. !! -!> @param[in] config Model configuration object !> @param[in] local_mesh_names Names of the local_mesh_types to extrude. !> @param[in] extrusion Extrusion to employ. +!> @param[in] local_halo_tiles +!> @param[in] tile_size !> @param[in] alt_name Optional, Alternative names for the !! extruded meshes, defaults to local_mesh_names !! if absent. diff --git a/components/driver/unit-test/assign_coordinate_xyz_mod_test.pf b/components/driver/unit-test/assign_coordinate_xyz_mod_test.pf index bf888f210..37eaac9ef 100644 --- a/components/driver/unit-test/assign_coordinate_xyz_mod_test.pf +++ b/components/driver/unit-test/assign_coordinate_xyz_mod_test.pf @@ -8,33 +8,26 @@ module assign_coordinate_xyz_mod_test use constants_mod, only : r_def, i_def + + use base_mesh_config_mod, only: geometry_planar, topology_fully_periodic use funit implicit none private - public :: assign_coordinate_xyz_test_type, test_all - - @TestCase - type, extends(TestCase) :: assign_coordinate_xyz_test_type - private - contains - procedure test_all - end type assign_coordinate_xyz_test_type + public :: test_all contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @Test - subroutine test_all( this ) + subroutine test_all() use driver_coordinates_mod, only : assign_coordinate_xyz - use base_mesh_config_mod, only: geometry_planar, topology_fully_periodic - implicit none - class(assign_coordinate_xyz_test_type), intent(inout) :: this + implicit none real(kind=r_def), parameter :: tol = 1.0e-3_r_def, & one = 1.0_r_def diff --git a/components/driver/unit-test/mesh/create_mesh_mod_test.pf b/components/driver/unit-test/mesh/create_mesh_mod_test.pf index a029c1868..313ca4394 100644 --- a/components/driver/unit-test/mesh/create_mesh_mod_test.pf +++ b/components/driver/unit-test/mesh/create_mesh_mod_test.pf @@ -139,7 +139,6 @@ contains integer(i_def) :: xyprocs(2) integer(i_def) :: max_stencil_depth logical(l_def) :: generate_inner_halos -! integer(i_def) :: tile_size(2) character(str_max_filename), parameter :: filename = & 'data/mesh_BiP8x8-750x250.nc' character(str_def), parameter :: mesh_name = 'unit_test' @@ -155,19 +154,6 @@ contains max_stencil_depth, generate_inner_halos, & 0_i_def, 1_i_def) -!!$ call feign_partitioning_config( coarsen_multigrid_tiles = .false., & -!!$ generate_inner_halos = .true., & -!!$ inner_halo_tiles = .false., & -!!$ max_tiled_multigrid_level = 1_i_def, & -!!$ panel_decomposition = & -!!$ panel_decomposition_auto, & -!!$ panel_xproc = 1_i_def, & -!!$ panel_yproc = 1_i_def, & -!!$ partitioner = & -!!$ partitioner_planar, & -!!$ tile_size_x = 1_i_def, & -!!$ tile_size_y = 1_i_def ) - allocate( extrusion, source=create_extrusion( METHOD_UNIFORM, & 100.0_r_def, & 10000.0_r_def, & @@ -176,7 +162,7 @@ contains ! Check that exactly one mesh is added to the collection @assertEqual( mesh_collection%n_meshes(), 0 ) -! tile_size = [1,1] + call create_mesh( mesh_name, extrusion, & inner_halo_tiles=.false., & tile_size=[1,1] ) diff --git a/components/science/source/algorithm/sci_mapping_constants_mod.x90 b/components/science/source/algorithm/sci_mapping_constants_mod.x90 index ff1e0e0c6..54aa2f101 100644 --- a/components/science/source/algorithm/sci_mapping_constants_mod.x90 +++ b/components/science/source/algorithm/sci_mapping_constants_mod.x90 @@ -223,6 +223,16 @@ contains type(operator_type), pointer :: u_lat_map type(operator_type), pointer :: u_up_map + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() + if (.not. u_lon_map_inventory%is_initialised()) then call u_lon_map_inventory%initialise(name='u_lon_map') end if @@ -247,15 +257,14 @@ contains call u_lat_map_inventory%add_operator(u_lat_map, w2_fs, w3_fs, mesh) call u_up_map_inventory%add_operator(u_up_map, w2_fs, wtheta_fs, mesh) - call invoke( name="compute_lonlatr_galerkin_operators", & - compute_map_u_operators_kernel_type(u_lon_map, & - u_lat_map, & - u_up_map, & - chi, panel_id, & - config%base_mesh%geometry(), & - config%base_mesh%topology(), & - config%finite_element%coord_system(), & - config%planet%scaled_radius(), & + call invoke( name="compute_lonlatr_galerkin_operators", & + compute_map_u_operators_kernel_type(u_lon_map, & + u_lat_map, & + u_up_map, & + chi, panel_id, & + geometry, topology, & + coord_system, & + scaled_radius, & qr) ) end subroutine create_spherical_components_to_w2_projection @@ -285,6 +294,16 @@ contains type(operator_type), pointer :: u_up_sample integer(tik) :: id + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() + if (.not. u_lon_sample_inventory%is_initialised()) then call u_lon_sample_inventory%initialise(name='u_lon_sample') end if @@ -310,15 +329,14 @@ contains call u_lat_sample_inventory%add_operator(u_lat_sample, w2_fs, w3_fs, mesh) call u_up_sample_inventory%add_operator(u_up_sample, w2_fs, wtheta_fs, mesh) - call invoke( name="compute_lonlatr_sample_operators", & - compute_sample_u_ops_kernel_type(u_lon_sample, & - u_lat_sample, & - u_up_sample, & - chi, panel_id, & - config%base_mesh%geometry(), & - config%base_mesh%topology(), & - config%finite_element%coord_system(), & - config%planet%scaled_radius() ) ) + call invoke( name="compute_lonlatr_sample_operators", & + compute_sample_u_ops_kernel_type(u_lon_sample, & + u_lat_sample, & + u_up_sample, & + chi, panel_id, & + geometry, topology, & + coord_system, & + scaled_radius) ) if ( LPROF ) call stop_timing( id, 'runtime_constants.mapping' ) @@ -1044,6 +1062,16 @@ contains integer(kind=i_def), parameter :: xdirection = 1_i_def integer(tik) :: id + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() + ! Check inventory is initialised if (.not. project_lon_dot_to_w1_inventory%is_initialised()) then call project_lon_dot_to_w1_inventory%initialise( & @@ -1069,14 +1097,13 @@ contains proj_op, w1_fs, w3_fs, mesh & ) - call invoke( name='proj_lon_dot_to_w1_op', & - project_ws_to_w1_operator_kernel_type(proj_op, & - chi, panel_id, & - xdirection, & - config%base_mesh%geometry(), & - config%base_mesh%topology(), & - config%finite_element%coord_system(), & - config%planet%scaled_radius(), & + call invoke( name='proj_lon_dot_to_w1_op', & + project_ws_to_w1_operator_kernel_type(proj_op, & + chi, panel_id, & + xdirection, & + geometry, topology, & + coord_system, & + scaled_radius, & qr) ) if ( LPROF ) call stop_timing( id, 'runtime_constants.mapping' ) @@ -1109,6 +1136,16 @@ contains integer(kind=i_def), parameter :: ydirection = 2_i_def integer(tik) :: id + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() + ! Check inventory is initialised if (.not. project_lat_dot_to_w1_inventory%is_initialised()) then call project_lat_dot_to_w1_inventory%initialise( & @@ -1134,14 +1171,13 @@ contains proj_op, w1_fs, w3_fs, mesh & ) - call invoke( name='proj_lat_dot_to_w1_op', & - project_ws_to_w1_operator_kernel_type(proj_op, & - chi, panel_id, & - ydirection, & - config%base_mesh%geometry(), & - config%base_mesh%topology(), & - config%finite_element%coord_system(), & - config%planet%scaled_radius(), & + call invoke( name='proj_lat_dot_to_w1_op', & + project_ws_to_w1_operator_kernel_type(proj_op, & + chi, panel_id, & + ydirection, & + geometry, topology, & + coord_system, & + scaled_radius, & qr) ) if ( LPROF ) call stop_timing( id, 'runtime_constants.mapping' ) @@ -1174,6 +1210,16 @@ contains integer(kind=i_def), parameter :: zdirection = 3_i_def integer(tik) :: id + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() + ! Check inventory is initialised if (.not. project_r_dot_to_w1_inventory%is_initialised()) then call project_r_dot_to_w1_inventory%initialise(name='project_r_dot_to_w1') @@ -1197,14 +1243,13 @@ contains proj_op, w1_fs, w3_fs, mesh & ) - call invoke( name='proj_r_dot_to_w1_op', & - project_ws_to_w1_operator_kernel_type(proj_op, & - chi, panel_id, & - zdirection, & - config%base_mesh%geometry(), & - config%base_mesh%topology(), & - config%finite_element%coord_system(), & - config%planet%scaled_radius(), & + call invoke( name='proj_r_dot_to_w1_op', & + project_ws_to_w1_operator_kernel_type(proj_op, & + chi, panel_id, & + zdirection, & + geometry, topology, & + coord_system, & + scaled_radius, & qr) ) if ( LPROF ) call stop_timing( id, 'runtime_constants.mapping' ) @@ -1239,6 +1284,16 @@ contains type(function_space_type), pointer :: w3_k0_fs integer(tik) :: id + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() + ! Initialise inventory if this is the first time getting this constant if (.not. w3_to_w2_displacement_inventory%is_initialised()) then call w3_to_w2_displacement_inventory%initialise( & @@ -1269,13 +1324,12 @@ contains w2h_k0_fs, local_mesh) call dummy_w3%initialise( w3_k0_fs ) - call invoke( setval_c(w3_to_w2_displacement, 0.0_r_def), & - w3_to_w2_displacement_kernel_type(w3_to_w2_displacement, & - chi, panel_id, dummy_w3, & - config%base_mesh%geometry(), & - config%base_mesh%topology(), & - config%finite_element%coord_system(), & - config%planet%scaled_radius() ) ) + call invoke( setval_c(w3_to_w2_displacement, 0.0_r_def), & + w3_to_w2_displacement_kernel_type(w3_to_w2_displacement, & + chi, panel_id, dummy_w3, & + geometry, topology, & + coord_system, & + scaled_radius) ) if ( LPROF ) call stop_timing( id, 'runtime_constants.mapping' ) end if diff --git a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 index 3cc55ec22..0d9f4a84b 100644 --- a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 +++ b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 @@ -255,8 +255,9 @@ end subroutine final_chi_transforms !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- -subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, coord_system, scaled_radius, & +subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & x, y, z ) implicit none @@ -436,8 +437,9 @@ end subroutine chir2xyz !! @param[out] latitude The second coordinate field out (latitude) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, coord_system, scaled_radius, & +subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & lon, lat, radius ) implicit none @@ -519,8 +521,9 @@ end subroutine chi2llr !! @param[out] beta The second coordinate field out (beta) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, coord_system, scaled_radius, & +subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & alpha, beta, radius ) implicit none diff --git a/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 index ea65d9e3b..6bb82c7e2 100644 --- a/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 @@ -42,7 +42,7 @@ module sci_w3_to_w2_displacement_kernel_mod arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system - arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius /) type(func_type) :: meta_funcs(1) = (/ & func_type(Wchi, GH_BASIS) & diff --git a/rose-stem/app/coupled/rose-app.conf b/rose-stem/app/coupled/rose-app.conf index 67be91894..64da50c16 100644 --- a/rose-stem/app/coupled/rose-app.conf +++ b/rose-stem/app/coupled/rose-app.conf @@ -76,13 +76,13 @@ multigrid_chain_nitems=1 [namelist:partitioning] generate_inner_halos=.true. +inner_halo_tiles=.false. panel_decomposition='auto' !!panel_xproc=0 !!panel_yproc=0 partitioner='cubedsphere' -tile_size_x=1, -tile_size_y=1, -inner_halo_tile=.false. +tile_size_x=1 +tile_size_y=1 [namelist:planet] scaling_factor=125.0 diff --git a/rose-stem/app/io_demo/rose-app.conf b/rose-stem/app/io_demo/rose-app.conf index e586d9828..42542dc29 100644 --- a/rose-stem/app/io_demo/rose-app.conf +++ b/rose-stem/app/io_demo/rose-app.conf @@ -85,13 +85,13 @@ multigrid_chain_nitems=1 [namelist:partitioning] generate_inner_halos=.false. +inner_halo_tiles=.false. panel_decomposition='auto' !!panel_xproc=1 !!panel_yproc=1 partitioner='planar' -tile_size_x=1, -tile_size_y=1, -inner_halo_tile=.false. +tile_size_x=1 +tile_size_y=1 [namelist:planet] scaling_factor=125.0 diff --git a/rose-stem/app/lbc_demo/rose-app.conf b/rose-stem/app/lbc_demo/rose-app.conf index 77017514b..d5af0b010 100644 --- a/rose-stem/app/lbc_demo/rose-app.conf +++ b/rose-stem/app/lbc_demo/rose-app.conf @@ -79,13 +79,13 @@ run_log_level='info' [!!namelist:partitioning] generate_inner_halos=.false. +inner_halo_tiles=.false. panel_decomposition='auto' !!panel_xproc=1 !!panel_yproc=1 partitioner='planar' -tile_size_x=1, -tile_size_y=1, -inner_halo_tile=.false. +tile_size_x=1 +tile_size_y=1 [namelist:planet] scaling_factor=125.0 diff --git a/rose-stem/app/simple_diffusion/rose-app.conf b/rose-stem/app/simple_diffusion/rose-app.conf index a35de9007..224ac40d5 100644 --- a/rose-stem/app/simple_diffusion/rose-app.conf +++ b/rose-stem/app/simple_diffusion/rose-app.conf @@ -77,13 +77,13 @@ multigrid_chain_nitems=1 [namelist:partitioning] generate_inner_halos=.true. +inner_halo_tiles=.false. panel_decomposition='auto' !!panel_xproc=1 !!panel_yproc=1 partitioner='planar' -tile_size_x=1, -tile_size_y=1, -inner_halo_tile=.false. +tile_size_x=1 +tile_size_y=1 [namelist:planet] scaling_factor=125.0 diff --git a/rose-stem/app/skeleton/rose-app.conf b/rose-stem/app/skeleton/rose-app.conf index 9d65aecb0..52749b3ea 100644 --- a/rose-stem/app/skeleton/rose-app.conf +++ b/rose-stem/app/skeleton/rose-app.conf @@ -74,13 +74,13 @@ multigrid_chain_nitems=1 [namelist:partitioning] generate_inner_halos=.true. +inner_halo_tiles=.false. panel_decomposition='auto' !!panel_xproc=1 !!panel_yproc=1 partitioner='planar' -tile_size_x=1, -tile_size_y=1, -inner_halo_tile=.false. +tile_size_x=1 +tile_size_y=1 [namelist:planet] scaling_factor=125.0 From 425943272eee99e82e432f8357f335fea5a8803a Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Mon, 23 Mar 2026 12:20:44 +0000 Subject: [PATCH 05/44] Update multitile provision --- .../lfric-driver/HEAD/rose-meta.conf | 36 +++--- .../driver/source/mesh/create_mesh_mod.f90 | 8 +- .../driver/source/mesh/multigrid_mod.f90 | 112 ++++++++++++++++++ rose-stem/app/coupled/rose-app.conf | 2 + rose-stem/app/io_demo/rose-app.conf | 2 + rose-stem/app/simple_diffusion/rose-app.conf | 2 + rose-stem/app/skeleton/rose-app.conf | 2 + 7 files changed, 142 insertions(+), 22 deletions(-) create mode 100644 components/driver/source/mesh/multigrid_mod.f90 diff --git a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf index db689407e..716576fef 100644 --- a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf @@ -629,6 +629,24 @@ sort-key=Panel-A04 !string_length=default type=character +[namelist:multigrid=coarsen_multigrid_tiles] +compulsory=true +description=Reduce x and y tile sizes by a factor of 2 in each multigrid level +help=Enables using larger tiles at higher resolution levels by automatically + =reducing tile sizes in coarser levels, which can improve performance. +sort-key=Panel-A10 +type=logical + +[namelist:multigrid=max_tiled_multigrid_level] +compulsory=true +description=Coarsest multigrid level to be tiled +help=Revert to 1x1 tiling (equivalent to colouring) for multigrid levels + =above this threshold (level 1 has highest resolution); tiling is + =typically more beneficial for higher resolutions. +range=1: +sort-key=Panel-A09 +type=integer + [namelist:multigrid=multigrid_chain_nitems] compulsory=true description=Number of items in multigrid function space chain @@ -669,14 +687,6 @@ help=For parallel computing, the 2D global mesh is divided up into partitions. ns=namelist/Model/Mesh/Partitioning sort-key=Section-A02 -[namelist:partitioning=coarsen_multigrid_tiles] -compulsory=false -description=Reduce x and y tile sizes by a factor of 2 in each multigrid level -help=Enables using larger tiles at higher resolution levels by automatically - =reducing tile sizes in coarser levels, which can improve performance. -sort-key=Panel-A10 -type=logical - [namelist:partitioning=generate_inner_halos] compulsory=true description=Generate inner halo regions @@ -696,16 +706,6 @@ help=Tiling inner halos separately from the partition interior guarantees sort-key=Panel-A08 type=logical -[namelist:partitioning=max_tiled_multigrid_level] -compulsory=false -description=Coarsest multigrid level to be tiled -help=Revert to 1x1 tiling (equivalent to colouring) for multigrid levels - =above this threshold (level 1 has highest resolution); tiling is - =typically more beneficial for higher resolutions. -range=1: -sort-key=Panel-A09 -type=integer - [namelist:partitioning=panel_decomposition] compulsory=true description=Panel partition decomposition diff --git a/components/driver/source/mesh/create_mesh_mod.f90 b/components/driver/source/mesh/create_mesh_mod.f90 index bc80bedb5..8aec9e0cc 100644 --- a/components/driver/source/mesh/create_mesh_mod.f90 +++ b/components/driver/source/mesh/create_mesh_mod.f90 @@ -17,10 +17,10 @@ module create_mesh_mod use extrusion_mod, only: extrusion_type, & uniform_extrusion_type, & geometric_extrusion_type, & - quadratic_extrusion_type, & - PRIME_EXTRUSION, & - SHIFTED, & - DOUBLE_LEVEL + quadratic_extrusion_type!, & +! PRIME_EXTRUSION, & +! SHIFTED, & +! DOUBLE_LEVEL use local_mesh_mod, only: local_mesh_type use mesh_mod, only: mesh_type use sci_query_mod, only: check_lbc diff --git a/components/driver/source/mesh/multigrid_mod.f90 b/components/driver/source/mesh/multigrid_mod.f90 new file mode 100644 index 000000000..365b8b638 --- /dev/null +++ b/components/driver/source/mesh/multigrid_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. +!----------------------------------------------------------------------------- + +module multigrid_mod + + use extrusion_mod, only: extrusion_type, prime_extrusion, & + shifted, double_level + use config_mod, only: config_type + use constants_mod, only: i_def, l_def, str_def + + implicit none + + public :: get_multigrid_tile_size + + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> @brief +!> +!> @param[in] config +!> @param[in] local_mesh_name +!> @param[in] extrusion +!> +!> @return tile_size +!> +subroutine get_multigrid_tile_size( config, local_mesh_names, extrusion, & + tile_size ) + + implicit none + + type(config_type), intent(in) :: config + character(str_def), intent(in) :: local_mesh_names(:) + type(extrusion_type), intent(in) :: extrusion + + integer(i_def), intent(inout) :: tile_size(:,:) + + + + integer(i_def) :: multigrid_level + integer(i_def) :: max_multigrid_level + logical(l_def) :: coarsen_multigrid_tiles + logical(l_def) :: set_tile_size + + character(str_def), allocatable :: chain_mesh_tags(:) + + !========================================================================= + ! This whole section should probably be in gungho science. It allows the + ! Gungho multigrid scheme to override the tile settings in the + ! configuration. This should really be written in the gungho science, + ! though the decision to call it should be made by the application, i.e. + ! the application may wish to use it's own tileing settings. + ! + ! In partitioning namelist, should be in multigrid + ! max_tiled_multigrid_level = config%multigrid%max_tiled_multigrid_level() + ! coarsen_multigrid_tiles = config%multigrid%coarsen_multigrid_tiles() + coarsen_multigrid_tiles = config%multigrid%coarsen_multigrid_tiles() + max_multigrid_level = config%multigrid%max_tiled_multigrid_level() + chain_mesh_tags = config%multigrid%chain_mesh_tags() + + extrusion_id = extrusion%get_id() + + !========================================================================= + if (coarsen_multigrid_tiles) then + + select case (extrusion_id) + case(prime_extrusion, shifted, double_level) + + ! Set coarsest multigrid level that will be tiled; + ! restrict to the finest grid by default + if (max_multigrid_level == imdi) then + call log_event('no max multigrid level set', log_level_error) + end if + + do i=1, size(local_mesh_names) + set_tile_size = .false. + name =local_mesh_names(i) + + ! Multigrid setup - use tiling if multigrid level is allowed, and + ! if mesh name includes the mesh tag at that level + do multigrid_level=1, size(chain_mesh_tags) + if ( index( trim(name), & + trim(chain_mesh_tags(multigrid_level)) ) > 0 & + .and. multigrid_level <= max_multigrid_level ) then + set_tile_size = .true. + exit + end if + end do + + if (set_tile_size) then + do multigrid_level=1, size(chain_mesh_tags) + if ( index( trim(name), & + trim(chain_mesh_tags(multigrid_level)) ) > 0 ) then + exit + end if + tile_size(:,i) = max( tile_size(:,i)/2, 1 ) + end do + end if ! set_tile_size + end do ! local_mesh_names + + case default + return + end select + + end if ! Coarsen multigrid_tiles + +end subroutine get_multigrid_tile_size + +end module multigrid_mod diff --git a/rose-stem/app/coupled/rose-app.conf b/rose-stem/app/coupled/rose-app.conf index 64da50c16..a3f42e9d7 100644 --- a/rose-stem/app/coupled/rose-app.conf +++ b/rose-stem/app/coupled/rose-app.conf @@ -72,6 +72,8 @@ run_log_level='info' [namelist:multigrid] chain_mesh_tags='' +coarsen_multigrid_tiles=.false. +max_tiled_multigrid_level=1 multigrid_chain_nitems=1 [namelist:partitioning] diff --git a/rose-stem/app/io_demo/rose-app.conf b/rose-stem/app/io_demo/rose-app.conf index 42542dc29..abb38ba8b 100644 --- a/rose-stem/app/io_demo/rose-app.conf +++ b/rose-stem/app/io_demo/rose-app.conf @@ -81,6 +81,8 @@ run_log_level='info' [namelist:multigrid] chain_mesh_tags='' +coarsen_multigrid_tiles=.false. +max_tiled_multigrid_level=1 multigrid_chain_nitems=1 [namelist:partitioning] diff --git a/rose-stem/app/simple_diffusion/rose-app.conf b/rose-stem/app/simple_diffusion/rose-app.conf index 224ac40d5..b63fc93f7 100644 --- a/rose-stem/app/simple_diffusion/rose-app.conf +++ b/rose-stem/app/simple_diffusion/rose-app.conf @@ -73,6 +73,8 @@ run_log_level='info' [namelist:multigrid] chain_mesh_tags='' +coarsen_multigrid_tiles=.false. +max_tiled_multigrid_level=1 multigrid_chain_nitems=1 [namelist:partitioning] diff --git a/rose-stem/app/skeleton/rose-app.conf b/rose-stem/app/skeleton/rose-app.conf index 52749b3ea..132e0a428 100644 --- a/rose-stem/app/skeleton/rose-app.conf +++ b/rose-stem/app/skeleton/rose-app.conf @@ -70,6 +70,8 @@ run_log_level='info' [namelist:multigrid] chain_mesh_tags='' +coarsen_multigrid_tiles=.false. +max_tiled_multigrid_level=1 multigrid_chain_nitems=1 [namelist:partitioning] From 97a85fe248b4919b47691ce9b0db3b1f4d16475c Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Tue, 24 Mar 2026 10:03:55 +0000 Subject: [PATCH 06/44] Update --- .../driver/source/driver_counter_mod.f90 | 11 +- .../algorithm/sci_geometric_constants_mod.x90 | 128 ++++++++++++------ 2 files changed, 95 insertions(+), 44 deletions(-) diff --git a/components/driver/source/driver_counter_mod.f90 b/components/driver/source/driver_counter_mod.f90 index 5853e98de..21865e95f 100644 --- a/components/driver/source/driver_counter_mod.f90 +++ b/components/driver/source/driver_counter_mod.f90 @@ -7,9 +7,10 @@ !> module driver_counter_mod - use config_mod, only: config_type - use count_mod, only: count_type, halo_calls - use timer_mod, only: timer, output_timer, init_timer + use config_mod, only: config_type + use constants_mod, only: str_max_filename, l_def + use count_mod, only: count_type, halo_calls + use timer_mod, only: timer, output_timer, init_timer implicit none @@ -63,8 +64,8 @@ subroutine final_counters(config, identifier) type(config_type), intent(in) :: config character(*), intent(in) :: identifier - logical(l_def) :: subroutine_counters - character(str_def) :: counter_output_suffix + logical(l_def) :: subroutine_counters + character(str_max_filename) :: counter_output_suffix subroutine_counters = config%io%subroutine_counters() counter_output_suffix = config%io%counter_output_suffix() diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90 b/components/science/source/algorithm/sci_geometric_constants_mod.x90 index 3d6efe65f..dea422af4 100644 --- a/components/science/source/algorithm/sci_geometric_constants_mod.x90 +++ b/components/science/source/algorithm/sci_geometric_constants_mod.x90 @@ -440,22 +440,22 @@ contains !> @brief Returns the (finite element) Det(J) values at W3 dof locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field - function get_detj_at_w3_fe(mesh_id) result(detj_at_w3) + function get_detj_at_w3_fe(config, mesh_id) result(detj_at_w3) ! @TODO #4487: update these imports ! use sci_calc_detj_at_w3_kernel_mod, only: calc_detj_at_w3_kernel_type use sci_compute_mass_matrix_kernel_w_scalar_mod, & only: compute_mass_matrix_kernel_w_scalar_type use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type - use finite_element_config_mod, only: nqp_h_exact, & - nqp_v_exact use operator_mod, only: operator_type use quadrature_xyoz_mod, only: quadrature_xyoz_type use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type implicit none + type(config_type), intent(in) :: config integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh logical(kind=l_def) :: constant_exists type(field_type), pointer :: detj_at_w3 @@ -469,8 +469,17 @@ contains type(quadrature_rule_gaussian_type) :: quadrature_rule integer(tik) :: id + integer(i_def) :: nqp_h_exact, nqp_v_exact + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + + nqp_h_exact = config%finite_element%nqp_h_exact() + nqp_v_exact = config%finite_element%nqp_v_exact() + ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then + if (order_h == 0 .and. order_v == 0) then detj_at_w3 => get_detj_at_w3_fv(mesh_id) return end if @@ -491,8 +500,7 @@ contains ! Create the object as it doesn't exist yet if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - w3_fs => function_space_collection%get_fs(mesh, element_order_h, & - element_order_v, W3) + w3_fs => function_space_collection%get_fs(mesh, order_h, order_v, W3) call detj_at_w3_inventory_fe%add_field(detj_at_w3, w3_fs, mesh) ! @TODO #4487: it is inefficient to calculate this via mass matrices @@ -593,14 +601,16 @@ contains !> @brief Returns the (finite element) Det(J) values at W2 dof locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field - function get_detj_at_w2_fe(mesh_id) result(detj_at_w2) + function get_detj_at_w2_fe(config, mesh_id) result(detj_at_w2) use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type implicit none - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh logical(kind=l_def) :: constant_exists type(field_type), pointer :: detj_at_w2 @@ -610,8 +620,13 @@ contains type(function_space_type), pointer :: w2_fs integer(tik) :: id + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then + if (order_h == 0 .and. order_v == 0) then detj_at_w2 => get_detj_at_w2_fv(mesh_id) return end if @@ -632,8 +647,7 @@ contains ! Create the object as it doesn't exist yet if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - w2_fs => function_space_collection%get_fs(mesh, element_order_h, & - element_order_v, W2) + w2_fs => function_space_collection%get_fs(mesh, order_h, order_v, W2) call multiplicity_w2%initialise( w2_fs ) call detj_at_w2_inventory_fe%add_field(detj_at_w2, w2_fs, mesh) @@ -710,13 +724,15 @@ contains !> @brief Returns a pointer to the vertical grid spacing, located at W3 DoFs !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The physical height difference of layers, at W3 - function get_dz_w3(mesh_id) result(dz_w3) + function get_dz_w3(config, mesh_id) result(dz_w3) use sci_get_dz_w3_kernel_mod, only: get_dz_w3_kernel_type implicit none - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(field_type), pointer :: dz_w3 logical(kind=l_def) :: constant_exists @@ -735,7 +751,7 @@ contains if (.not. constant_exists) then ! If this constant doesn't exist, create it ! Get height first to avoid potentially timing twice - height_w2 => get_height_fv(W2, mesh_id) + height_w2 => get_height_fv(config, W2, mesh_id) if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) @@ -844,13 +860,15 @@ contains !> @brief Returns the 1/dz values at lowest-order Wtheta DoF locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The dz_at_wtheta field - function get_dz_at_wtheta(mesh_id) result(dz_at_wtheta) + function get_dz_at_wtheta(config, mesh_id) result(dz_at_wtheta) use sci_calc_dz_face_kernel_mod, only: calc_dz_face_kernel_type implicit none - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(field_type), pointer :: dz_at_wtheta type(function_space_type), pointer :: wtheta_k0_fs @@ -874,8 +892,8 @@ contains ! Create constant if it doesn't already exist if (.not. constant_exists) then ! NB: this assumes heights are in the lowest-order space - height_w3 => get_height_fv(W3, mesh_id) - height_wth => get_height_fv(Wtheta, mesh_id) + height_w3 => get_height_fv(config, W3, mesh_id) + height_wth => get_height_fv(config, Wtheta, mesh_id) if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) @@ -898,15 +916,15 @@ contains !> i.e. ignoring the orographic effect on the area !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The dA_msl_proj field - function get_dA_msl_proj(mesh_id) result(dA_msl_proj) + function get_dA_msl_proj(config, mesh_id) result(dA_msl_proj) - use base_mesh_config_mod, only: geometry, geometry_spherical - use extrusion_config_mod, only: planet_radius, domain_height use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type implicit none - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: mesh_id + integer(kind=i_def) :: local_mesh_id type(mesh_type), pointer :: mesh type(mesh_type), pointer :: prime_mesh @@ -918,6 +936,14 @@ contains type(function_space_type), pointer :: fs integer(tik) :: id + integer(i_def) :: geometry + real(r_def) :: planet_radius + real(r_def) :: domain_height + + geometry = config%base_mesh%geometry() + planet_radius = config%extrusion%planet_radius() + domain_height = config%extrusion%domain_height() + ! Initialise inventory if it hasn't been done so already if (.not. dA_msl_proj_inventory%is_initialised()) then call dA_msl_proj_inventory%initialise(name="dA_msl_proj") @@ -975,9 +1001,14 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - long_ptr => get_longitude_fv(space_id, mesh_id) + if (order_h == 0 .and. order_v == 0) then + long_ptr => get_longitude_fv(config, space_id, mesh_id) return end if @@ -1103,9 +1134,14 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - lat_ptr => get_latitude_fv(space_id, mesh_id) + if (order_h == 0 .and. order_v == 0) then + lat_ptr => get_latitude_fv(config, space_id, mesh_id) return end if @@ -1214,17 +1250,16 @@ contains !> @param[in] space The space of the desired height field !> @param[in] mesh_id The ID of the mesh to get the object for !> @return A height field - function get_height_fe(space_id, mesh_id) result(height) + function get_height_fe(config, space_id, mesh_id) result(height) use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type use sci_height_discontinuous_kernel_mod, & only: height_discontinuous_kernel_type - use base_mesh_config_mod, only: geometry - use finite_element_config_mod, only: coord_system - use planet_config_mod, only: scaled_radius implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1239,9 +1274,19 @@ contains character(len=str_def) :: inventory_name integer(tik) :: id + real(r_def) :: scaled_radius + integer(i_def) :: geometry, coord_system + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + coord_system = config%finite_element%coord_system() + geometry = config%base_mesh%geometry() + scaled_radius = config%planet%scaled_radius() + ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - height => get_height_fv(space_id, mesh_id) + if (order_h == 0 .and. order_v == 0) then + height => get_height_fv(config, space_id, mesh_id) return end if @@ -1284,9 +1329,8 @@ contains if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - space => function_space_collection%get_fs( & - mesh, element_order_h, element_order_v, space_id & - ) + space => function_space_collection%get_fs(mesh, order_h, order_v, & + space_id) call inventory%add_field(height, space, mesh) select case (space_id) @@ -1329,17 +1373,16 @@ contains !> @param[in] space The space of the desired height field !> @param[in] mesh_id The ID of the mesh to get the object for !> @return A height field - function get_height_fv(space_id, mesh_id) result(height) + function get_height_fv(config, space_id, mesh_id) result(height) use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type use sci_height_discontinuous_kernel_mod, & only: height_discontinuous_kernel_type - use base_mesh_config_mod, only: geometry - use finite_element_config_mod, only: coord_system - use planet_config_mod, only: scaled_radius implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1354,6 +1397,13 @@ contains character(len=str_def) :: inventory_name integer(tik) :: id + real(r_def) :: scaled_radius + integer(i_def) :: geometry, coord_system + + coord_system = config%finite_element%coord_system() + geometry = config%base_mesh%geometry() + scaled_radius = config%planet%scaled_radius() + ! Determine inventory based on space select case (space_id) case (W0) From 05e0850da3ae73f004a76470b6abf55db4336b75 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 25 Mar 2026 12:30:09 +0000 Subject: [PATCH 07/44] Add a newer version of gemoetric constants --- .../new_sci_geometric_constants_mod.x90 | 1647 +++++++++++++++++ 1 file changed, 1647 insertions(+) create mode 100644 components/science/source/algorithm/new_sci_geometric_constants_mod.x90 diff --git a/components/science/source/algorithm/new_sci_geometric_constants_mod.x90 b/components/science/source/algorithm/new_sci_geometric_constants_mod.x90 new file mode 100644 index 000000000..1f3cf7539 --- /dev/null +++ b/components/science/source/algorithm/new_sci_geometric_constants_mod.x90 @@ -0,0 +1,1647 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright 2021 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 Pre-computes and stores various geometric objects. +!> +!> @details This module controls the set up of various objects relating to +!> the geometry of the mesh that do not change during a run. These +!> objects are accessed from this module through appropriate 'get' +!> functions. +!------------------------------------------------------------------------------- + +module new_sci_geometric_constants_mod + + ! Infrastructure + use config_mod, only: config_type + use constants_mod, only: i_def, r_def, l_def, str_def + use extrusion_mod, only: TWOD, PRIME_EXTRUSION + use field_mod, only: field_type + use fs_continuity_mod, only: W0, W1, W2, W2H, W3, Wtheta + use function_space_collection_mod, only: function_space_collection + use function_space_mod, only: function_space_type + use integer_field_mod, only: integer_field_type + use inventory_by_mesh_mod, only: inventory_by_mesh_type + use inventory_by_local_mesh_mod, only: inventory_by_local_mesh_type + use local_mesh_mod, only: local_mesh_type + use log_mod, only: log_event, LOG_LEVEL_ERROR + use mesh_collection_mod, only: mesh_collection + use mesh_mod, only: mesh_type + use timing_mod, only: start_timing, stop_timing, & + tik, LPROF + + ! Configuration + use base_mesh_config_mod, only: geometry_spherical + use finite_element_config_mod, only: coord_system_native + + implicit none + + private + + ! Variables private to this module that can only be accessed by public + ! functions returning pointers to them + + ! ========================================================================== ! + ! Inventories for use in the rest of the model + ! ========================================================================== ! + ! Finite element representations of coordinates + type(inventory_by_mesh_type), target :: chi_inventory + type(inventory_by_mesh_type), target :: panel_id_inventory + type(inventory_by_mesh_type) :: extended_chi_inventory + + ! Basic geometric entities + type(inventory_by_mesh_type) :: dA_at_w2_inventory + type(inventory_by_mesh_type) :: dz_w3_inventory + type(inventory_by_mesh_type) :: detj_at_w3_inventory_fe + type(inventory_by_mesh_type) :: detj_at_w3_inventory_fv + type(inventory_by_mesh_type) :: detj_at_w2_inventory_fe + type(inventory_by_mesh_type) :: detj_at_w2_inventory_fv + type(inventory_by_mesh_type) :: delta_at_wtheta_inventory + type(inventory_by_mesh_type) :: dx_at_w2_inventory + type(inventory_by_mesh_type) :: dz_at_wtheta_inventory + type(inventory_by_local_mesh_type) :: dA_msl_proj_inventory + + ! 2D Longitude/latitude fields + type(inventory_by_local_mesh_type), target :: lat_w3_inventory_fe + type(inventory_by_local_mesh_type), target :: lat_w3_inventory_fv + type(inventory_by_local_mesh_type), target :: lat_w2_inventory_fe + type(inventory_by_local_mesh_type), target :: lat_w2_inventory_fv + type(inventory_by_local_mesh_type), target :: lat_w2h_inventory_fe + type(inventory_by_local_mesh_type), target :: lat_w2h_inventory_fv + type(inventory_by_local_mesh_type), target :: long_w3_inventory_fe + type(inventory_by_local_mesh_type), target :: long_w3_inventory_fv + type(inventory_by_local_mesh_type), target :: long_w2_inventory_fe + type(inventory_by_local_mesh_type), target :: long_w2_inventory_fv + type(inventory_by_local_mesh_type), target :: long_w2h_inventory_fe + type(inventory_by_local_mesh_type), target :: long_w2h_inventory_fv + + ! Heights of DoFs + type(inventory_by_mesh_type), target :: height_w0_inventory_fe + type(inventory_by_mesh_type), target :: height_w0_inventory_fv + type(inventory_by_mesh_type), target :: height_w1_inventory_fe + type(inventory_by_mesh_type), target :: height_w1_inventory_fv + type(inventory_by_mesh_type), target :: height_w2_inventory_fe + type(inventory_by_mesh_type), target :: height_w2_inventory_fv + type(inventory_by_mesh_type), target :: height_w2h_inventory_fe + type(inventory_by_mesh_type), target :: height_w2h_inventory_fv + type(inventory_by_mesh_type), target :: height_w3_inventory_fe + type(inventory_by_mesh_type), target :: height_w3_inventory_fv + type(inventory_by_mesh_type), target :: height_wth_inventory_fe + type(inventory_by_mesh_type), target :: height_wth_inventory_fv + + ! Face selectors, used to avoid doubly-iterating over horizontal faces + type(inventory_by_local_mesh_type) :: face_selector_ew_inventory + type(inventory_by_local_mesh_type) :: face_selector_ns_inventory + + ! ========================================================================== ! + ! Public functions for accessing the module contents + ! ========================================================================== ! + + public :: final_geometric_constants + public :: get_panel_id + public :: get_coordinates + public :: get_dA_at_w2 + public :: get_detj_at_w3_fv + public :: get_detj_at_w2_fv + public :: get_delta_at_wtheta + public :: get_dx_at_w2 + public :: get_face_selector_ew + public :: get_face_selector_ns + public :: get_chi_inventory + public :: get_panel_id_inventory + + public :: get_extended_coordinates + public :: get_detj_at_w3_fe + public :: get_detj_at_w2_fe + public :: get_dz_w3 + public :: get_dz_at_wtheta + public :: get_dA_msl_proj + public :: get_height_fe + public :: get_height_fv + public :: get_latitude_fe + public :: get_latitude_fv + public :: get_longitude_fe + public :: get_longitude_fv + + ! Private routines for creating constants + private :: compute_latlon + private :: compute_face_selectors + +contains + + ! ========================================================================== ! + ! Private routines for creating some particular constants + ! ========================================================================== ! + + !> @brief Private routine for computing longitude and latitude fields + !> @param[in] config Configuration object + !> @param[in,out] long_inventory Inventory containing longitude fields + !> @param[in,out] lat_inventory Inventory containing latitude fields + !> @param[in] mesh Mesh used to determine local mesh for + !! computing the fields for + !> @param[in] fs_id Identifier for function space to compute + !! longitude and latitude fields for + !> @param[in] use_fe Flag to indicate whether to use finite + !! element or finite volume cells + subroutine compute_latlon(config, long_inventory, lat_inventory, & + mesh, fs_id, use_fe) + + use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type + + implicit none + + type(config_type), intent(in) :: config + + type(inventory_by_local_mesh_type), intent(inout) :: long_inventory + type(inventory_by_local_mesh_type), intent(inout) :: lat_inventory + type(mesh_type), intent(in) :: mesh + integer(kind=i_def), intent(in) :: fs_id + logical(kind=l_def), intent(in) :: use_fe + + ! Internal variables + type(mesh_type), pointer :: twod_mesh + type(local_mesh_type), pointer :: local_mesh + type(field_type), pointer :: lat + type(field_type), pointer :: long + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(function_space_type), pointer :: twod_fs + integer(kind=i_def) :: k_h, k_v + integer(tik) :: id + + integer(i_def) :: geometry, topology + integer(i_def) :: order_h, order_v + integer(i_def) :: coord_system + real(r_def) :: f_lat, f_lon + real(r_def) :: scaled_radius + + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() + + f_lat = config%base_mesh%f_lat() + f_lon = config%idealised%f_lon() + + if (use_fe) then + k_h = order_h + k_v = order_v + else + k_h = 0 + k_v = 0 + end if + + twod_mesh => mesh_collection%get_mesh(mesh, TWOD) + local_mesh => mesh%get_local_mesh() + twod_fs => function_space_collection%get_fs(twod_mesh, k_h, k_v, fs_id) + call lat_inventory%add_field(lat, twod_fs, local_mesh) + call long_inventory%add_field(long, twod_fs, local_mesh) + + if ( geometry == geometry_spherical ) then + chi => get_coordinates(mesh%get_id()) + panel_id => get_panel_id(mesh%get_id()) + call invoke( compute_latlon_kernel_type(lat, long, chi, panel_id, & + geometry, topology, & + coord_system, scaled_radius) ) + else + call invoke( setval_c(lat, f_lat), & + setval_c(long, f_lon) ) + end if + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + + end subroutine compute_latlon + + + !> @brief Private routine for computing face selectors fields + !> @param[in,out] ew_inventory Inventory containing East-West selectors + !> @param[in,out] ns_inventory Inventory containing North-South selectors + !> @param[in] mesh Mesh used to determine local mesh for + !! computing the fields for + subroutine compute_face_selectors(mesh) + + use reference_element_mod, only: S, W + use sci_set_any_int_dof_kernel_mod, only: set_any_int_dof_kernel_type + use sci_face_selector_kernel_mod, only: face_selector_kernel_type + + implicit none + + type(mesh_type), intent(in) :: mesh + + ! Internal variables + type(mesh_type), pointer :: twod_mesh + type(local_mesh_type), pointer :: local_mesh + type(integer_field_type), pointer :: face_selector_ew + type(integer_field_type), pointer :: face_selector_ns + type(integer_field_type) :: face_counter + type(function_space_type), pointer :: w2h_2d_fs + type(function_space_type), pointer :: w3_2d_fs + integer(tik) :: id + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + twod_mesh => mesh_collection%get_mesh(mesh, TWOD) + local_mesh => mesh%get_local_mesh() + w2h_2d_fs => function_space_collection%get_fs(twod_mesh, 0, 0, W2H) + w3_2d_fs => function_space_collection%get_fs(twod_mesh, 0, 0, W3) + + ! Temporary W2H field, tracking the count for each face + call face_counter%initialise( w2h_2d_fs ) + + call face_selector_ew_inventory%add_field( & + face_selector_ew, w3_2d_fs, local_mesh & + ) + call face_selector_ns_inventory%add_field( & + face_selector_ns, w3_2d_fs, local_mesh & + ) + + call invoke( int_setval_c(face_counter, 0), & + ! Do West and South faces for every cell + int_setval_c(face_selector_ew, 1), & + int_setval_c(face_selector_ns, 1), & + set_any_int_dof_kernel_type(face_counter, W, 1), & + set_any_int_dof_kernel_type(face_counter, S, 1), & + ! Determine where North and East faces are needed + face_selector_kernel_type(face_selector_ew, & + face_selector_ns, & + face_counter ) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + + end subroutine compute_face_selectors + + ! ========================================================================== ! + ! GETTERS FOR FINITE ELEMENT COORDINATE FIELDS + ! ========================================================================== ! + !> @brief Function to return a pointer to the panel_id + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The coordinate field array + function get_panel_id(mesh_id) result(panel_id_ptr) + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(mesh_type), pointer :: prime_extrusion_mesh + type(field_type), pointer :: panel_id_ptr + + mesh => mesh_collection%get_mesh(mesh_id) + if (mesh%get_extrusion_id() == TWOD) then + prime_extrusion_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) + call panel_id_inventory%get_field(prime_extrusion_mesh, panel_id_ptr) + else + call panel_id_inventory%get_field(mesh, panel_id_ptr) + end if + + end function get_panel_id + + !> @brief Returns a pointer to the coordinate field array + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The coordinate field array + function get_coordinates(mesh_id) result(coords_ptr) + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(mesh_type), pointer :: prime_extrusion_mesh + type(field_type), pointer :: coords_ptr(:) + + mesh => mesh_collection%get_mesh(mesh_id) + if (mesh%get_extrusion_id() == TWOD) then + prime_extrusion_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) + call chi_inventory%get_field_array(prime_extrusion_mesh, coords_ptr) + else + call chi_inventory%get_field_array(mesh, coords_ptr) + end if + + end function get_coordinates + + + !> @brief Returns a pointer to the extended coordinate field array + !> @param[in] config Configuration object + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The coordinate field array + function get_extended_coordinates(config, mesh_id) result(extended_chi) + + use sci_extend_chi_field_kernel_mod, only: extend_chi_field_kernel_type + + implicit none + + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: mesh_id + + type(mesh_type), pointer :: mesh + type(field_type), pointer :: extended_chi(:) + logical(kind=l_def) :: constant_exists + integer(kind=i_def) :: depth + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(function_space_type), pointer :: wchi_fs + + integer(tik) :: id + integer(i_def) :: coord_system + + coord_system = config%finite_element%coord_system() + + ! Initialise inventory if this is the first time getting this constant + if (.not. extended_chi_inventory%is_initialised()) then + call extended_chi_inventory%initialise(name="extended_chi") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = extended_chi_inventory%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + ! If this constant doesn't exist, create it + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + wchi_fs => chi(1)%get_function_space() + depth = mesh%get_halo_depth() + call extended_chi_inventory%add_field_array( & + extended_chi, wchi_fs, 3, mesh, halo_depth=depth & + ) + + if (coord_system /= coord_system_native) then + call log_event( & + "Extended coordinates only implemented for native " // & + "coord_system option", LOG_LEVEL_ERROR & + ) + end if + + call invoke( extend_chi_field_kernel_type(extended_chi, chi, & + panel_id, depth) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + else + ! Otherwise, return existing constant + call extended_chi_inventory%get_field_array(mesh, extended_chi) + end if + + end function get_extended_coordinates + + + ! ========================================================================== ! + ! GETTERS FOR BASIC GEOMETRIC ENTITIES + ! ========================================================================== ! + !> @brief Returns the areas of cell faces at W2 DoF locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The dA field + function get_dA_at_w2(mesh_id) result(dA_at_w2) + + use sci_calc_da_at_w2_kernel_mod, only: calc_dA_at_w2_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(field_type), pointer :: dA_at_w2 + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(function_space_type), pointer :: w2_k0_fs + integer(tik) :: id + + ! Initialise inventory if this is the first time getting this constant + if (.not. dA_at_w2_inventory%is_initialised()) then + call dA_at_w2_inventory%initialise(name="dA_at_w2") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = dA_at_w2_inventory%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + ! If this constant doesn't exist, create it + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w2_k0_fs => function_space_collection%get_fs(mesh, 0, 0, W2) + call dA_at_w2_inventory%add_field(dA_at_w2, w2_k0_fs, mesh) + + call invoke( setval_c(dA_at_w2, 0.0_r_def), & + calc_dA_at_w2_kernel_type(dA_at_w2, chi, panel_id) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + else + ! Otherwise, return existing constant + call dA_at_w2_inventory%get_field(mesh, dA_at_w2) + end if + + end function get_dA_at_w2 + + + !> @brief Returns the (finite element) Det(J) values at W3 dof locations + !> @param[in] config Configuration object + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The Det(J) field + function get_detj_at_w3_fe(config, mesh_id) result(detj_at_w3) + + ! @TODO #4487: update these imports + ! use sci_calc_detj_at_w3_kernel_mod, only: calc_detj_at_w3_kernel_type + use sci_compute_mass_matrix_kernel_w_scalar_mod, & + only: compute_mass_matrix_kernel_w_scalar_type + use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type + use operator_mod, only: operator_type + use quadrature_xyoz_mod, only: quadrature_xyoz_type + use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type + + implicit none + + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: detj_at_w3 + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(function_space_type), pointer :: w3_fs + ! @TODO #4487: arguments for calculating detj in old way + type(operator_type) :: mm_w3 + type(quadrature_xyoz_type) :: qr + logical(kind=l_def) :: extended_mesh + type(quadrature_rule_gaussian_type) :: quadrature_rule + integer(tik) :: id + + integer(i_def) :: nqp_h_exact, nqp_v_exact + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + + nqp_h_exact = config%finite_element%nqp_h_exact() + nqp_v_exact = config%finite_element%nqp_v_exact() + + ! If running at lowest order, use finite volume + if (order_h == 0 .and. order_v == 0) then + detj_at_w3 => get_detj_at_w3_fv(mesh_id) + return + end if + + ! Check inventory is initialised + if (.not. detj_at_w3_inventory_fe%is_initialised()) then + ! Initialise all inventories together + call detj_at_w3_inventory_fe%initialise(name='detj_at_w3_fe') + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = detj_at_w3_inventory_fe%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + ! Create the object as it doesn't exist yet + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w3_fs => function_space_collection%get_fs(mesh, order_h, order_v, W3) + call detj_at_w3_inventory_fe%add_field(detj_at_w3, w3_fs, mesh) + + ! @TODO #4487: it is inefficient to calculate this via mass matrices + ! The proper method is preserved in the comment here + ! call invoke( calc_detj_at_w3_kernel_type(detj_at_w3, chi, panel_id) ) + call mm_w3%initialise( w3_fs, w3_fs ) + qr = quadrature_xyoz_type(nqp_h_exact, nqp_h_exact, nqp_v_exact, & + quadrature_rule) + extended_mesh = .false. + call invoke( compute_mass_matrix_kernel_w_scalar_type(mm_w3, & + chi, & + panel_id, & + extended_mesh, & + qr), & + setval_c(detj_at_w3, 0.0_r_def), & + mm_diagonal_kernel_type(detj_at_w3, mm_w3) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Get existing constant + call detj_at_w3_inventory_fe%get_field(mesh, detj_at_w3) + + end function get_detj_at_w3_fe + + + !> @brief Returns the (finite volume) Det(J) values at W3 dof locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The Det(J) field + function get_detj_at_w3_fv(mesh_id) result(detj_at_w3) + + ! @TODO #4487: update these imports + ! use sci_calc_detj_at_w3_kernel_mod, & + ! only: calc_detj_at_w3_kernel_type + use sci_compute_mass_matrix_kernel_w_scalar_mod, & + only: compute_mass_matrix_kernel_w_scalar_type + use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type + use operator_mod, only: operator_type + use quadrature_xyoz_mod, only: quadrature_xyoz_type + use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: detj_at_w3 + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(function_space_type), pointer :: w3_fs + ! @TODO #4487: arguments for calculating detj in old way + type(operator_type) :: mm_w3 + type(quadrature_xyoz_type) :: qr + logical(kind=l_def) :: extended_mesh + type(quadrature_rule_gaussian_type) :: quadrature_rule + integer(tik) :: id + + ! Check inventory is initialised + if (.not. detj_at_w3_inventory_fv%is_initialised()) then + ! Initialise all inventories together + call detj_at_w3_inventory_fv%initialise(name='detj_at_w3_fv') + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = detj_at_w3_inventory_fv%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + ! Create the object as it doesn't exist yet + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w3_fs => function_space_collection%get_fs(mesh, 0, 0, W3) + call detj_at_w3_inventory_fv%add_field(detj_at_w3, w3_fs, mesh) + + ! @TODO #4487: it is inefficient to calculate this via mass matrices + ! The proper method is preserved in the comment here + ! call invoke( calc_detj_at_w3_kernel_type(detj_at_w3, chi, panel_id) ) + call mm_w3%initialise( w3_fs, w3_fs ) + qr = quadrature_xyoz_type(3, quadrature_rule) + extended_mesh = .false. + call invoke( compute_mass_matrix_kernel_w_scalar_type(mm_w3, & + chi, & + panel_id, & + extended_mesh, & + qr), & + setval_c(detj_at_w3, 0.0_r_def), & + mm_diagonal_kernel_type(detj_at_w3, mm_w3) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Get existing constant + call detj_at_w3_inventory_fv%get_field(mesh, detj_at_w3) + + end function get_detj_at_w3_fv + + + !> @brief Returns the (finite element) Det(J) values at W2 dof locations + !> @param[in] config Configuration object + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The Det(J) field + function get_detj_at_w2_fe(config, mesh_id) result(detj_at_w2) + + use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type + use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type + + implicit none + + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: detj_at_w2 + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(field_type) :: multiplicity_w2 + type(function_space_type), pointer :: w2_fs + integer(tik) :: id + + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + + ! If running at lowest order, use finite volume + if (order_h == 0 .and. order_v == 0) then + detj_at_w2 => get_detj_at_w2_fv(mesh_id) + return + end if + + ! Check inventory is initialised + if (.not. detj_at_w2_inventory_fe%is_initialised()) then + ! Initialise all inventories together + call detj_at_w2_inventory_fe%initialise(name='detj_at_w2_fe') + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = detj_at_w2_inventory_fe%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + ! Create the object as it doesn't exist yet + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w2_fs => function_space_collection%get_fs(mesh, order_h, order_v, W2) + call multiplicity_w2%initialise( w2_fs ) + call detj_at_w2_inventory_fe%add_field(detj_at_w2, w2_fs, mesh) + + ! @TODO #4487: a small optimisation here is to multiply by rmultiplicity, + ! rather than computing and dividing by mulitplicity + call invoke( setval_c(detj_at_w2, 0.0_r_def), & + calc_detj_at_w2_kernel_type(detj_at_w2, chi, panel_id), & + setval_c(multiplicity_w2, 0.0_r_def), & + multiplicity_kernel_type(multiplicity_w2), & + inc_X_divideby_Y(detj_at_w2, multiplicity_w2) ) + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Get existing constant + call detj_at_w2_inventory_fe%get_field(mesh, detj_at_w2) + + end function get_detj_at_w2_fe + + + !> @brief Returns the (finite volume) Det(J) values at W2 dof locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The Det(J) field + function get_detj_at_w2_fv(mesh_id) result(detj_at_w2) + + use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type + use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: detj_at_w2 + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(field_type) :: multiplicity_w2 + type(function_space_type), pointer :: w2_fs + integer(tik) :: id + + ! Check inventory is initialised + if (.not. detj_at_w2_inventory_fv%is_initialised()) then + ! Initialise all inventories together + call detj_at_w2_inventory_fv%initialise(name='detj_at_w2_fv') + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = detj_at_w2_inventory_fv%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + ! Create the object as it doesn't exist yet + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w2_fs => function_space_collection%get_fs(mesh, 0, 0, W2) + call multiplicity_w2%initialise( w2_fs ) + call detj_at_w2_inventory_fv%add_field(detj_at_w2, w2_fs, mesh) + + ! @TODO #4487: a small optimisation here is to multiply by rmultiplicity, + ! rather than computing and dividing by mulitplicity + call invoke( setval_c(detj_at_w2, 0.0_r_def), & + calc_detj_at_w2_kernel_type(detj_at_w2, chi, panel_id), & + setval_c(multiplicity_w2, 0.0_r_def), & + multiplicity_kernel_type(multiplicity_w2), & + inc_X_divideby_Y(detj_at_w2, multiplicity_w2) ) + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Get existing constant + call detj_at_w2_inventory_fv%get_field(mesh, detj_at_w2) + + end function get_detj_at_w2_fv + + + !> @brief Returns a pointer to the vertical grid spacing, located at W3 DoFs + !> @param[in] config Configuration object + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The physical height difference of layers, at W3 + function get_dz_w3(config, mesh_id) result(dz_w3) + + use sci_get_dz_w3_kernel_mod, only: get_dz_w3_kernel_type + + implicit none + + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + + type(mesh_type), pointer :: mesh + type(field_type), pointer :: dz_w3 + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: height_w2 + type(function_space_type), pointer :: w3_fs + integer(tik) :: id + + ! Initialise inventory if this is the first time getting this constant + if (.not. dz_w3_inventory%is_initialised()) then + call dz_w3_inventory%initialise(name="dz_w3") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = dz_w3_inventory%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + ! If this constant doesn't exist, create it + ! Get height first to avoid potentially timing twice + height_w2 => get_height_fv(config, W2, mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w3_fs => function_space_collection%get_fs(mesh, 0, 0, W3) + call dz_w3_inventory%add_field(dz_w3, w3_fs, mesh) + + call invoke( get_dz_w3_kernel_type(dz_w3, height_w2) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + else + ! Otherwise, return existing constant + call dz_w3_inventory%get_field(mesh, dz_w3) + end if + + end function get_dz_w3 + + + !> @brief Returns the delta_at_wtheta values at Wtheta DoF locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The delta_at_wtheta field + function get_delta_at_wtheta(mesh_id) result(delta_at_wtheta) + + use sci_calc_delta_at_wtheta_kernel_mod, & + only: calc_delta_at_wtheta_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: dx_at_w2 + type(field_type), pointer :: delta_at_wtheta + type(function_space_type), pointer :: wt_k0_fs + integer(tik) :: id + + ! Initialise inventory if it hasn't been done so already + if (.not. delta_at_wtheta_inventory%is_initialised()) then + call delta_at_wtheta_inventory%initialise(name="delta_at_wtheta") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = delta_at_wtheta_inventory%paired_object_exists(mesh_id) + + ! Create constant if it doesn't already exist + if (.not. constant_exists) then + wt_k0_fs => function_space_collection%get_fs(mesh, 0, 0, Wtheta) + dx_at_w2 => get_dx_at_w2(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + call delta_at_wtheta_inventory%add_field(delta_at_wtheta, wt_k0_fs, mesh) + + call invoke( calc_delta_at_wtheta_kernel_type(delta_at_wtheta, dx_at_w2) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Return constant + call delta_at_wtheta_inventory%get_field(mesh, delta_at_wtheta) + + end function get_delta_at_wtheta + + !> @brief Returns the dx_at_w2 values at W2 DoF locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The dx_at_w2 field + function get_dx_at_w2(mesh_id) result(dx_at_w2) + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: dx_at_w2 + type(field_type), pointer :: detj_at_w2 + type(field_type), pointer :: dA_at_w2 + type(function_space_type), pointer :: w2_fs + integer(tik) :: id + + ! Initialise inventory if it hasn't been done so already + if (.not. dx_at_w2_inventory%is_initialised()) then + call dx_at_w2_inventory%initialise(name="dx_at_w2") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = dx_at_w2_inventory%paired_object_exists(mesh_id) + + ! Create constant if it doesn't already exist + if (.not. constant_exists) then + w2_fs => function_space_collection%get_fs(mesh, 0, 0, W2) + detj_at_w2 => get_detj_at_w2_fv(mesh_id) + dA_at_w2 => get_dA_at_w2(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + call dx_at_w2_inventory%add_field(dx_at_w2, w2_fs, mesh) + call invoke( X_divideby_Y(dx_at_w2, detj_at_w2, dA_at_w2) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Return constant + call dx_at_w2_inventory%get_field(mesh, dx_at_w2) + + end function get_dx_at_w2 + + + !> @brief Returns the 1/dz values at lowest-order Wtheta DoF locations + !> @param[in] config Configuration object + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The dz_at_wtheta field + function get_dz_at_wtheta(config, mesh_id) result(dz_at_wtheta) + + use sci_calc_dz_face_kernel_mod, only: calc_dz_face_kernel_type + + implicit none + + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + + type(mesh_type), pointer :: mesh + type(field_type), pointer :: dz_at_wtheta + type(function_space_type), pointer :: wtheta_k0_fs + type(field_type), pointer :: height_w3 + type(field_type), pointer :: height_wth + logical(kind=l_def) :: constant_exists + integer(tik) :: id + + ! Parameters of the cells + integer(i_def), parameter :: n_centres = 1_i_def + logical(l_def), parameter :: ign_surf = .false. + + ! Initialise inventory if it hasn't been done so already + if (.not. dz_at_wtheta_inventory%is_initialised()) then + call dz_at_wtheta_inventory%initialise(name="dz_at_wtheta") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = dz_at_wtheta_inventory%paired_object_exists(mesh_id) + + ! Create constant if it doesn't already exist + if (.not. constant_exists) then + ! NB: this assumes heights are in the lowest-order space + height_w3 => get_height_fv(config, W3, mesh_id) + height_wth => get_height_fv(config, Wtheta, mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + wtheta_k0_fs => function_space_collection%get_fs(mesh, 0, 0, Wtheta) + + call dz_at_wtheta_inventory%add_field(dz_at_wtheta, wtheta_k0_fs, mesh) + + call invoke( calc_dz_face_kernel_type(dz_at_wtheta, height_w3, & + height_wth, n_centres, ign_surf) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Return constant + call dz_at_wtheta_inventory%get_field(mesh, dz_at_wtheta) + + end function get_dz_at_wtheta + + + !> @brief Returns the surface area of a cell projected to mean sea level + !> i.e. ignoring the orographic effect on the area + !> @param[in] config Configuration object + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The dA_msl_proj field + function get_dA_msl_proj(config, mesh_id) result(dA_msl_proj) + + use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type + + implicit none + + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + + integer(kind=i_def) :: local_mesh_id + type(mesh_type), pointer :: mesh + type(mesh_type), pointer :: prime_mesh + type(mesh_type), pointer :: twod_mesh + type(local_mesh_type), pointer :: local_mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: dA_msl_proj + type(field_type), pointer :: dA_at_w2 + type(function_space_type), pointer :: fs + integer(tik) :: id + + integer(i_def) :: geometry + real(r_def) :: planet_radius + real(r_def) :: domain_height + + geometry = config%base_mesh%geometry() + planet_radius = config%extrusion%planet_radius() + domain_height = config%extrusion%domain_height() + + ! Initialise inventory if it hasn't been done so already + if (.not. dA_msl_proj_inventory%is_initialised()) then + call dA_msl_proj_inventory%initialise(name="dA_msl_proj") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + local_mesh_id = local_mesh%get_id() + constant_exists = dA_msl_proj_inventory%paired_object_exists(local_mesh_id) + + ! Create constant if it doesn't already exist + if (.not. constant_exists) then + prime_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) + twod_mesh => mesh_collection%get_mesh(mesh, TWOD) + fs => function_space_collection%get_fs(twod_mesh, 0, 0, W3) + dA_at_w2 => get_dA_at_w2(prime_mesh%get_id()) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + call dA_msl_proj_inventory%add_field(dA_msl_proj, fs, local_mesh) + call invoke( calc_da_msl_proj_kernel_type(dA_at_w2, dA_msl_proj, & + planet_radius, domain_height, & + geometry, geometry_spherical) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Return constant + call dA_msl_proj_inventory%get_field(local_mesh, dA_msl_proj) + + end function get_dA_msl_proj + + + ! ========================================================================== ! + ! PHYSICAL COORDINATES OF DOFs + ! ========================================================================== ! + !> @brief Returns a pointer to the longitude of finite element DoFs + !> @param[in] config Configuration object + !> @param[in] space_id The space for which to get the longitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The longitude field + function get_longitude_fe(config, space_id, mesh_id) result(long_ptr) + + implicit none + + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + type(mesh_type), pointer :: mesh + type(local_mesh_type), pointer :: local_mesh + type(inventory_by_local_mesh_type), pointer :: long_inventory + type(inventory_by_local_mesh_type), pointer :: lat_inventory + type(field_type), pointer :: long_ptr + logical(kind=l_def) :: constant_exists + character(len=str_def) :: inventory_name + + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + + ! If running at lowest order, use finite volume + if (order_h == 0 .and. order_v == 0) then + long_ptr => get_longitude_fv(config, space_id, mesh_id) + return + end if + + ! NB: Longitude and latitude fields are computed simultaneously + ! Determine inventory based on space + select case (space_id) + case (W2) + long_inventory => long_w2_inventory_fe + lat_inventory => lat_w2_inventory_fe + inventory_name = "_w2_fe" + case (W2H) + long_inventory => long_w2h_inventory_fe + lat_inventory => lat_w2h_inventory_fe + inventory_name = "_w2h_fe" + case (W3) + long_inventory => long_w3_inventory_fe + lat_inventory => lat_w3_inventory_fe + inventory_name = "_w3_fe" + case default + long_ptr => null() + call log_event("Longitude not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. long_inventory%is_initialised()) then + call long_inventory%initialise(name='longitude_'//trim(inventory_name)) + call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) + end if + + ! Create constant + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) then + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.true.) + end if + + call long_inventory%get_field(local_mesh, long_ptr) + + end function get_longitude_fe + + !> @brief Returns a pointer to the longitude of finite volume DoFs + !> @param[in] config Configuration object + !> @param[in] space_id The space for which to get the longitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The longitude field + function get_longitude_fv(config, space_id, mesh_id) result(long_ptr) + + implicit none + + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + type(mesh_type), pointer :: mesh + type(local_mesh_type), pointer :: local_mesh + type(inventory_by_local_mesh_type), pointer :: long_inventory + type(inventory_by_local_mesh_type), pointer :: lat_inventory + type(field_type), pointer :: long_ptr + logical(kind=l_def) :: constant_exists + character(len=str_def) :: inventory_name + + ! NB: Longitude and latitude fields are computed simultaneously + ! Determine inventory based on space + select case (space_id) + case (W2) + long_inventory => long_w2_inventory_fv + lat_inventory => lat_w2_inventory_fv + inventory_name = "_w2_fv" + case (W2H) + long_inventory => long_w2h_inventory_fv + lat_inventory => lat_w2h_inventory_fv + inventory_name = "_w2h_fv" + case (W3) + long_inventory => long_w3_inventory_fv + lat_inventory => lat_w3_inventory_fv + inventory_name = "_w3_fv" + case default + long_ptr => null() + call log_event("Longitude not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. long_inventory%is_initialised()) then + call long_inventory%initialise(name='longitude_'//trim(inventory_name)) + call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) + end if + + ! Create constant + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) then + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.false.) + end if + + call long_inventory%get_field(local_mesh, long_ptr) + + end function get_longitude_fv + + + !> @brief Returns a pointer to the latitude of finite element DoFs + !> @param[in] config Configuration object + !> @param[in] space_id The space for which to get the latitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The latitude field + function get_latitude_fe(config, space_id, mesh_id) result(lat_ptr) + + implicit none + + type(config_type), intent(in) :: config + + integer(kind=i_def), intent(in) :: space_id + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(local_mesh_type), pointer :: local_mesh + type(inventory_by_local_mesh_type), pointer :: long_inventory + type(inventory_by_local_mesh_type), pointer :: lat_inventory + type(field_type), pointer :: lat_ptr + logical(kind=l_def) :: constant_exists + character(len=str_def) :: inventory_name + + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + + ! If running at lowest order, use finite volume + if (order_h == 0 .and. order_v == 0) then + lat_ptr => get_latitude_fv(config, space_id, mesh_id) + return + end if + + ! NB: Longitude and latitude fields are computed simultaneously + ! Determine inventory based on space + select case (space_id) + case (W2) + long_inventory => long_w2_inventory_fe + lat_inventory => lat_w2_inventory_fe + inventory_name = "_w2_fe" + case (W2H) + long_inventory => long_w2h_inventory_fe + lat_inventory => lat_w2h_inventory_fe + inventory_name = "_w2h_fe" + case (W3) + long_inventory => long_w3_inventory_fe + lat_inventory => lat_w3_inventory_fe + inventory_name = "_w3_fe" + case default + lat_ptr => null() + call log_event("Latitude not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. lat_inventory%is_initialised()) then + call long_inventory%initialise(name='longitude_'//trim(inventory_name)) + call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) + end if + + ! Create constant + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) then + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.true.) + end if + + call lat_inventory%get_field(local_mesh, lat_ptr) + + end function get_latitude_fe + + + + !> @brief Returns a pointer to the latitude of finite volume DoFs + !> @param[in] config Configuration object + !> @param[in] space_id The space for which to get the latitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The latitude field + function get_latitude_fv(config, space_id, mesh_id) result(lat_ptr) + + implicit none + + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + type(mesh_type), pointer :: mesh + type(local_mesh_type), pointer :: local_mesh + type(inventory_by_local_mesh_type), pointer :: long_inventory + type(inventory_by_local_mesh_type), pointer :: lat_inventory + type(field_type), pointer :: lat_ptr + logical(kind=l_def) :: constant_exists + character(len=str_def) :: inventory_name + + ! NB: Longitude and latitude fields are computed simultaneously + ! Determine inventory based on space + select case (space_id) + case (W2) + long_inventory => long_w2_inventory_fv + lat_inventory => lat_w2_inventory_fv + inventory_name = "_w2_fv" + case (W2H) + long_inventory => long_w2h_inventory_fv + lat_inventory => lat_w2h_inventory_fv + inventory_name = "_w2h_fv" + case (W3) + long_inventory => long_w3_inventory_fv + lat_inventory => lat_w3_inventory_fv + inventory_name = "_w3_fv" + case default + lat_ptr => null() + call log_event("Latitude not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. lat_inventory%is_initialised()) then + call long_inventory%initialise(name='longitude_'//trim(inventory_name)) + call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) + end if + + ! Create constant + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) then + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.false.) + end if + + call lat_inventory%get_field(local_mesh, lat_ptr) + + end function get_latitude_fv + + + !> @brief Returns a pointer to a finite element height field + !> @param[in] config Configuration object + !> @param[in] space_id The space of the desired height field + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return A height field + function get_height_fe(config, space_id, mesh_id) result(height) + + + use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type + use sci_height_discontinuous_kernel_mod, & + only: height_discontinuous_kernel_type + + implicit none + + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + type(mesh_type), pointer :: mesh + type(inventory_by_mesh_type), pointer :: inventory + logical(kind=l_def) :: constant_exists + type(function_space_type), pointer :: space + type(field_type), pointer :: chi(:) + type(field_type), pointer :: height + type(field_type) :: rmultiplicity + type(field_type) :: nodal_multiplicity + type(field_type) :: ones + character(len=str_def) :: inventory_name + integer(tik) :: id + + real(r_def) :: scaled_radius + integer(i_def) :: geometry, coord_system + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + coord_system = config%finite_element%coord_system() + geometry = config%base_mesh%geometry() + scaled_radius = config%planet%scaled_radius() + + ! If running at lowest order, use finite volume + if (order_h == 0 .and. order_v == 0) then + height => get_height_fv(config, space_id, mesh_id) + return + end if + + ! Determine inventory based on space + select case (space_id) + case (W0) + inventory => height_w0_inventory_fe + inventory_name = "height_w0_fe" + case (W1) + inventory => height_w1_inventory_fe + inventory_name = "height_w1_fe" + case (W2) + inventory => height_w2_inventory_fe + inventory_name = "height_w2_fe" + case (W2H) + inventory => height_w2h_inventory_fe + inventory_name = "height_w2h_fe" + case (W3) + inventory => height_w3_inventory_fe + inventory_name = "height_w3_fe" + case (Wtheta) + inventory => height_wth_inventory_fe + inventory_name = "height_wtheta_fe" + case default + height => null() + call log_event("Height not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. inventory%is_initialised()) then + call inventory%initialise(name=inventory_name) + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = inventory%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + ! If this constant doesn't exist, create it + chi => get_coordinates(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + space => function_space_collection%get_fs(mesh, & + order_h, & + order_v, & + space_id) + call inventory%add_field(height, space, mesh) + + select case (space_id) + ! Horizontally discontinuous spaces + case (W3, Wtheta) + call invoke( & + height_discontinuous_kernel_type( & + height, chi, geometry, coord_system, scaled_radius & + ) & + ) + + ! Horizontally continuous spaces + case default + ! Can't import multiplicity, so must calculate it + call ones%initialise( space ) + call nodal_multiplicity%initialise( space ) + call rmultiplicity%initialise( space ) + + call invoke( & + setval_c(ones, 1.0_r_def), & + setval_c(nodal_multiplicity, 0.0_r_def), & + multiplicity_kernel_type(nodal_multiplicity), & + X_divideby_Y(rmultiplicity, ones, nodal_multiplicity), & + setval_c(height, 0.0_r_def), & + height_continuous_kernel_type( & + height, chi, rmultiplicity, & + geometry, coord_system, scaled_radius & + ) & + ) + end select + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + else + call inventory%get_field(mesh, height) + end if + + end function get_height_fe + + + !> @brief Returns a pointer to a finite volume height field + !> @param[in] config Configuration object + !> @param[in] space_id The space of the desired height field + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return A height field + function get_height_fv(config, space_id, mesh_id) result(height) + + use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type + use sci_height_discontinuous_kernel_mod, & + only: height_discontinuous_kernel_type + + implicit none + + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + type(mesh_type), pointer :: mesh + type(inventory_by_mesh_type), pointer :: inventory + logical(kind=l_def) :: constant_exists + type(function_space_type), pointer :: space + type(field_type), pointer :: chi(:) + type(field_type), pointer :: height + type(field_type) :: rmultiplicity + type(field_type) :: nodal_multiplicity + type(field_type) :: ones + character(len=str_def) :: inventory_name + integer(tik) :: id + + real(r_def) :: scaled_radius + integer(i_def) :: geometry, coord_system + + coord_system = config%finite_element%coord_system() + geometry = config%base_mesh%geometry() + scaled_radius = config%planet%scaled_radius() + + ! Determine inventory based on space + select case (space_id) + case (W0) + inventory => height_w0_inventory_fv + inventory_name = "height_w0_fv" + case (W1) + inventory => height_w1_inventory_fv + inventory_name = "height_w1_fv" + case (W2) + inventory => height_w2_inventory_fv + inventory_name = "height_w2_fv" + case (W2H) + inventory => height_w2h_inventory_fv + inventory_name = "height_w2h_fv" + case (W3) + inventory => height_w3_inventory_fv + inventory_name = "height_w3_fv" + case (Wtheta) + inventory => height_wth_inventory_fv + inventory_name = "height_wtheta_fv" + case default + height => null() + call log_event("Height not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. inventory%is_initialised()) then + call inventory%initialise(name=inventory_name) + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = inventory%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + ! If this constant doesn't exist, create it + chi => get_coordinates(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + space => function_space_collection%get_fs(mesh, 0, 0, space_id) + call inventory%add_field(height, space, mesh) + + select case (space_id) + ! Horizontally discontinuous spaces + case (W3, Wtheta) + call invoke( & + height_discontinuous_kernel_type( & + height, chi, geometry, coord_system, scaled_radius & + ) & + ) + + ! Horizontally continuous spaces + case default + ! Can't import multiplicity, so must calculate it + call ones%initialise( space ) + call nodal_multiplicity%initialise( space ) + call rmultiplicity%initialise( space ) + + call invoke( & + setval_c(ones, 1.0_r_def), & + setval_c(nodal_multiplicity, 0.0_r_def), & + multiplicity_kernel_type(nodal_multiplicity), & + X_divideby_Y(rmultiplicity, ones, nodal_multiplicity), & + setval_c(height, 0.0_r_def), & + height_continuous_kernel_type( & + height, chi, rmultiplicity, & + geometry, coord_system, scaled_radius & + ) & + ) + end select + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + else + call inventory%get_field(mesh, height) + end if + + end function get_height_fv + + + ! ========================================================================== ! + ! FACE SELECTORS + ! ========================================================================== ! + + !> @brief Returns a pointer to the east-west face selector + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The east-west face selector + function get_face_selector_ew(mesh_id) result(selector) + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh => null() + type(local_mesh_type), pointer :: local_mesh => null() + type(integer_field_type), pointer :: selector + logical(kind=l_def) :: constant_exists + + ! Initialise inventory if this is the first time getting this constant + if (.not. face_selector_ew_inventory%is_initialised()) then + call face_selector_ew_inventory%initialise(name="face_selector_ew") + call face_selector_ns_inventory%initialise(name="face_selector_ns") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = & + face_selector_ew_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) call compute_face_selectors(mesh) + + call face_selector_ew_inventory%get_field(local_mesh, selector) + + end function get_face_selector_ew + + !> @brief Returns a pointer to the north-south face selector + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The north-south face selector + function get_face_selector_ns(mesh_id) result(selector) + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh => null() + type(local_mesh_type), pointer :: local_mesh => null() + type(integer_field_type), pointer :: selector + logical(kind=l_def) :: constant_exists + + ! Initialise inventory if this is the first time getting this constant + if (.not. face_selector_ew_inventory%is_initialised()) then + call face_selector_ew_inventory%initialise(name="face_selector_ew") + call face_selector_ns_inventory%initialise(name="face_selector_ns") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = & + face_selector_ns_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) call compute_face_selectors(mesh) + + call face_selector_ns_inventory%get_field(local_mesh, selector) + + end function get_face_selector_ns + + ! ========================================================================== ! + ! GETTERS FOR INVENTORIES + ! ========================================================================== ! + ! These are two special inventories, which are set up in the driver + + !> @brief Returns a pointer to the chi inventory + function get_chi_inventory() result(inventory_ptr) + implicit none + type(inventory_by_mesh_type), pointer :: inventory_ptr + + inventory_ptr => chi_inventory + + end function get_chi_inventory + + !> @brief Returns a pointer to the panel_id inventory + function get_panel_id_inventory() result(inventory_ptr) + implicit none + type(inventory_by_mesh_type), pointer :: inventory_ptr + + inventory_ptr => panel_id_inventory + + end function get_panel_id_inventory + + ! ========================================================================== ! + ! FINALISE + ! ========================================================================== ! + !> @brief Explicitly reclaim memory from module scope variables + subroutine final_geometric_constants() + + implicit none + + call lat_w2_inventory_fe%clear() + call lat_w2_inventory_fv%clear() + call lat_w3_inventory_fe%clear() + call lat_w3_inventory_fv%clear() + call lat_w2h_inventory_fe%clear() + call lat_w2h_inventory_fv%clear() + call long_w2_inventory_fe%clear() + call long_w2_inventory_fv%clear() + call long_w3_inventory_fe%clear() + call long_w3_inventory_fv%clear() + call long_w2h_inventory_fe%clear() + call long_w2h_inventory_fv%clear() + call dA_at_w2_inventory%clear() + call height_wth_inventory_fe%clear() + call height_wth_inventory_fv%clear() + call height_w3_inventory_fe%clear() + call height_w3_inventory_fv%clear() + call height_w2_inventory_fe%clear() + call height_w2_inventory_fv%clear() + call height_w2h_inventory_fe%clear() + call height_w2h_inventory_fv%clear() + call height_w1_inventory_fe%clear() + call height_w1_inventory_fv%clear() + call height_w0_inventory_fe%clear() + call height_w0_inventory_fv%clear() + call dz_w3_inventory%clear() + call panel_id_inventory%clear() + call chi_inventory%clear() + call extended_chi_inventory%clear() + call detj_at_w3_inventory_fe%clear() + call detj_at_w3_inventory_fv%clear() + call detj_at_w2_inventory_fe%clear() + call detj_at_w2_inventory_fv%clear() + call delta_at_wtheta_inventory%clear() + call dx_at_w2_inventory%clear() + call dz_at_wtheta_inventory%clear() + call dA_msl_proj_inventory%clear() + + end subroutine final_geometric_constants + +end module new_sci_geometric_constants_mod From df1eecce8a3ee13dc5b1c6c151ae501bb411d528 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 25 Mar 2026 12:32:38 +0000 Subject: [PATCH 08/44] Reverting file back to original on main --- .../algorithm/sci_geometric_constants_mod.x90 | 219 ++++++------------ 1 file changed, 65 insertions(+), 154 deletions(-) diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90 b/components/science/source/algorithm/sci_geometric_constants_mod.x90 index dea422af4..e33f44e9a 100644 --- a/components/science/source/algorithm/sci_geometric_constants_mod.x90 +++ b/components/science/source/algorithm/sci_geometric_constants_mod.x90 @@ -15,7 +15,6 @@ module sci_geometric_constants_mod ! Infrastructure - use config_mod, only: config_type use constants_mod, only: i_def, r_def, l_def, str_def use extrusion_mod, only: TWOD, PRIME_EXTRUSION use field_mod, only: field_type @@ -33,8 +32,8 @@ module sci_geometric_constants_mod tik, LPROF ! Configuration - use base_mesh_config_mod, only: geometry_spherical - use finite_element_config_mod, only: coord_system_native + use finite_element_config_mod, only: element_order_h, & + element_order_v implicit none @@ -135,7 +134,6 @@ contains ! ========================================================================== ! !> @brief Private routine for computing longitude and latitude fields - !> @param[in] config Configuration object !> @param[in,out] long_inventory Inventory containing longitude fields !> @param[in,out] lat_inventory Inventory containing latitude fields !> @param[in] mesh Mesh used to determine local mesh for @@ -144,15 +142,15 @@ contains !! longitude and latitude fields for !> @param[in] use_fe Flag to indicate whether to use finite !! element or finite volume cells - subroutine compute_latlon(config, long_inventory, lat_inventory, & - mesh, fs_id, use_fe) + subroutine compute_latlon(long_inventory, lat_inventory, mesh, fs_id, use_fe) - use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type + use base_mesh_config_mod, only: f_lat, geometry, & + geometry_spherical + use idealised_config_mod, only: f_lon + use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type implicit none - type(config_type), intent(in) :: config - type(inventory_by_local_mesh_type), intent(inout) :: long_inventory type(inventory_by_local_mesh_type), intent(inout) :: lat_inventory type(mesh_type), intent(in) :: mesh @@ -170,28 +168,11 @@ contains integer(kind=i_def) :: k_h, k_v integer(tik) :: id - integer(i_def) :: geometry, topology - integer(i_def) :: order_h, order_v - integer(i_def) :: coord_system - real(r_def) :: f_lat, f_lon - real(r_def) :: scaled_radius - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() - - f_lat = config%base_mesh%f_lat() - f_lon = config%idealised%f_lon() - if (use_fe) then - k_h = order_h - k_v = order_v + k_h = element_order_h + k_v = element_order_v else k_h = 0 k_v = 0 @@ -206,11 +187,9 @@ contains if ( geometry == geometry_spherical ) then chi => get_coordinates(mesh%get_id()) panel_id => get_panel_id(mesh%get_id()) - call invoke( compute_latlon_kernel_type(lat, long, chi, panel_id, & - geometry, topology, & - coord_system, scaled_radius) ) + call invoke( compute_latlon_kernel_type(lat, long, chi, panel_id) ) else - call invoke( setval_c(lat, f_lat), & + call invoke( setval_c(lat, f_lat), & setval_c(long, f_lon) ) end if @@ -323,18 +302,16 @@ contains end function get_coordinates !> @brief Returns a pointer to the extended coordinate field array - !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The coordinate field array - function get_extended_coordinates(config, mesh_id) result(extended_chi) + function get_extended_coordinates(mesh_id) result(extended_chi) + use finite_element_config_mod, only: coord_system, coord_system_native use sci_extend_chi_field_kernel_mod, only: extend_chi_field_kernel_type implicit none - type(config_type), intent(in) :: config integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh type(field_type), pointer :: extended_chi(:) logical(kind=l_def) :: constant_exists @@ -342,11 +319,7 @@ contains type(field_type), pointer :: chi(:) type(field_type), pointer :: panel_id type(function_space_type), pointer :: wchi_fs - - integer(tik) :: id - integer(i_def) :: coord_system - - coord_system = config%finite_element%coord_system() + integer(tik) :: id ! Initialise inventory if this is the first time getting this constant if (.not. extended_chi_inventory%is_initialised()) then @@ -440,22 +413,22 @@ contains !> @brief Returns the (finite element) Det(J) values at W3 dof locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field - function get_detj_at_w3_fe(config, mesh_id) result(detj_at_w3) + function get_detj_at_w3_fe(mesh_id) result(detj_at_w3) ! @TODO #4487: update these imports ! use sci_calc_detj_at_w3_kernel_mod, only: calc_detj_at_w3_kernel_type use sci_compute_mass_matrix_kernel_w_scalar_mod, & only: compute_mass_matrix_kernel_w_scalar_type use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type + use finite_element_config_mod, only: nqp_h_exact, & + nqp_v_exact use operator_mod, only: operator_type use quadrature_xyoz_mod, only: quadrature_xyoz_type use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type implicit none - type(config_type), intent(in) :: config integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh logical(kind=l_def) :: constant_exists type(field_type), pointer :: detj_at_w3 @@ -469,17 +442,8 @@ contains type(quadrature_rule_gaussian_type) :: quadrature_rule integer(tik) :: id - integer(i_def) :: nqp_h_exact, nqp_v_exact - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - - nqp_h_exact = config%finite_element%nqp_h_exact() - nqp_v_exact = config%finite_element%nqp_v_exact() - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then + if (element_order_h == 0 .and. element_order_v == 0) then detj_at_w3 => get_detj_at_w3_fv(mesh_id) return end if @@ -500,7 +464,8 @@ contains ! Create the object as it doesn't exist yet if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - w3_fs => function_space_collection%get_fs(mesh, order_h, order_v, W3) + w3_fs => function_space_collection%get_fs(mesh, element_order_h, & + element_order_v, W3) call detj_at_w3_inventory_fe%add_field(detj_at_w3, w3_fs, mesh) ! @TODO #4487: it is inefficient to calculate this via mass matrices @@ -601,16 +566,14 @@ contains !> @brief Returns the (finite element) Det(J) values at W2 dof locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field - function get_detj_at_w2_fe(config, mesh_id) result(detj_at_w2) + function get_detj_at_w2_fe(mesh_id) result(detj_at_w2) use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id - + integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh logical(kind=l_def) :: constant_exists type(field_type), pointer :: detj_at_w2 @@ -620,13 +583,8 @@ contains type(function_space_type), pointer :: w2_fs integer(tik) :: id - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then + if (element_order_h == 0 .and. element_order_v == 0) then detj_at_w2 => get_detj_at_w2_fv(mesh_id) return end if @@ -647,7 +605,8 @@ contains ! Create the object as it doesn't exist yet if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - w2_fs => function_space_collection%get_fs(mesh, order_h, order_v, W2) + w2_fs => function_space_collection%get_fs(mesh, element_order_h, & + element_order_v, W2) call multiplicity_w2%initialise( w2_fs ) call detj_at_w2_inventory_fe%add_field(detj_at_w2, w2_fs, mesh) @@ -724,15 +683,13 @@ contains !> @brief Returns a pointer to the vertical grid spacing, located at W3 DoFs !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The physical height difference of layers, at W3 - function get_dz_w3(config, mesh_id) result(dz_w3) + function get_dz_w3(mesh_id) result(dz_w3) use sci_get_dz_w3_kernel_mod, only: get_dz_w3_kernel_type implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id - + integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(field_type), pointer :: dz_w3 logical(kind=l_def) :: constant_exists @@ -751,7 +708,7 @@ contains if (.not. constant_exists) then ! If this constant doesn't exist, create it ! Get height first to avoid potentially timing twice - height_w2 => get_height_fv(config, W2, mesh_id) + height_w2 => get_height_fv(W2, mesh_id) if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) @@ -860,15 +817,13 @@ contains !> @brief Returns the 1/dz values at lowest-order Wtheta DoF locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The dz_at_wtheta field - function get_dz_at_wtheta(config, mesh_id) result(dz_at_wtheta) + function get_dz_at_wtheta(mesh_id) result(dz_at_wtheta) use sci_calc_dz_face_kernel_mod, only: calc_dz_face_kernel_type implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id - + integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(field_type), pointer :: dz_at_wtheta type(function_space_type), pointer :: wtheta_k0_fs @@ -892,8 +847,8 @@ contains ! Create constant if it doesn't already exist if (.not. constant_exists) then ! NB: this assumes heights are in the lowest-order space - height_w3 => get_height_fv(config, W3, mesh_id) - height_wth => get_height_fv(config, Wtheta, mesh_id) + height_w3 => get_height_fv(W3, mesh_id) + height_wth => get_height_fv(Wtheta, mesh_id) if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) @@ -916,15 +871,15 @@ contains !> i.e. ignoring the orographic effect on the area !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The dA_msl_proj field - function get_dA_msl_proj(config, mesh_id) result(dA_msl_proj) + function get_dA_msl_proj(mesh_id) result(dA_msl_proj) + use base_mesh_config_mod, only: geometry, geometry_spherical + use extrusion_config_mod, only: planet_radius, domain_height use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type implicit none - type(config_type), intent(in) :: config - integer(kind=i_def), intent(in) :: mesh_id - + integer(kind=i_def), intent(in) :: mesh_id integer(kind=i_def) :: local_mesh_id type(mesh_type), pointer :: mesh type(mesh_type), pointer :: prime_mesh @@ -936,14 +891,6 @@ contains type(function_space_type), pointer :: fs integer(tik) :: id - integer(i_def) :: geometry - real(r_def) :: planet_radius - real(r_def) :: domain_height - - geometry = config%base_mesh%geometry() - planet_radius = config%extrusion%planet_radius() - domain_height = config%extrusion%domain_height() - ! Initialise inventory if it hasn't been done so already if (.not. dA_msl_proj_inventory%is_initialised()) then call dA_msl_proj_inventory%initialise(name="dA_msl_proj") @@ -981,16 +928,13 @@ contains ! ========================================================================== ! !> @brief Returns a pointer to the longitude of finite element DoFs - !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the longitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The longitude field - function get_longitude_fe(config, space_id, mesh_id) result(long_ptr) + function get_longitude_fe(space_id, mesh_id) result(long_ptr) implicit none - type(config_type), intent(in) :: config - integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1001,14 +945,9 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - long_ptr => get_longitude_fv(config, space_id, mesh_id) + if (element_order_h == 0 .and. element_order_v == 0) then + long_ptr => get_longitude_fv(space_id, mesh_id) return end if @@ -1044,8 +983,8 @@ contains constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.true.) + call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & + use_fe=.true.) end if call long_inventory%get_field(local_mesh, long_ptr) @@ -1053,16 +992,13 @@ contains end function get_longitude_fe !> @brief Returns a pointer to the longitude of finite volume DoFs - !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the longitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The longitude field - function get_longitude_fv(config, space_id, mesh_id) result(long_ptr) + function get_longitude_fv(space_id, mesh_id) result(long_ptr) implicit none - type(config_type), intent(in) :: config - integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1105,8 +1041,8 @@ contains constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.false.) + call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & + use_fe=.false.) end if call long_inventory%get_field(local_mesh, long_ptr) @@ -1114,16 +1050,13 @@ contains end function get_longitude_fv !> @brief Returns a pointer to the latitude of finite element DoFs - !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the latitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The latitude field - function get_latitude_fe(config, space_id, mesh_id) result(lat_ptr) + function get_latitude_fe(space_id, mesh_id) result(lat_ptr) implicit none - type(config_type), intent(in) :: config - integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1134,14 +1067,9 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - lat_ptr => get_latitude_fv(config, space_id, mesh_id) + if (element_order_h == 0 .and. element_order_v == 0) then + lat_ptr => get_latitude_fv(space_id, mesh_id) return end if @@ -1177,8 +1105,8 @@ contains constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.true.) + call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & + use_fe=.true.) end if call lat_inventory%get_field(local_mesh, lat_ptr) @@ -1186,16 +1114,13 @@ contains end function get_latitude_fe !> @brief Returns a pointer to the latitude of finite volume DoFs - !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the latitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The latitude field - function get_latitude_fv(config, space_id, mesh_id) result(lat_ptr) + function get_latitude_fv(space_id, mesh_id) result(lat_ptr) implicit none - type(config_type), intent(in) :: config - integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1238,8 +1163,8 @@ contains constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.false.) + call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & + use_fe=.false.) end if call lat_inventory%get_field(local_mesh, lat_ptr) @@ -1250,16 +1175,17 @@ contains !> @param[in] space The space of the desired height field !> @param[in] mesh_id The ID of the mesh to get the object for !> @return A height field - function get_height_fe(config, space_id, mesh_id) result(height) + function get_height_fe(space_id, mesh_id) result(height) use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type use sci_height_discontinuous_kernel_mod, & only: height_discontinuous_kernel_type + use base_mesh_config_mod, only: geometry + use finite_element_config_mod, only: coord_system + use planet_config_mod, only: scaled_radius implicit none - type(config_type), intent(in) :: config - integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1274,19 +1200,9 @@ contains character(len=str_def) :: inventory_name integer(tik) :: id - real(r_def) :: scaled_radius - integer(i_def) :: geometry, coord_system - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - coord_system = config%finite_element%coord_system() - geometry = config%base_mesh%geometry() - scaled_radius = config%planet%scaled_radius() - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - height => get_height_fv(config, space_id, mesh_id) + if (element_order_h == 0 .and. element_order_v == 0) then + height => get_height_fv(space_id, mesh_id) return end if @@ -1329,8 +1245,9 @@ contains if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - space => function_space_collection%get_fs(mesh, order_h, order_v, & - space_id) + space => function_space_collection%get_fs( & + mesh, element_order_h, element_order_v, space_id & + ) call inventory%add_field(height, space, mesh) select case (space_id) @@ -1373,16 +1290,17 @@ contains !> @param[in] space The space of the desired height field !> @param[in] mesh_id The ID of the mesh to get the object for !> @return A height field - function get_height_fv(config, space_id, mesh_id) result(height) + function get_height_fv(space_id, mesh_id) result(height) use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type use sci_height_discontinuous_kernel_mod, & only: height_discontinuous_kernel_type + use base_mesh_config_mod, only: geometry + use finite_element_config_mod, only: coord_system + use planet_config_mod, only: scaled_radius implicit none - type(config_type), intent(in) :: config - integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1397,13 +1315,6 @@ contains character(len=str_def) :: inventory_name integer(tik) :: id - real(r_def) :: scaled_radius - integer(i_def) :: geometry, coord_system - - coord_system = config%finite_element%coord_system() - geometry = config%base_mesh%geometry() - scaled_radius = config%planet%scaled_radius() - ! Determine inventory based on space select case (space_id) case (W0) From 7869db7d812e8d7161c1b50d6bf281a44ac613c2 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 25 Mar 2026 13:29:59 +0000 Subject: [PATCH 09/44] Need an unaltered compute latlon --- .../new_sci_compute_latlon_kernel_mod.F90 | 142 ++++++++++++++++++ 1 file changed, 142 insertions(+) create mode 100644 components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 diff --git a/components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 b/components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 new file mode 100644 index 000000000..6337098b1 --- /dev/null +++ b/components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 @@ -0,0 +1,142 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright 2019 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 Returns latitude and longitude fields +!> +module new_sci_compute_latlon_kernel_mod + + use argument_mod, only: arg_type, func_type, & + GH_FIELD, GH_SCALAR, & + GH_INTEGER, GH_REAL, & + GH_WRITE, GH_READ, & + ANY_SPACE_1, & + ANY_DISCONTINUOUS_SPACE_3, & + ANY_SPACE_9, GH_BASIS, & + CELL_COLUMN, GH_EVALUATOR + use constants_mod, only: r_def, i_def + use kernel_mod, only: kernel_type + use sci_chi_transform_mod, only: chi2llr + + implicit none + + private + + !--------------------------------------------------------------------------- + ! Public types + !--------------------------------------------------------------------------- + !> Metadata describing the kernel to PSyclone + !> + type, public, extends(kernel_type) :: compute_latlon_kernel_type + private + type(arg_type) :: meta_args(8) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & + arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & + 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_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius + /) + + type(func_type) :: meta_funcs(1) = (/ & + func_type(ANY_SPACE_9, GH_BASIS) & + /) + integer :: operates_on = CELL_COLUMN + integer :: gh_shape = GH_EVALUATOR + contains + procedure, nopass :: compute_latlon_code + end type + + + !--------------------------------------------------------------------------- + ! Contained functions/subroutines + !--------------------------------------------------------------------------- + public :: compute_latlon_code + +contains + +!> @brief Calculates the latitude and longitude fields from the x, y and z components +!> @details Will only work at lowest order for now +!> @param[in] nlayers The number of layers (always 1) +!> @param[in,out] latitude Latitude field data +!> @param[in,out] longitude Longitude field data +!> @param[in] chi_1 First component of the coordinate field +!> @param[in] chi_2 Second component of the coordinate field +!> @param[in] chi_3 Third component of the coordinate field +!> @param[in] panel_id A field giving the ID for mesh panels +!> @param[in] geometry +!> @param[in] topology +!> @param[in] coord_system +!> @param[in] scaled_radius +!> @param[in] ndf_x Number of degrees of freedom per cell for height +!> @param[in] undf_x Number of unique degrees of freedom for height +!> @param[in] map_x Dofmap for the cell at the base of the column for height +!> @param[in] ndf_chi The number of degrees of freedom per cell for chi +!> @param[in] undf_chi The 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] basis_chi Basis functions evaluated at nodal points for height +!> @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 +subroutine compute_latlon_code(nlayers, & + latitude, longitude, & + chi_1, chi_2, chi_3, & + panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + ndf_x, undf_x, map_x, & + ndf_chi, undf_chi, map_chi, & + basis_chi, & + ndf_pid, undf_pid, map_pid & + ) + + implicit none + + ! Arguments + integer(kind=i_def), intent(in) :: nlayers + integer(kind=i_def), intent(in) :: ndf_x, undf_x + integer(kind=i_def), intent(in) :: ndf_chi, undf_chi + integer(kind=i_def), intent(in) :: ndf_pid, undf_pid + + real(kind=r_def), dimension(undf_x), intent(inout) :: latitude, longitude + 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 + + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + integer(kind=i_def), intent(in) :: coord_system + real(kind=r_def), intent(in) :: scaled_radius + + integer(kind=i_def), dimension(ndf_x), intent(in) :: map_x + integer(kind=i_def), dimension(ndf_chi), intent(in) :: map_chi + integer(kind=i_def), dimension(ndf_pid), intent(in) :: map_pid + real(kind=r_def), dimension(1, ndf_chi, ndf_x), intent(in) :: basis_chi + + ! Internal variables + integer(kind=i_def) :: df_chi, df_x, k, ipanel + real(kind=r_def) :: coords(3), lat, lon, radius + + ipanel = int(panel_id(map_pid(1)), i_def) + + do k = 0, nlayers-1 + do df_x = 1, ndf_x + coords(:) = 0.0_r_def + do df_chi = 1, ndf_chi + coords(1) = coords(1) + chi_1(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) + coords(2) = coords(2) + chi_2(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) + coords(3) = coords(3) + chi_3(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) + end do + call chi2llr(coords(1), coords(2), coords(3), ipanel, & + geometry, topology, coord_system, scaled_radius, & + lon, lat, radius) + latitude(map_x(df_x) + k) = lat + longitude(map_x(df_x) + k) = lon + end do + end do + +end subroutine compute_latlon_code + +end module new_sci_compute_latlon_kernel_mod From a019544428403cb4f88676de57a9e996241c7989 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 25 Mar 2026 13:32:14 +0000 Subject: [PATCH 10/44] Revert old compute latlon --- .../sci_compute_latlon_kernel_mod.F90 | 33 ++++--------------- 1 file changed, 7 insertions(+), 26 deletions(-) diff --git a/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 b/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 index bac76055b..1ca3f2776 100644 --- a/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 @@ -8,10 +8,9 @@ module sci_compute_latlon_kernel_mod use argument_mod, only: arg_type, func_type, & - GH_FIELD, GH_SCALAR, & - GH_INTEGER, GH_REAL, & + GH_FIELD, GH_REAL, & GH_WRITE, GH_READ, & - ANY_SPACE_1, & + ANY_SPACE_1, & ANY_DISCONTINUOUS_SPACE_3, & ANY_SPACE_9, GH_BASIS, & CELL_COLUMN, GH_EVALUATOR @@ -30,17 +29,12 @@ module sci_compute_latlon_kernel_mod !> type, public, extends(kernel_type) :: compute_latlon_kernel_type private - type(arg_type) :: meta_args(8) = (/ & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & + type(arg_type) :: meta_args(4) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & + arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & 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_SCALAR, GH_INTEGER, GH_READ), &! geometry - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system - arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3) & /) - type(func_type) :: meta_funcs(1) = (/ & func_type(ANY_SPACE_9, GH_BASIS) & /) @@ -67,10 +61,6 @@ module sci_compute_latlon_kernel_mod !> @param[in] chi_2 Second component of the coordinate field !> @param[in] chi_3 Third component of the coordinate field !> @param[in] panel_id A field giving the ID for mesh panels -!> @param[in] geometry -!> @param[in] topology -!> @param[in] coord_system -!> @param[in] scaled_radius !> @param[in] ndf_x Number of degrees of freedom per cell for height !> @param[in] undf_x Number of unique degrees of freedom for height !> @param[in] map_x Dofmap for the cell at the base of the column for height @@ -85,8 +75,6 @@ subroutine compute_latlon_code(nlayers, & latitude, longitude, & chi_1, chi_2, chi_3, & panel_id, & - geometry, topology, & - coord_system, scaled_radius, & ndf_x, undf_x, map_x, & ndf_chi, undf_chi, map_chi, & basis_chi, & @@ -105,11 +93,6 @@ subroutine compute_latlon_code(nlayers, & 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 - integer(kind=i_def), intent(in) :: geometry - integer(kind=i_def), intent(in) :: topology - integer(kind=i_def), intent(in) :: coord_system - real(kind=r_def), intent(in) :: scaled_radius - integer(kind=i_def), dimension(ndf_x), intent(in) :: map_x integer(kind=i_def), dimension(ndf_chi), intent(in) :: map_chi integer(kind=i_def), dimension(ndf_pid), intent(in) :: map_pid @@ -129,9 +112,7 @@ subroutine compute_latlon_code(nlayers, & coords(2) = coords(2) + chi_2(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) coords(3) = coords(3) + chi_3(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) end do - call chi2llr(coords(1), coords(2), coords(3), ipanel, & - geometry, topology, coord_system, scaled_radius, & - lon, lat, radius) + call chi2llr(coords(1), coords(2), coords(3), ipanel, lon, lat, radius) latitude(map_x(df_x) + k) = lat longitude(map_x(df_x) + k) = lon end do From 131f7fc22872628963a303d387c05d7ce2ea754c Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 25 Mar 2026 13:51:18 +0000 Subject: [PATCH 11/44] Duplicate more --- applications/coupled/source/driver/init_coupled_mod.X90 | 2 +- .../source/algorithm/new_sci_geometric_constants_mod.x90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/applications/coupled/source/driver/init_coupled_mod.X90 b/applications/coupled/source/driver/init_coupled_mod.X90 index 8715a45a2..4955fe372 100644 --- a/applications/coupled/source/driver/init_coupled_mod.X90 +++ b/applications/coupled/source/driver/init_coupled_mod.X90 @@ -29,7 +29,7 @@ module init_coupled_mod LOG_LEVEL_ERROR use mesh_mod, only : mesh_type use pure_abstract_field_mod, only : pure_abstract_field_type - use sci_compute_latlon_kernel_mod, only : compute_latlon_kernel_type + use new_sci_compute_latlon_kernel_mod, only : compute_latlon_kernel_type implicit none diff --git a/components/science/source/algorithm/new_sci_geometric_constants_mod.x90 b/components/science/source/algorithm/new_sci_geometric_constants_mod.x90 index 1f3cf7539..71d4b265c 100644 --- a/components/science/source/algorithm/new_sci_geometric_constants_mod.x90 +++ b/components/science/source/algorithm/new_sci_geometric_constants_mod.x90 @@ -148,7 +148,7 @@ contains subroutine compute_latlon(config, long_inventory, lat_inventory, & mesh, fs_id, use_fe) - use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type + use new_sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type implicit none From bffc6d979924a32119247678c59005fe684b141d Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 25 Mar 2026 13:56:02 +0000 Subject: [PATCH 12/44] duplicate chi_transform --- .../geometry/new_sci_chi_transform_mod.F90 | 637 ++++++++++++++++++ .../kernel/geometry/sci_chi_transform_mod.F90 | 96 +-- 2 files changed, 660 insertions(+), 73 deletions(-) create mode 100644 components/science/source/kernel/geometry/new_sci_chi_transform_mod.F90 diff --git a/components/science/source/kernel/geometry/new_sci_chi_transform_mod.F90 b/components/science/source/kernel/geometry/new_sci_chi_transform_mod.F90 new file mode 100644 index 000000000..219be0180 --- /dev/null +++ b/components/science/source/kernel/geometry/new_sci_chi_transform_mod.F90 @@ -0,0 +1,637 @@ +!------------------------------------------------------------------------------- +! (c) Crown copyright 2021 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 Routines for transforming the chi coordinate fields +!! +!! @details Contains routines for conversion of chi coordinate fields. These +!! are accessed through the chi2ABC interface functions, so that +!! which coord_system chi is in, it will convert the +!! coordinates to the ABC system +!------------------------------------------------------------------------------ +module new_sci_chi_transform_mod + +use constants_mod, only : r_def, i_def, l_def, & + str_def, EPS, PI, rmdi +use coord_transform_mod, only : alphabetar2xyz, & + alphabetar2llr, & + xyz2alphabetar, & + llr2xyz, xyz2llr, & + xyz2ll, & + mesh_rotation_matrix, & + schmidt_transform_xyz, & + inverse_schmidt_transform_xyz +use log_mod, only : log_event, & + log_scratch_space, & + LOG_LEVEL_ERROR, & + LOG_LEVEL_DEBUG, & + LOG_LEVEL_WARNING +use matrix_invert_mod, only : matrix_invert_3x3 + +! Configuration modules +use base_mesh_config_mod, only: geometry_spherical, & + geometry_planar, & + topology_fully_periodic +use finite_element_config_mod, only: coord_system_xyz, & + coord_system_native + +implicit none + +private + +! ---------------------------------------------------------------------------- ! +! Private matrices or values that need computing once +! ---------------------------------------------------------------------------- ! + +real(kind=r_def) :: chi2xyz_rot_mat(3,3) +real(kind=r_def) :: xyz2chi_rot_mat(3,3) +real(kind=r_def) :: stretch_factor +logical(kind=l_def) :: to_rotate +logical(kind=l_def) :: to_stretch + +! ---------------------------------------------------------------------------- ! +! Public subroutines +! ---------------------------------------------------------------------------- ! +public :: init_chi_transforms +public :: final_chi_transforms +public :: chi2xyz +public :: chi2abr +public :: chi2llr +public :: chir2xyz +public :: get_mesh_rotation_matrix +public :: get_inverse_mesh_rotation_matrix +public :: get_stretch_factor +public :: get_to_rotate +public :: get_to_stretch + +!------------------------------------------------------------------------------ +! Contained functions / subroutines +!------------------------------------------------------------------------------ +contains + +!------------------------------------------------------------------------------ +!> @brief Initialise the coordinate transform information +!! +!> @param[in] geometry +!> @param[in] topology +!> @param[in] mesh_collection Optional: a collection of meshes, which contain +!! metadata used to determine the rotation matrix +!! and stretching factors. +!> @param[in] north_pole_arg Optional: target north pole, used to generate +!! the rotation matrix. This is incompatible with +!! the mesh_collection argument, and ideally +!! should only be used for unit-testing. +!> @param[in] equator_lat_arg Optional: Latitude of the equator of the mesh, +!! allowing a stretching to be described. +!! This is incompatible with the mesh_collection +!! argument, and ideally should only be used for +!! unit-testing. +!------------------------------------------------------------------------------ +subroutine init_chi_transforms( geometry, & + topology, & + mesh_collection, & + north_pole_arg, equator_lat_arg ) + + use local_mesh_mod, only: local_mesh_type + use mesh_collection_mod, only: mesh_collection_type + use mesh_mod, only: mesh_type + + implicit none + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + + type(mesh_collection_type), optional, intent(in) :: mesh_collection + real(kind=r_def), optional, intent(in) :: north_pole_arg(2) + real(kind=r_def), optional, intent(in) :: equator_lat_arg + + type(mesh_type), pointer :: mesh + type(local_mesh_type), pointer :: local_mesh + character(str_def), allocatable :: all_mesh_names(:) + + real(kind=r_def) :: north_pole(2) + real(kind=r_def) :: null_island(2) + real(kind=r_def) :: equatorial_latitude + + ! -------------------------------------------------------------------------- ! + ! Extract stretching and rotation information from mesh + ! -------------------------------------------------------------------------- ! + ! Begin by assuming no stretching and no rotation + to_stretch = .false. + to_rotate = .false. + north_pole(1) = PI + north_pole(2) = PI/2.0_r_def + null_island(1) = 0.0_r_def + null_island(2) = 0.0_r_def + equatorial_latitude = 0.0_r_def + + if ( present(mesh_collection) .and. & + (present(equator_lat_arg) .or. present(north_pole_arg)) ) then + call log_event( & + 'init_chi_transform: mesh_compatible argument cannot be passed with ' // & + 'another argument', LOG_LEVEL_ERROR & + ) + end if + + if (present(mesh_collection)) then + ! NB: + ! At this stage, we will assume that the stretching and rotation are the same + ! for all meshes. If they weren't, we would need to extract a different factor + ! and different rotation matrix for each mesh. The chi2*** transforms would + ! also need to take mesh_id as an argument, which would be a major API change + ! since it would need passing through each kernel. + ! Therefore, extract first mesh from collection ... + all_mesh_names = mesh_collection%get_mesh_names() + if (SIZE(all_mesh_names) > 0) then + mesh => mesh_collection%get_mesh(all_mesh_names(1)) + else + call log_event( & + 'init_chi_transform: unable to determine mesh rotation and ' // & + 'stretching because there are no meshes!', LOG_LEVEL_ERROR & + ) + end if + + ! Extract rotation and stretching information from global mesh + local_mesh => mesh%get_local_mesh() + north_pole = local_mesh%get_north_pole() + null_island = local_mesh%get_null_island() + equatorial_latitude = local_mesh%get_equatorial_latitude() + + ! If any variables are unset, set them to defaults here -------------------- + if ( abs(north_pole(1) - rmdi) < EPS & + .or. abs(north_pole(2) - rmdi) < EPS ) then + north_pole(1) = 0.0_r_def + north_pole(2) = PI/2.0_r_def + call log_event( & + 'Mesh North Pole not set, so using (lon=0, lat=pi/2) as default', & + LOG_LEVEL_WARNING & + ) + end if + if ( abs(null_island(1) - rmdi) < EPS & + .or. abs(null_island(2) - rmdi) < EPS ) then + null_island(1) = 0.0_r_def + null_island(2) = 0.0_r_def + call log_event( & + 'Mesh Null Island not set, so using (lon=0, lat=0) as default', & + LOG_LEVEL_WARNING & + ) + end if + if ( abs(equatorial_latitude - rmdi) < EPS .or. & + geometry == geometry_planar .or. topology /= topology_fully_periodic ) then + equatorial_latitude = 0.0_r_def + call log_event( & + 'Equatorial latitude for mesh not set, so using 0.0 as default', & + LOG_LEVEL_WARNING & + ) + end if + end if ! present(mesh_collection) + + if (present(north_pole_arg)) north_pole = north_pole_arg + if (present(equator_lat_arg)) equatorial_latitude = equator_lat_arg + + + ! Now that parameters have been read in, determine if stretching or rotation + ! are actually happening + to_stretch = abs(equatorial_latitude) > EPS + ! It's probably safer to check both the null island and the north pole here + to_rotate = ( abs(north_pole(2) - PI/2.0_r_def) > EPS & + .or. abs(null_island(1)) > EPS .or. abs(null_island(2)) > EPS ) + + ! Compute Schmidt stretch factor --------------------------------------------- + stretch_factor = sqrt( (1.0_r_def - sin(equatorial_latitude)) & + / (1.0_r_def + sin(equatorial_latitude)) ) + + ! Compute rotation matrix ---------------------------------------------------- + chi2xyz_rot_mat = mesh_rotation_matrix(north_pole) + + ! Compute inverse rotation matrix -------------------------------------------- + xyz2chi_rot_mat = matrix_invert_3x3(chi2xyz_rot_mat) + + write(log_scratch_space,'(A,L6,A,2E16.8)') & + 'Mesh rotation: ', to_rotate, ' north pole: ', north_pole(1), north_pole(2) + call log_event(log_scratch_space, LOG_LEVEL_DEBUG) + write(log_scratch_space,'(A,L6,A,E16.8,A,E16.8)') & + 'Mesh stretching: ', to_stretch, ' stretching factor: ', stretch_factor, & + ' latitude of equator: ', equatorial_latitude + call log_event(log_scratch_space, LOG_LEVEL_DEBUG) + +end subroutine init_chi_transforms + +!------------------------------------------------------------------------------ +!> @brief Nullify the coordinate transform values +!------------------------------------------------------------------------------ +subroutine final_chi_transforms() + + implicit none + + to_stretch = .false. + to_rotate = .false. + stretch_factor = rmdi + chi2xyz_rot_mat(:,:) = 0.0_r_def + xyz2chi_rot_mat(:,:) = 0.0_r_def + +end subroutine final_chi_transforms + + +!------------------------------------------------------------------------------- +!> @brief Transforms a coordinate field chi from any system into global +!> Cartesian (X,Y,Z) coordinates. If chi is in a spherical coordinate +!> system, the third coordinate should be height, and the scaled_radius +!> will be added to the height to give the radius before the coordinates +!> are transformed to (X,Y,Z) coordinates. +!! +!! @param[in] chi_1 The first coordinate field in +!! @param[in] chi_2 The second coordinate field in +!! @param[in] chi_3 The third coordinate field in +!! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius +!! @param[in] panel_id The mesh panel ID +!! @param[out] x The first coordinate field out (global Cartesian X) +!! @param[out] y The second coordinate field out (global Cartesian Y) +!! @param[out] z The third coordinate field out (global Cartesian Z) +!------------------------------------------------------------------------------- +subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + x, y, z ) + + implicit none + + integer(kind=i_def), intent(in) :: panel_id + real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 + real(kind=r_def), intent(out) :: x, y, z + + real(kind=r_def) :: xyz(3) + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + + if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then + ! chi already uses (geocentric) Cartesian coordinates + x = chi_1 + y = chi_2 + z = chi_3 + + else if (topology /= topology_fully_periodic) then + ! domain is a spherical LAM, using (lon,lat,z) coordinates + call llr2xyz(chi_1, chi_2, chi_3+scaled_radius, x, y, z) + + if (to_rotate) then + xyz(1) = x + xyz(2) = y + xyz(3) = z + + xyz = matmul(chi2xyz_rot_mat, xyz) + + x = xyz(1) + y = xyz(2) + z = xyz(3) + end if + + else + ! cubed-sphere coordinates + ! transform to native (X,Y,Z) coordinates + call alphabetar2xyz(chi_1, chi_2, chi_3+scaled_radius, panel_id, x, y, z) + + ! stretch, if necessary + if (to_stretch) then + xyz(1) = x + xyz(2) = y + xyz(3) = z + + xyz = schmidt_transform_xyz(xyz, stretch_factor) + + x = xyz(1) + y = xyz(2) + z = xyz(3) + end if + + ! rotate, if necessary + if (to_rotate) then + xyz(1) = x + xyz(2) = y + xyz(3) = z + + xyz = matmul(chi2xyz_rot_mat, xyz) + + x = xyz(1) + y = xyz(2) + z = xyz(3) + end if + end if + +end subroutine chi2xyz + + +!------------------------------------------------------------------------------- +!> @brief Transforms a coordinate field chi from any system into global +!> Cartesian (X,Y,Z) coordinates. If chi is in a spherical coordinate +!> system, the third coordinate should be radius (distinguishing this +!> function from chi2xyz above). Therefore this will not add the +!> scaled_radius to transform. +!! +!! @param[in] chi_1 The first coordinate field in +!! @param[in] chi_2 The second coordinate field in +!! @param[in] chi_3 The third coordinate field in +!! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[out] x The first coordinate field out (global Cartesian X) +!! @param[out] y The second coordinate field out (global Cartesian Y) +!! @param[out] z The third coordinate field out (global Cartesian Z) +!------------------------------------------------------------------------------- +subroutine chir2xyz( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, coord_system, & + x, y, z ) + + implicit none + + integer(kind=i_def), intent(in) :: panel_id + real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 + real(kind=r_def), intent(out) :: x, y, z + + real(kind=r_def) :: xyz(3) + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + + if (coord_system == coord_system_xyz .or. geometry == geometry_planar) then + ! chi already uses (geocentric) Cartesian coordinates + x = chi_1 + y = chi_2 + z = chi_3 + + else if (topology /= topology_fully_periodic) then + ! domain is a spherical LAM, using (lon,lat,z) coordinates + call llr2xyz(chi_1, chi_2, chi_3, x, y, z) + + if (to_rotate) then + xyz(1) = x + xyz(2) = y + xyz(3) = z + + xyz = matmul(chi2xyz_rot_mat, xyz) + + x = xyz(1) + y = xyz(2) + z = xyz(3) + end if + + else + ! cubed-sphere coordinates + ! transform to native (X,Y,Z) coordinates + call alphabetar2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) + + ! stretch, if necessary + if (to_stretch) then + xyz(1) = x + xyz(2) = y + xyz(3) = z + + xyz = schmidt_transform_xyz(xyz, stretch_factor) + + x = xyz(1) + y = xyz(2) + z = xyz(3) + end if + + ! rotate, if necessary + if (to_rotate) then + xyz(1) = x + xyz(2) = y + xyz(3) = z + + xyz = matmul(chi2xyz_rot_mat, xyz) + + x = xyz(1) + y = xyz(2) + z = xyz(3) + end if + end if + +end subroutine chir2xyz + + +!------------------------------------------------------------------------------- +!> @brief Transforms a coordinate field chi from any system into spherical polar +!> (longitude, latitude, radius) coordinates +!! +!! @param[in] chi_1 The first coordinate field in +!! @param[in] chi_2 The second coordinate field in +!! @param[in] chi_3 The third coordinate field in +!! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius +!! @param[out] longitude The first coordinate field out (longitude) +!! @param[out] latitude The second coordinate field out (latitude) +!! @param[out] radius The third coordinate field out (radius) +!------------------------------------------------------------------------------- +subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + lon, lat, radius ) + + implicit none + + integer(kind=i_def), intent(in) :: panel_id + real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 + real(kind=r_def), intent(out) :: lon, lat, radius + + real(kind=r_def) :: xyz(3) + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + + if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then + ! chi uses (geocentric) Cartesian coordinates + call xyz2llr(chi_1, chi_2, chi_3, lon, lat, radius) + + else if (topology /= topology_fully_periodic) then + ! domain is a spherical LAM, already using (lon,lat,z) coordinates + ! may need to rotate these to the physical (lon,lat) coordinates + + ! avoid conversions in computing radius + radius = chi_3 + scaled_radius + + if (to_rotate) then + call llr2xyz(chi_1, chi_2, radius, xyz(1), xyz(2), xyz(3)) + xyz = matmul(chi2xyz_rot_mat, xyz) + call xyz2ll(xyz(1), xyz(2), xyz(3), lon, lat) + else + lon = chi_1 + lat = chi_2 + end if + + else + ! cubed-sphere coordinates + ! transform to native (X,Y,Z) coordinates + radius = chi_3 + scaled_radius + + if (to_stretch .or. to_rotate) then + call alphabetar2xyz(chi_1, chi_2, radius, panel_id, xyz(1), xyz(2), xyz(3)) + + ! stretch, if necessary + if (to_stretch) then + xyz = schmidt_transform_xyz(xyz, stretch_factor) + end if + + ! rotate, if necessary + if (to_rotate) then + xyz = matmul(chi2xyz_rot_mat, xyz) + end if + + ! convert to spherical polar coordinates + call xyz2ll(xyz(1), xyz(2), xyz(3), lon, lat) + + else + call alphabetar2llr(chi_1, chi_2, radius, panel_id, lon, lat) + end if + + end if + +end subroutine chi2llr + + +!------------------------------------------------------------------------------- +!> @brief Transforms a coordinate field chi from any system into *native* +!! equiangular cubed sphere (alpha,beta,radius) coordinates +!! +!! @param[in] chi_1 The first coordinate field in +!! @param[in] chi_2 The second coordinate field in +!! @param[in] chi_3 The third coordinate field in +!! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius +!! @param[out] alpha The first coordinate field out (alpha) +!! @param[out] beta The second coordinate field out (beta) +!! @param[out] radius The third coordinate field out (radius) +!------------------------------------------------------------------------------- +subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + alpha, beta, radius ) + + implicit none + + integer(kind=i_def), intent(in) :: panel_id + real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 + real(kind=r_def), intent(out) :: alpha, beta, radius + + real(kind=r_def) :: xyz(3) + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + + if (topology /= topology_fully_periodic .or. geometry /= geometry_spherical) then + + call log_event( 'chi2abr can only be used on cubed-sphere meshes', & + LOG_LEVEL_ERROR ) + + else if (coord_system == coord_system_native) then + alpha = chi_1 + beta = chi_2 + radius = chi_3 + scaled_radius + + else + ! geocentric Cartesian coordinates + xyz(1) = chi_1 + xyz(2) = chi_2 + xyz(3) = chi_3 + + ! un-rotate, if necessary + if (to_rotate) then + xyz = matmul(xyz2chi_rot_mat, xyz) + end if + + ! un-stretch, if necessary + if (to_stretch) then + xyz = inverse_schmidt_transform_xyz(xyz, stretch_factor) + end if + + ! transform to equiangular cubed-sphere coordinates + call xyz2alphabetar(xyz(1), xyz(2), xyz(3), panel_id, alpha, beta, radius) + end if + +end subroutine chi2abr + +!------------------------------------------------------------------------------- +!> @brief Returns a pointer to the rotation matrix for transforming from the +!! native Cartesian coordinates to the physical Cartesian coordinates +!------------------------------------------------------------------------------- +function get_mesh_rotation_matrix() result(rot_mat) + + implicit none + real(kind=r_def) :: rot_mat(3,3) + + rot_mat = chi2xyz_rot_mat + +end function get_mesh_rotation_matrix + +!------------------------------------------------------------------------------- +!> @brief Returns a pointer to the inverse rotation matrix, transforming from +!! physical Cartesian coordinates to native Cartesian coordinates +!------------------------------------------------------------------------------- +function get_inverse_mesh_rotation_matrix() result(rot_mat) + + implicit none + real(kind=r_def) :: rot_mat(3,3) + + rot_mat = xyz2chi_rot_mat + +end function get_inverse_mesh_rotation_matrix + +!------------------------------------------------------------------------------- +!> @brief Returns the Schmidt transform stretch factor +!------------------------------------------------------------------------------- +function get_stretch_factor() result(stretch_factor_out) + + implicit none + real(kind=r_def) :: stretch_factor_out + + stretch_factor_out = stretch_factor + +end function get_stretch_factor + +!------------------------------------------------------------------------------- +!> @brief Returns whether coordinates are rotated +!------------------------------------------------------------------------------- +function get_to_rotate() result(to_rotate_out) + + implicit none + logical(kind=l_def) :: to_rotate_out + + to_rotate_out = to_rotate + +end function get_to_rotate + +!------------------------------------------------------------------------------- +!> @brief Returns whether coordinates are stretched +!------------------------------------------------------------------------------- +function get_to_stretch() result(to_stretch_out) + + implicit none + logical(kind=l_def) :: to_stretch_out + + to_stretch_out = to_stretch + +end function get_to_stretch + +end module new_sci_chi_transform_mod + diff --git a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 index 0d9f4a84b..39ccfe0fb 100644 --- a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 +++ b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 @@ -30,12 +30,15 @@ module sci_chi_transform_mod LOG_LEVEL_WARNING use matrix_invert_mod, only : matrix_invert_3x3 -! Configuration modules -use base_mesh_config_mod, only: geometry_spherical, & - geometry_planar, & - topology_fully_periodic -use finite_element_config_mod, only: coord_system_xyz, & - coord_system_native +use base_mesh_config_mod, only : geometry, & + geometry_spherical, & + geometry_planar, & + topology, & + topology_fully_periodic +use finite_element_config_mod, only : coord_system, & + coord_system_xyz, & + coord_system_native +use planet_config_mod, only : scaled_radius implicit none @@ -74,8 +77,6 @@ module sci_chi_transform_mod !------------------------------------------------------------------------------ !> @brief Initialise the coordinate transform information !! -!> @param[in] geometry -!> @param[in] topology !> @param[in] mesh_collection Optional: a collection of meshes, which contain !! metadata used to determine the rotation matrix !! and stretching factors. @@ -89,14 +90,13 @@ module sci_chi_transform_mod !! argument, and ideally should only be used for !! unit-testing. !------------------------------------------------------------------------------ -subroutine init_chi_transforms( geometry, & - topology, & - mesh_collection, & +subroutine init_chi_transforms( geometry, topology, & + mesh_collection, & north_pole_arg, equator_lat_arg ) - use local_mesh_mod, only: local_mesh_type - use mesh_collection_mod, only: mesh_collection_type - use mesh_mod, only: mesh_type + use local_mesh_mod, only : local_mesh_type + use mesh_collection_mod, only : mesh_collection_type + use mesh_mod, only : mesh_type implicit none @@ -118,6 +118,7 @@ subroutine init_chi_transforms( geometry, & ! -------------------------------------------------------------------------- ! ! Extract stretching and rotation information from mesh ! -------------------------------------------------------------------------- ! + ! Begin by assuming no stretching and no rotation to_stretch = .false. to_rotate = .false. @@ -186,7 +187,7 @@ subroutine init_chi_transforms( geometry, & LOG_LEVEL_WARNING & ) end if - end if ! present(mesh_collection) + end if if (present(north_pole_arg)) north_pole = north_pole_arg if (present(equator_lat_arg)) equatorial_latitude = equator_lat_arg @@ -246,19 +247,11 @@ end subroutine final_chi_transforms !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[in] scaled_radius -!! @param[in] panel_id The mesh panel ID !! @param[out] x The first coordinate field out (global Cartesian X) !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- -subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - x, y, z ) +subroutine chi2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) implicit none @@ -268,11 +261,6 @@ subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & real(kind=r_def) :: xyz(3) - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system - real(r_def), intent(in) :: scaled_radius - if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then ! chi already uses (geocentric) Cartesian coordinates x = chi_1 @@ -341,16 +329,11 @@ end subroutine chi2xyz !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system !! @param[out] x The first coordinate field out (global Cartesian X) !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- -subroutine chir2xyz( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, coord_system, & - x, y, z ) +subroutine chir2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) implicit none @@ -360,10 +343,6 @@ subroutine chir2xyz( chi_1, chi_2, chi_3, panel_id, & real(kind=r_def) :: xyz(3) - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system - if (coord_system == coord_system_xyz .or. geometry == geometry_planar) then ! chi already uses (geocentric) Cartesian coordinates x = chi_1 @@ -429,18 +408,11 @@ end subroutine chir2xyz !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[in] scaled_radius !! @param[out] longitude The first coordinate field out (longitude) !! @param[out] latitude The second coordinate field out (latitude) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - lon, lat, radius ) +subroutine chi2llr(chi_1, chi_2, chi_3, panel_id, lon, lat, radius) implicit none @@ -450,11 +422,6 @@ subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & real(kind=r_def) :: xyz(3) - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system - real(r_def), intent(in) :: scaled_radius - if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then ! chi uses (geocentric) Cartesian coordinates call xyz2llr(chi_1, chi_2, chi_3, lon, lat, radius) @@ -513,18 +480,11 @@ end subroutine chi2llr !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[in] scaled_radius !! @param[out] alpha The first coordinate field out (alpha) !! @param[out] beta The second coordinate field out (beta) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - alpha, beta, radius ) +subroutine chi2abr(chi_1, chi_2, chi_3, panel_id, alpha, beta, radius) implicit none @@ -534,15 +494,10 @@ subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & real(kind=r_def) :: xyz(3) - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system - real(r_def), intent(in) :: scaled_radius - if (topology /= topology_fully_periodic .or. geometry /= geometry_spherical) then - - call log_event( 'chi2abr can only be used on cubed-sphere meshes', & - LOG_LEVEL_ERROR ) + call log_event( & + 'chi2abr can only be used on cubed-sphere meshes', LOG_LEVEL_ERROR & + ) else if (coord_system == coord_system_native) then alpha = chi_1 @@ -576,7 +531,6 @@ end subroutine chi2abr !! native Cartesian coordinates to the physical Cartesian coordinates !------------------------------------------------------------------------------- function get_mesh_rotation_matrix() result(rot_mat) - implicit none real(kind=r_def) :: rot_mat(3,3) @@ -589,7 +543,6 @@ end function get_mesh_rotation_matrix !! physical Cartesian coordinates to native Cartesian coordinates !------------------------------------------------------------------------------- function get_inverse_mesh_rotation_matrix() result(rot_mat) - implicit none real(kind=r_def) :: rot_mat(3,3) @@ -601,7 +554,6 @@ end function get_inverse_mesh_rotation_matrix !> @brief Returns the Schmidt transform stretch factor !------------------------------------------------------------------------------- function get_stretch_factor() result(stretch_factor_out) - implicit none real(kind=r_def) :: stretch_factor_out @@ -613,7 +565,6 @@ end function get_stretch_factor !> @brief Returns whether coordinates are rotated !------------------------------------------------------------------------------- function get_to_rotate() result(to_rotate_out) - implicit none logical(kind=l_def) :: to_rotate_out @@ -625,7 +576,6 @@ end function get_to_rotate !> @brief Returns whether coordinates are stretched !------------------------------------------------------------------------------- function get_to_stretch() result(to_stretch_out) - implicit none logical(kind=l_def) :: to_stretch_out From a9ed9e17773abcc48d6add176312209b4f141d11 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 25 Mar 2026 14:39:15 +0000 Subject: [PATCH 13/44] update --- components/driver/source/driver_coordinates_mod.F90 | 6 +++--- components/driver/source/driver_fem_mod.f90 | 2 +- .../kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 | 2 +- .../geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 | 2 +- .../unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf | 6 +++--- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/components/driver/source/driver_coordinates_mod.F90 b/components/driver/source/driver_coordinates_mod.F90 index 52cec5fc0..bb6fc75ac 100644 --- a/components/driver/source/driver_coordinates_mod.F90 +++ b/components/driver/source/driver_coordinates_mod.F90 @@ -63,9 +63,9 @@ subroutine assign_coordinate_field(config, chi, panel_id, mesh) use reference_element_mod, only: reference_element_type use mesh_mod, only: mesh_type use local_mesh_mod, only: local_mesh_type - use sci_chi_transform_mod, only: get_inverse_mesh_rotation_matrix, & - get_to_rotate, & - get_stretch_factor + use new_sci_chi_transform_mod, only: get_inverse_mesh_rotation_matrix, & + get_to_rotate, & + get_stretch_factor implicit none diff --git a/components/driver/source/driver_fem_mod.f90 b/components/driver/source/driver_fem_mod.f90 index f61ba507a..3d5938023 100644 --- a/components/driver/source/driver_fem_mod.f90 +++ b/components/driver/source/driver_fem_mod.f90 @@ -12,7 +12,7 @@ !> * Initialises function space chains for use by the model. module driver_fem_mod - use sci_chi_transform_mod, only: init_chi_transforms, & + use new_sci_chi_transform_mod, only: init_chi_transforms, & final_chi_transforms use config_mod, only: config_type use constants_mod, only: i_def, l_def, str_def diff --git a/components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 b/components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 index 6337098b1..d14d1e09f 100644 --- a/components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 @@ -17,7 +17,7 @@ module new_sci_compute_latlon_kernel_mod CELL_COLUMN, GH_EVALUATOR use constants_mod, only: r_def, i_def use kernel_mod, only: kernel_type - use sci_chi_transform_mod, only: chi2llr + use new_sci_chi_transform_mod, only: chi2llr implicit none diff --git a/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 b/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 index 965ecacff..e98fee09e 100644 --- a/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 @@ -19,7 +19,7 @@ module sci_nodal_xyz_coordinates_kernel_mod GH_BASIS, CELL_COLUMN, & GH_EVALUATOR use constants_mod, only : r_def, i_def -use sci_chi_transform_mod, only : chi2xyz +use new_sci_chi_transform_mod, only : chi2xyz implicit none diff --git a/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf b/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf index 257ae2285..a408edcfa 100644 --- a/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf @@ -40,7 +40,7 @@ contains use base_mesh_config_mod, only : geometry_planar, & topology_fully_periodic - use sci_chi_transform_mod, only : init_chi_transforms + use new_sci_chi_transform_mod, only : init_chi_transforms use finite_element_config_mod, only : cellshape_quadrilateral, & coord_system_xyz use feign_config_mod, only : feign_finite_element_config, & @@ -88,8 +88,8 @@ contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine tearDown( this ) - use config_loader_mod, only: final_configuration - use sci_chi_transform_mod, only: final_chi_transforms + use config_loader_mod, only: final_configuration + use new_sci_chi_transform_mod, only: final_chi_transforms implicit none From d57f71a747bea65117c368a585cfac503d56952a Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 25 Mar 2026 16:42:34 +0000 Subject: [PATCH 14/44] test for new files --- .../geometry/new_chi_transform_mod_test.pf | 352 ++++++++++++++++++ .../new_compute_latlon_kernel_mod_test.pf | 139 +++++++ 2 files changed, 491 insertions(+) create mode 100644 components/science/unit-test/kernel/geometry/new_chi_transform_mod_test.pf create mode 100644 components/science/unit-test/kernel/geometry/new_compute_latlon_kernel_mod_test.pf diff --git a/components/science/unit-test/kernel/geometry/new_chi_transform_mod_test.pf b/components/science/unit-test/kernel/geometry/new_chi_transform_mod_test.pf new file mode 100644 index 000000000..88b6e6803 --- /dev/null +++ b/components/science/unit-test/kernel/geometry/new_chi_transform_mod_test.pf @@ -0,0 +1,352 @@ +!------------------------------------------------------------------------------- +! (c) Crown copyright 2021 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 new_chi_transform_mod_test + + use, intrinsic :: iso_fortran_env, only : real64 + + use constants_mod, only : i_def, r_def, str_long, PI, rmdi + + use base_mesh_config_mod, only: geometry_spherical, & + geometry_planar, & + topology_fully_periodic, & + topology_non_periodic + + use finite_element_config_mod, only: coord_system_native, & + coord_system_xyz + + use funit + + implicit none + + public :: new_chi_transform_mod_test_type, test_all, get_chi_parameters, & + test_chi_constructor + + @testParameter + type, public, extends(AbstractTestParameter) :: chi_parameters_type + integer(i_def) :: source_coord_system + integer(i_def) :: target_coord_system + integer(i_def) :: panel_id + real(r_def) :: source_chi_1 + real(r_def) :: source_chi_2 + real(r_def) :: source_chi_3 + real(r_def) :: target_chi_1 + real(r_def) :: target_chi_2 + real(r_def) :: target_chi_3 + contains + procedure :: toString + end type chi_parameters_type + + @TestCase(testParameters={get_chi_parameters()}, constructor=test_chi_constructor) + type, extends(ParameterizedTestCase) :: new_chi_transform_mod_test_type + private + integer(i_def) :: source_coord_system + integer(i_def) :: target_coord_system + integer(i_def) :: panel_id + real(r_def) :: source_chi_1 + real(r_def) :: source_chi_2 + real(r_def) :: source_chi_3 + real(r_def) :: target_chi_1 + real(r_def) :: target_chi_2 + real(r_def) :: target_chi_3 + + integer(i_def) :: src_coord_system + integer(i_def) :: topology + integer(i_def) :: geometry + real(r_def) :: scaled_radius + + contains + procedure setUp + procedure tearDown + procedure test_all + end type new_chi_transform_mod_test_type + + ! Add my own parameters for the different coordinate system cases + integer(i_def), parameter :: ABH = 1 + integer(i_def), parameter :: LLH = 2 + integer(i_def), parameter :: XYZ = 3 + integer(i_def), parameter :: R2XYZ = 4 + integer(i_def), parameter :: LLH_rot = 5 + integer(i_def), parameter :: ABH_stretch_rot = 6 + + real(r_def), parameter :: planet_radius = 14.0_r_def + real(r_def), parameter :: scaling = 1.0_r_def + +contains + + function test_chi_constructor( test_parameter ) result ( new_test ) + + implicit none + + type(chi_parameters_type), intent(in) :: test_parameter + type(new_chi_transform_mod_test_type) :: new_test + + new_test%source_coord_system = test_parameter%source_coord_system + new_test%target_coord_system = test_parameter%target_coord_system + new_test%panel_id = test_parameter%panel_id + new_test%source_chi_1 = test_parameter%source_chi_1 + new_test%source_chi_2 = test_parameter%source_chi_2 + new_test%source_chi_3 = test_parameter%source_chi_3 + new_test%target_chi_1 = test_parameter%target_chi_1 + new_test%target_chi_2 = test_parameter%target_chi_2 + new_test%target_chi_3 = test_parameter%target_chi_3 + + end function test_chi_constructor + + function toString( this ) result( output_string ) + + implicit none + + class( chi_parameters_type ), intent( in ) :: this + character(:), allocatable :: output_string + + character(:), allocatable :: source_string, target_string + + select case ( this%source_coord_system ) + case ( XYZ ) + source_string = 'XYZ' + case ( LLH ) + source_string = 'LLH' + case ( ABH ) + source_string = 'ABH' + case ( LLH_rot ) + source_string = 'LLH rot' + case ( ABH_stretch_rot ) + source_string = 'ABH stretch+rot' + end select + + select case ( this%target_coord_system ) + case ( XYZ ) + target_string = 'XYZ' + case ( LLH ) + target_string = 'LLH' + case ( ABH ) + target_string = 'ABH' + case ( R2XYZ ) + target_string = 'R2XYZ' + end select + + output_string = trim( source_string // '2' // target_string ) + + end function toString + + function get_chi_parameters() result ( chi_parameters ) + + implicit none + + type(chi_parameters_type) :: chi_parameters(15) + + integer(i_def) :: panel_id, pid_rot + real(r_def) :: radius, height + real(r_def) :: alpha, beta + real(r_def) :: alpha_sr, beta_sr + real(r_def) :: X, Y, Z + real(r_def) :: lon, lat + real(r_def) :: lon_rot, lat_rot + real(r_def) :: varrho + + ! Consider a particular point on the sphere + ! Give the coordinates for this point in each coordinate system + ! Try to choose non-trivial analytic values + panel_id = 2 + height = 5.0_r_def + radius = planet_radius + height + + ! Start with special choices of alpha and beta + alpha = PI / 6.0_r_def + beta = - PI / 12.0_r_def + + ! varrho is sqrt(1 + tan(alpha)**2 + tan(beta)**2) + ! For our alpha and beta, tan(alpha) = sqrt(3)/3 and tan(beta) = 2 - sqrt(3) + varrho = sqrt(25.0_r_def / 3.0_r_def - 4.0_r_def * sqrt(3.0_r_def)) + + ! for panel 2, x=-r*tan(alpha)/varrho, y=r/varrho, z=r*tan(beta)/varrho + X = -19.0_r_def*sqrt(3.0_r_def) / 3.0_r_def / varrho + Y = 19.0_r_def / varrho + Z = -19.0_r_def*(2.0_r_def - sqrt(3.0_r_def)) / varrho + + ! for panel 2, lon=pi/2 + alpha, lat=atan(tan(beta)/sqrt(1+tan(alpha)**2))) + lon = 2.0_r_def * PI / 3.0_r_def + lat = -atan(sqrt(3.0_r_def) * (2.0_r_def - sqrt(3.0_r_def)) / 2.0_r_def) + + ! Rotated lon, lat coordinates -- computed offline + ! Rotate north pole to (90, 0) + lon_rot = -2.0053150793200873_r_def + lat_rot = 1.0039712567034795_r_def + + ! Stretched and rotated alpha, beta coordinates -- computed offline + ! Rotate north pole to (-90, 0) and stretch factor of 1/sqrt(3) + pid_rot = 6 + alpha_sr = 0.14467932028782213_r_def + beta_sr = 0.30419085098985305_r_def + + ! The arguments below are the parameters defined in chi_parameters_type + + chi_parameters = [ chi_parameters_type(ABH, ABH, panel_id, & + alpha, beta, height, & + alpha, beta, radius), & + chi_parameters_type(ABH, LLH, panel_id, & + alpha, beta, height, & + lon, lat, radius), & + chi_parameters_type(ABH, XYZ, panel_id, & + alpha, beta, height, & + X, Y, Z), & + chi_parameters_type(ABH_stretch_rot, LLH, pid_rot, & + alpha_sr, beta_sr, height, & + lon, lat, radius), & + chi_parameters_type(ABH_stretch_rot, XYZ, pid_rot, & + alpha_sr, beta_sr, height, & + X, Y, Z), & + chi_parameters_type(LLH, LLH, panel_id, & + lon, lat, height, & + lon, lat, radius), & + chi_parameters_type(LLH, XYZ, panel_id, & + lon, lat, height, & + X, Y, Z), & + chi_parameters_type(LLH_rot, LLH, panel_id, & + lon_rot, lat_rot, height, & + lon, lat, radius), & + chi_parameters_type(LLH_rot, XYZ, panel_id, & + lon_rot, lat_rot, height, & + X, Y, Z), & + chi_parameters_type(XYZ, ABH, panel_id, & + X, Y, Z, & + alpha, beta, radius), & + chi_parameters_type(XYZ, LLH, panel_id, & + X, Y, Z, & + lon, lat, radius), & + chi_parameters_type(XYZ, XYZ, panel_id, & + X, Y, Z, X, Y, Z), & + chi_parameters_type(ABH, R2XYZ, panel_id, & + alpha, beta, radius, & + X, Y, Z), & + chi_parameters_type(LLH, R2XYZ, panel_id, & + lon, lat, radius, & + X, Y, Z), & + chi_parameters_type(XYZ, R2XYZ, panel_id, & + X, Y, Z, X, Y, Z) ] + + end function get_chi_parameters + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine setUp( this ) + + use new_sci_chi_transform_mod, only: init_chi_transforms + + implicit none + + class(new_chi_transform_mod_test_type), intent(inout) :: this + + real(r_def) :: north_pole(2), equatorial_latitude + + select case ( this%source_coord_system ) + case ( XYZ ) + this%src_coord_system = coord_system_xyz + this%topology = topology_fully_periodic + + case ( LLH, LLH_rot ) + this%src_coord_system = coord_system_native + this%topology = topology_non_periodic + + case ( ABH, ABH_stretch_rot ) + this%src_coord_system = coord_system_native + this%topology = topology_fully_periodic + end select + + this%geometry = geometry_spherical + this%scaled_radius = planet_radius*scaling + + if ( this%source_coord_system == LLH_rot ) then + north_pole(1) = PI/2.0_r_def + north_pole(2) = 0.0_r_def + call init_chi_transforms(this%geometry, & + this%topology, & + north_pole_arg=north_pole) + else if ( this%source_coord_system == ABH_stretch_rot ) then + north_pole(1) = -PI/2.0_r_def + north_pole(2) = 0.0_r_def + equatorial_latitude = PI/6.0_r_def + call init_chi_transforms(this%geometry, & + this%topology, & + north_pole_arg=north_pole, & + equator_lat_arg=equatorial_latitude) + else + ! Non-rotated or stretched case + call init_chi_transforms(this%geometry, & + this%topology) + + end if + + end subroutine setUp + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine tearDown( this ) + + use new_sci_chi_transform_mod, only: final_chi_transforms + use config_loader_mod, only: final_configuration + + implicit none + + class(new_chi_transform_mod_test_type), intent(inout) :: this + + call final_configuration() + call final_chi_transforms() + + end subroutine tearDown + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @Test + subroutine test_all( this ) + + use new_sci_chi_transform_mod, only: chi2abr, chi2llr, chi2xyz, chir2xyz + + implicit none + + class(new_chi_transform_mod_test_type), intent(inout) :: this + + real(kind=r_def) :: tol, new_coord_1, new_coord_2, new_coord_3 + + select case ( this%target_coord_system ) + case ( ABH ) + call chi2abr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, this%scaled_radius, & + new_coord_1, new_coord_2, new_coord_3) + case ( LLH ) + call chi2llr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, this%scaled_radius, & + new_coord_1, new_coord_2, new_coord_3 ) + case ( XYZ ) + call chi2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, this%scaled_radius, & + new_coord_1, new_coord_2, new_coord_3 ) + case ( R2XYZ ) + call chir2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, & + new_coord_1, new_coord_2, new_coord_3 ) + end select + + ! Check if answers are correct + if ( r_def == real64 ) then + tol = 1e-12_r_def + @assertEqual( this%target_chi_1, new_coord_1, tol ) + @assertEqual( this%target_chi_2, new_coord_2, tol ) + @assertEqual( this%target_chi_3, new_coord_3, tol ) + else + tol = 10.0_r_def*spacing( new_coord_1 ) + @assertEqual( this%target_chi_1, new_coord_1, tol ) + tol = 10.0_r_def*spacing( new_coord_2 ) + @assertEqual( this%target_chi_2, new_coord_2, tol ) + tol = 10.0_r_def*spacing( new_coord_3 ) + @assertEqual( this%target_chi_3, new_coord_3, tol ) + end if + + end subroutine test_all + +end module new_chi_transform_mod_test diff --git a/components/science/unit-test/kernel/geometry/new_compute_latlon_kernel_mod_test.pf b/components/science/unit-test/kernel/geometry/new_compute_latlon_kernel_mod_test.pf new file mode 100644 index 000000000..c3b71d6f0 --- /dev/null +++ b/components/science/unit-test/kernel/geometry/new_compute_latlon_kernel_mod_test.pf @@ -0,0 +1,139 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright 2019 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 new_compute_latlon_kernel_mod_test + + use constants_mod, only : i_def, r_def, pi, imdi, rmdi + use get_unit_test_m3x3_dofmap_mod, & + only : get_w3_m3x3_dofmap, get_wchi_m3x3_dofmap + use get_unit_test_m3x3_q3x3x3_sizes_mod, & + only : get_w3_m3x3_q3x3x3_size, get_wchi_m3x3_q3x3x3_size + use get_unit_test_q3x3x3_basis_mod, & + only : get_wchi_q3x3x3_basis + + use funit + + use finite_element_config_mod, only: coord_system_xyz + + implicit none + + private + public :: set_up, tear_down, test_all + + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @before + subroutine set_up() + + use new_sci_chi_transform_mod, only: init_chi_transforms + + implicit none + + call init_chi_transforms(imdi, imdi) + + end subroutine set_up + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @after + subroutine tear_down() + + use new_sci_chi_transform_mod, only: final_chi_transforms + + implicit none + + call final_chi_transforms() + + end subroutine tear_down + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @Test + subroutine test_all() + + use new_sci_compute_latlon_kernel_mod, only: compute_latlon_code + + implicit none + + real(r_def), parameter :: tol = 1.0e-12_r_def + integer(i_def), parameter :: nlayers = 1 + integer(i_def) :: k, df_w3 + + integer(i_def) :: ndf_w3, undf_w3, ndf_chi, undf_chi + integer(i_def) :: unused + integer(i_def), allocatable :: map_w3(:,:), map_chi(:,:) + real(r_def), allocatable :: chi_1(:), chi_2(:), chi_3(:), panel_id(:) + real(r_def), allocatable :: basis_chi(:,:,:,:) + + real(r_def), allocatable :: latitude(:), longitude(:) + real(r_def), allocatable :: lat_answer(:), lon_answer(:) + + integer(i_def), parameter :: geometry = imdi + integer(i_def), parameter :: topology = imdi + integer(i_def), parameter :: coord_system = coord_system_xyz + real(r_def), parameter :: scaled_radius = rmdi + + call get_w3_m3x3_q3x3x3_size( ndf_w3, undf_w3, unused, & + unused, unused, unused, & + unused, nlayers=nlayers) + call get_w3_m3x3_dofmap( map_w3 ) + call get_wchi_m3x3_q3x3x3_size( ndf_chi, undf_chi, unused, & + unused, unused, unused, & + unused, nlayers=nlayers) + call get_wchi_m3x3_dofmap( map_chi ) + + call get_wchi_q3x3x3_basis( basis_chi ) + + ! Test latlon kernel + allocate( latitude(undf_w3) ) + allocate( longitude(undf_w3) ) + allocate( chi_1(undf_chi) ) + allocate( chi_2(undf_chi) ) + allocate( chi_3(undf_chi) ) + allocate( panel_id(undf_w3) ) + allocate( lat_answer(undf_w3) ) + allocate( lon_answer(undf_w3) ) + + chi_1(:) = 1.0_r_def + chi_2(:) = 2.0_r_def + chi_3(:) = 1.0_r_def + panel_id(:) = 1.0_r_def + + ! Call the kernel + call compute_latlon_code(nlayers, & + latitude, longitude, & + chi_1, chi_2, chi_3, & + panel_id, & + geometry, & + topology, & + coord_system, & + scaled_radius, & + ndf_w3, undf_w3, map_w3(:,1), & + ndf_chi, undf_chi, map_chi(:,1), & + basis_chi(:,:,1,:), & + ndf_w3, undf_w3, map_w3 & + ) + + !Test the answer + k = 0 + df_w3 = 1 + lon_answer(map_w3(df_w3,1) + k) = 1.1071487177940904_r_def ! + lat_answer(map_w3(df_w3,1) + k) = 0.42053433528396511_r_def ! + @assertEqual(lat_answer(map_w3(df_w3,1) + k), latitude(map_w3(df_w3,1) + k), tol) + @assertEqual(lon_answer(map_w3(df_w3,1) + k), longitude(map_w3(df_w3,1) + k), tol) + + deallocate( latitude ) + deallocate( longitude ) + deallocate( chi_1 ) + deallocate( chi_2 ) + deallocate( chi_3 ) + deallocate( panel_id ) + deallocate( lat_answer ) + deallocate( lon_answer ) + + end subroutine test_all + +end module new_compute_latlon_kernel_mod_test From 827e6e135a1bceb321ef045693afbec2b23a54bb Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 25 Mar 2026 20:09:10 +0000 Subject: [PATCH 15/44] new files --- ...w_sci_w3_to_w2_displacement_kernel_mod.F90 | 231 ++++++++++++++++++ ...w_w3_to_w2_displacement_kernel_mod_test.pf | 175 +++++++++++++ 2 files changed, 406 insertions(+) create mode 100644 components/science/source/kernel/inter_function_space/new_sci_w3_to_w2_displacement_kernel_mod.F90 create mode 100644 components/science/unit-test/kernel/inter_function_space/new_w3_to_w2_displacement_kernel_mod_test.pf diff --git a/components/science/source/kernel/inter_function_space/new_sci_w3_to_w2_displacement_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/new_sci_w3_to_w2_displacement_kernel_mod.F90 new file mode 100644 index 000000000..3f07d9f84 --- /dev/null +++ b/components/science/source/kernel/inter_function_space/new_sci_w3_to_w2_displacement_kernel_mod.F90 @@ -0,0 +1,231 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright 2024 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 Calculates the effective horizontal displacement corresponding to the +!! error when averaging a W3 to W2 points. +!> @details Uses the coordinate fields to compute the displacement between a +!! W2 point and the effective averaging point when averaging a scalar +!! field from W3 to W2. Only intended to be used on the cubed-sphere. +!! This kernel is only designed for lowest order finite elements. +module new_sci_w3_to_w2_displacement_kernel_mod + + use argument_mod, only : arg_type, func_type, & + GH_FIELD, GH_SCALAR, & + GH_REAL, GH_INTEGER, & + GH_READ, GH_INC, & + ANY_DISCONTINUOUS_SPACE_3, & + GH_BASIS, GH_EVALUATOR, & + CELL_COLUMN, GH_SCALAR, & + GH_LOGICAL + use fs_continuity_mod, only : W3, W2H, Wchi + use constants_mod, only : r_def, i_def + use kernel_mod, only : kernel_type + use reference_element_mod, only : E, W, N, S + + implicit none + + private + + !------------------------------------------------------------------------------- + ! Public types + !------------------------------------------------------------------------------- + !> The type declaration for the kernel. Contains the metadata needed by the PSy layer + type, public, extends(kernel_type) :: w3_to_w2_displacement_kernel_type + private + type(arg_type) :: meta_args(8) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_INC, W2H), & + arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & + arg_type(GH_FIELD, GH_REAL, GH_READ, W3), & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius + /) + type(func_type) :: meta_funcs(1) = (/ & + func_type(Wchi, GH_BASIS) & + /) + integer :: operates_on = CELL_COLUMN + integer :: gh_shape = GH_EVALUATOR + integer :: gh_evaluator_targets(2) = (/ W2H, W3 /) + contains + procedure, nopass :: w3_to_w2_displacement_code + end type + + !------------------------------------------------------------------------------- + ! Contained functions/subroutines + !------------------------------------------------------------------------------- + public :: w3_to_w2_displacement_code + + contains + + !> @brief Calculates the effective horizontal displacement corresponding to + !! the error when averaging a W3 to W2 points + !> @param[in] nlayers Number of layers + !> @param[in,out] displacement 2D W2H field containing the displacements + !! corresponding to the averaging error. This is + !! dimensionless, being divided by the cell width + !> @param[in] chi_1 The first coordinate field + !> @param[in] chi_2 The second coordinate field + !> @param[in] chi_3 The third coordinate field + !> @param[in] panel_id ID for panels of the underlying mesh + !> @param[in] dummy_w3 An unused dummy field in W3 + !> @param[in] geometry + !> @param[in] topology + !> @param[in] coord_system + !> @param[in] scaled_radius + !> @param[in] ndf_w2h Number of DoFs for W2H per cell + !> @param[in] undf_w2h Number of unique DoFs for W2H per partition + !> @param[in] map_w2h The DoF map for bottom layer cells for W2H + !> @param[in] ndf_chi Number of DoFs for Wchi per cell + !> @param[in] undf_chi Number of unique DoFs for Wchi per partition + !> @param[in] map_chi The DoF map for bottom layer cells for Wchi + !> @param[in] basis_chi_w2h Wchi basis functions evaluated at W2H points + !> @param[in] basis_chi_w3 Wchi basis functions evaluated at W3 points + !> @param[in] ndf_pid Number of DoFs for panel id per cell + !> @param[in] undf_pid Number of unique DoFs for panel id per partition + !> @param[in] map_pid The DoF map for bottom layer cells for panel ID + !> @param[in] ndf_w3 Number of DoFs for W3 per cell + !> @param[in] undf_w3 Number of unique DoFs for W3 per partition + !> @param[in] map_w3 The DoF map for bottom layer cells for W3 + subroutine w3_to_w2_displacement_code( nlayers, & + displacement, & + chi_1, & + chi_2, & + chi_3, & + panel_id, & + dummy_w3, & + geometry, & + topology, & + coord_system, & + scaled_radius, & + ndf_w2h, & + undf_w2h, & + map_w2h, & + ndf_chi, & + undf_chi, & + map_chi, & + basis_chi_w2h, & + basis_chi_w3, & + ndf_pid, & + undf_pid, & + map_pid, & + ndf_w3, & + undf_w3, & + map_w3 ) + + use new_sci_chi_transform_mod, only: chi2abr + + implicit none + + ! Arguments + integer(kind=i_def), intent(in) :: nlayers + integer(kind=i_def), intent(in) :: ndf_w2h, undf_w2h + integer(kind=i_def), intent(in) :: ndf_chi, undf_chi + integer(kind=i_def), intent(in) :: ndf_pid, undf_pid + integer(kind=i_def), intent(in) :: ndf_w3, undf_w3 + integer(kind=i_def), intent(in) :: map_w2h(ndf_w2h) + integer(kind=i_def), intent(in) :: map_chi(ndf_chi) + integer(kind=i_def), intent(in) :: map_pid(ndf_pid) + integer(kind=i_def), intent(in) :: map_w3(ndf_w3) + + real(kind=r_def), intent(inout) :: displacement(undf_w2h) + real(kind=r_def), intent(in) :: chi_1(undf_chi) + real(kind=r_def), intent(in) :: chi_2(undf_chi) + real(kind=r_def), intent(in) :: chi_3(undf_chi) + real(kind=r_def), intent(in) :: panel_id(undf_pid) + real(kind=r_def), intent(in) :: dummy_w3(undf_w3) + real(kind=r_def), intent(in) :: basis_chi_w2h(1,ndf_chi,ndf_w2h) + real(kind=r_def), intent(in) :: basis_chi_w3(1,ndf_chi,ndf_w3) + + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + integer(kind=i_def), intent(in) :: coord_system + real(kind=r_def), intent(in) :: scaled_radius + + ! Vertical cell index + integer(kind=i_def) :: df_w2h, df_w3, df_chi + integer(kind=i_def) :: ipanel + real(kind=r_def) :: cell_width_opposite, cell_half_width_adjacent + real(kind=r_def) :: alpha_w3, beta_w3, dummy_r + real(kind=r_def) :: alpha_w2h(4), beta_w2h(4) + real(kind=r_def) :: chi1_at_dof, chi2_at_dof, chi3_at_dof + real(kind=r_def) :: e_alpha(3), e_beta(3) + real(kind=r_def) :: phi, varrho + + ipanel = int(panel_id(map_pid(1)), i_def) + + ! The output field is 2D so we can ignore layers + + ! Get alpha and beta values at each DoF + ! W3 points ---------------------------------------------------------------- + chi1_at_dof = 0.0_r_def + chi2_at_dof = 0.0_r_def + chi3_at_dof = 0.0_r_def + ! Get chi at this point and then transform to alpha/beta coords + df_w3 = 1 + do df_chi = 1, ndf_chi + chi1_at_dof = chi1_at_dof + & + basis_chi_w3(1,df_chi,df_w3) * chi_1(map_chi(df_chi)) + chi2_at_dof = chi2_at_dof + & + basis_chi_w3(1,df_chi,df_w3) * chi_2(map_chi(df_chi)) + chi3_at_dof = chi3_at_dof + & + basis_chi_w3(1,df_chi,df_w3) * chi_3(map_chi(df_chi)) + end do + call chi2abr(chi1_at_dof, chi2_at_dof, chi3_at_dof, ipanel, & + geometry, topology, coord_system, scaled_radius, & + alpha_w3, beta_w3, dummy_r) + + ! W2H points --------------------------------------------------------------- + do df_w2h = 1, 4 + chi1_at_dof = 0.0_r_def + chi2_at_dof = 0.0_r_def + chi3_at_dof = 0.0_r_def + ! Get chi at this point and then transform to alpha/beta coords + df_w3 = 1 + do df_chi = 1, ndf_chi + chi1_at_dof = chi1_at_dof + & + basis_chi_w2h(1,df_chi,df_w2h) * chi_1(map_chi(df_chi)) + chi2_at_dof = chi2_at_dof + & + basis_chi_w2h(1,df_chi,df_w2h) * chi_2(map_chi(df_chi)) + chi3_at_dof = chi3_at_dof + & + basis_chi_w2h(1,df_chi,df_w2h) * chi_3(map_chi(df_chi)) + end do + call chi2abr(chi1_at_dof, chi2_at_dof, chi3_at_dof, ipanel, & + geometry, topology, coord_system, scaled_radius, & + alpha_w2h(df_w2h), beta_w2h(df_w2h), dummy_r) + + end do + + ! Compute angle between basis functions ------------------------------------ + varrho = sqrt(1.0_r_def + (tan(alpha_w3))**2.0_r_def + (tan(beta_w3))**2.0_r_def) + e_alpha(1) = -tan(alpha_w3)*cos(beta_w3)/varrho + e_alpha(2) = 1.0_r_def/cos(beta_w3)/varrho + e_alpha(3) = -tan(alpha_w3)*sin(beta_w3)/varrho + e_beta(1) = -tan(beta_w3)*cos(alpha_w3)/varrho + e_beta(2) = -tan(beta_w3)*sin(alpha_w3)/varrho + e_beta(3) = 1.0_r_def/cos(alpha_w3)/varrho + phi = asin(dot_product(e_alpha, e_beta)) + + ! Compute contribution to displacement for each face ----------------------- + do df_w2h = 1, 4 + ! Take alpha / beta depending on the face + if (df_w2h == N .or. df_w2h == S) then + cell_half_width_adjacent = beta_w3 - beta_w2h(df_w2h) + cell_width_opposite = alpha_w2h(E) - alpha_w2h(W) + else + cell_half_width_adjacent = alpha_w3 - alpha_w2h(df_w2h) + cell_width_opposite = beta_w2h(N) - beta_w2h(S) + end if + + ! Half-factor for each side of the face -- could be rmultiplicity but + ! as this is on the cubed-sphere we can just take it to be 0.5 + displacement(map_w2h(df_w2h)) = displacement(map_w2h(df_w2h)) + & + 0.5_r_def * cell_half_width_adjacent * sin(phi) / cell_width_opposite + end do + + end subroutine w3_to_w2_displacement_code + +end module new_sci_w3_to_w2_displacement_kernel_mod diff --git a/components/science/unit-test/kernel/inter_function_space/new_w3_to_w2_displacement_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/new_w3_to_w2_displacement_kernel_mod_test.pf new file mode 100644 index 000000000..18dea4c81 --- /dev/null +++ b/components/science/unit-test/kernel/inter_function_space/new_w3_to_w2_displacement_kernel_mod_test.pf @@ -0,0 +1,175 @@ +!----------------------------------------------------------------------------- +! (c) Crown copyright 2024 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 kernel to compute errors in W3 to W2 averaging +module new_w3_to_w2_displacement_kernel_mod_test + + use constants_mod, only: i_def, r_def, PI, l_def + use reference_element_mod, only: S, E, N, W + + use base_mesh_config_mod, only: geometry_spherical, & + topology_fully_periodic + use finite_element_config_mod, only: coord_system_native + + use funit + + + implicit none + + private + public :: set_up, tear_down, test_all + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @before + subroutine set_up() + + use sci_chi_transform_mod, only: init_chi_transforms + + implicit none + + call init_chi_transforms(geometry_spherical, topology_fully_periodic) + + end subroutine set_up + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @after + subroutine tear_down() + + use sci_chi_transform_mod, only: final_chi_transforms + + implicit none + + call final_chi_transforms() + + end subroutine tear_down + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + @test + subroutine test_all() + + use new_sci_w3_to_w2_displacement_kernel_mod, only: w3_to_w2_displacement_code + use get_unit_test_w2hnodal_basis_mod, only: get_wchi_w2hnodal_basis + use get_unit_test_w3nodal_basis_mod, only: get_wchi_w3nodal_basis + + implicit none + + real(r_def), parameter :: tol = 1.0e-2_r_def + real(r_def), parameter :: dalpha = 0.05_r_def + real(r_def), parameter :: dbeta = 0.05_r_def + real(r_def), parameter :: alpha0 = -PI/4.0_r_def + real(r_def), parameter :: beta0 = PI/6.0_r_def + real(r_def), parameter :: dz = 2.0_r_def + + integer(i_def), parameter :: geometry = geometry_spherical + integer(i_def), parameter :: topology = topology_fully_periodic + integer(i_def), parameter :: coord_system = coord_system_native + real(r_def), parameter :: scaled_radius = 1900000.0_r_def + + ! Non-periodic 3x3x3 domain + integer(i_def), parameter :: ncells = 2 + integer(i_def), parameter :: nlayers = 1 + integer(i_def), parameter :: ndf_w2h = 4 + integer(i_def), parameter :: undf_w2h = 7 + integer(i_def), parameter :: ndf_chi = 8 + integer(i_def), parameter :: undf_chi = ndf_chi*nlayers*ncells + integer(i_def), parameter :: ndf_w3 = 1 + integer(i_def), parameter :: undf_w3 = ncells*nlayers + integer(i_def) :: map_w2h(ndf_w2h,ncells) + integer(i_def) :: map_w3(ndf_w3,ncells) + integer(i_def) :: map_chi(ndf_chi,ncells) + real(r_def), allocatable :: basis_chi_w3(:,:,:) + real(r_def), allocatable :: basis_chi_w2h(:,:,:) + + ! Fields + real(r_def) :: displacement(undf_w2h) + real(r_def) :: chi_1(undf_chi) + real(r_def) :: chi_2(undf_chi) + real(r_def) :: chi_3(undf_chi) + real(r_def) :: panel_id(undf_w3) + real(r_def) :: dummy_w3(undf_w3) + real(r_def) :: answer, phi + + integer(i_def) :: cell + + ! ------------------------------------------------------------------------ ! + ! Make DoF maps + ! ------------------------------------------------------------------------ ! + ! Two cells + map_w3 = reshape([1 , 2], [ndf_w3, ncells]) + map_w2h = reshape([1, 2, 3, 4, 5, 1, 6, 7], [ndf_w2h, ncells]) + map_chi = reshape([1, 2, 3, 4, 5, 6, 7, 8, & + 9, 10, 11, 12, 13, 14, 15, 16], [ndf_chi, ncells]) + + ! ------------------------------------------------------------------------ ! + ! Get basis functions + ! ------------------------------------------------------------------------ ! + + call get_wchi_w3nodal_basis(basis_chi_w3) + call get_wchi_w2hnodal_basis(basis_chi_w2h) + + ! ------------------------------------------------------------------------ ! + ! Set up initial chi field + ! ------------------------------------------------------------------------ ! + + chi_1 = (/ alpha0, alpha0 + dalpha, alpha0, alpha0 + dalpha, & + alpha0, alpha0 + dalpha, alpha0, alpha0 + dalpha, & + beta0, beta0 + dbeta, beta0, beta0 + dbeta, & + beta0, beta0 + dbeta, beta0, beta0 + dbeta /) + chi_2 = (/ beta0, beta0, beta0 + dbeta, beta0 + dbeta, & + beta0, beta0, beta0 + dbeta, beta0 + dbeta, & + alpha0, alpha0, alpha0 + dalpha, alpha0 + dalpha, & + alpha0, alpha0, alpha0 + dalpha, alpha0 + dalpha /) + chi_3 = (/ 0.0_r_def, 0.0_r_def, 0.0_r_def, 0.0_r_def, dz, dz, dz, dz, & + 0.0_r_def, 0.0_r_def, 0.0_r_def, 0.0_r_def, dz, dz, dz, dz /) + panel_id(1) = 1.0_r_def + panel_id(2) = 4.0_r_def + + ! ------------------------------------------------------------------------ ! + ! Set up answer + ! ------------------------------------------------------------------------ ! + + ! Approximate angle between alpha and beta coordinates at (alpha0=-pi/4, beta0=pi/6) + phi = 0.361367_r_def + answer = 0.5_r_def*dalpha/dbeta*sin(phi) + + ! ------------------------------------------------------------------------ ! + ! Run + ! ------------------------------------------------------------------------ ! + + ! Initialise data + displacement(:) = 0.0_r_def + + do cell = 1, ncells + + call w3_to_w2_displacement_code( nlayers, & + displacement, & + chi_1, chi_2, chi_3, & + panel_id, & + dummy_w3, & + geometry, topology, & + coord_system, scaled_radius, & + ndf_w2h, undf_w2h, map_w2h(:,cell), & + ndf_chi, undf_chi, map_chi(:,cell), & + basis_chi_w2h, basis_chi_w3, & + ndf_w3, undf_w3, map_w3(:,cell), & + ndf_w3, undf_w3, map_w3(:,cell) ) + end do + + ! ------------------------------------------------------------------------ ! + ! Check + ! ------------------------------------------------------------------------ ! + + ! Only check the first DoF as this is the only shared value between panels + @assertEqual(answer, displacement(1), tol) + + deallocate(basis_chi_w3) + deallocate(basis_chi_w2h) + + end subroutine test_all + +end module new_w3_to_w2_displacement_kernel_mod_test From 3951a00d7b02c8c63743178f74a34ab1cf63934d Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Thu, 26 Mar 2026 09:20:52 +0000 Subject: [PATCH 16/44] update --- .../kernel/geometry/chi_transform_mod_test.pf | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf b/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf index e8e50e1ea..56c18b054 100644 --- a/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf @@ -302,7 +302,7 @@ contains @Test subroutine test_all( this ) - use sci_chi_transform_mod, only : chi2abr, chi2llr, chi2xyz, chir2xyz + use sci_chi_transform_mod, only : chi2abr, chi2llr, chi2xyz, chir2xyz implicit none @@ -313,24 +313,16 @@ contains select case ( this%target_coord_system ) case ( ABH ) call chi2abr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, this%geometry, this%topology, & - this%src_coord_system, this%scaled_radius, & - new_coord_1, new_coord_2, new_coord_3) + this%panel_id, new_coord_1, new_coord_2, new_coord_3) case ( LLH ) call chi2llr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, this%geometry, this%topology, & - this%src_coord_system, this%scaled_radius, & - new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, new_coord_1, new_coord_2, new_coord_3 ) case ( XYZ ) call chi2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, this%geometry, this%topology, & - this%src_coord_system, this%scaled_radius, & - new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, new_coord_1, new_coord_2, new_coord_3 ) case ( R2XYZ ) call chir2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, this%geometry, this%topology, & - this%src_coord_system, & - new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, new_coord_1, new_coord_2, new_coord_3 ) end select ! Check if answers are correct From 7dd12a7b6844323fec60f4aaaede17f1076f9f4d Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Thu, 26 Mar 2026 13:09:29 +0000 Subject: [PATCH 17/44] Getting it back to before --- Makefile | 1 + .../source/driver/init_coupled_mod.X90 | 2 +- .../driver/source/driver_coordinates_mod.F90 | 6 +- components/driver/source/driver_fem_mod.f90 | 4 +- .../new_sci_geometric_constants_mod.x90 | 1647 ----------------- .../algorithm/sci_geometric_constants_mod.x90 | 328 ++-- .../algorithm/sci_mapping_constants_mod.x90 | 2 +- .../geometry/new_sci_chi_transform_mod.F90 | 637 ------- .../new_sci_compute_latlon_kernel_mod.F90 | 142 -- .../kernel/geometry/sci_chi_transform_mod.F90 | 96 +- .../sci_compute_latlon_kernel_mod.F90 | 34 +- .../sci_nodal_xyz_coordinates_kernel_mod.F90 | 2 +- ...w_sci_w3_to_w2_displacement_kernel_mod.F90 | 231 --- .../fem/gp_vector_rhs_kernel_mod_test.pf | 16 +- .../kernel/geometry/chi_transform_mod_test.pf | 27 +- .../geometry/new_chi_transform_mod_test.pf | 352 ---- .../new_compute_latlon_kernel_mod_test.pf | 139 -- ...w_w3_to_w2_displacement_kernel_mod_test.pf | 175 -- 18 files changed, 356 insertions(+), 3485 deletions(-) delete mode 100644 components/science/source/algorithm/new_sci_geometric_constants_mod.x90 delete mode 100644 components/science/source/kernel/geometry/new_sci_chi_transform_mod.F90 delete mode 100644 components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 delete mode 100644 components/science/source/kernel/inter_function_space/new_sci_w3_to_w2_displacement_kernel_mod.F90 delete mode 100644 components/science/unit-test/kernel/geometry/new_chi_transform_mod_test.pf delete mode 100644 components/science/unit-test/kernel/geometry/new_compute_latlon_kernel_mod_test.pf delete mode 100644 components/science/unit-test/kernel/inter_function_space/new_w3_to_w2_displacement_kernel_mod_test.pf diff --git a/Makefile b/Makefile index a5d1adb5f..101501fd0 100644 --- a/Makefile +++ b/Makefile @@ -22,6 +22,7 @@ OPERATE_ON ?= infrastructure \ mesh_tools \ applications/skeleton \ applications/simple_diffusion \ + applications/coupled \ applications/lbc_demo \ applications/io_demo diff --git a/applications/coupled/source/driver/init_coupled_mod.X90 b/applications/coupled/source/driver/init_coupled_mod.X90 index 4955fe372..8715a45a2 100644 --- a/applications/coupled/source/driver/init_coupled_mod.X90 +++ b/applications/coupled/source/driver/init_coupled_mod.X90 @@ -29,7 +29,7 @@ module init_coupled_mod LOG_LEVEL_ERROR use mesh_mod, only : mesh_type use pure_abstract_field_mod, only : pure_abstract_field_type - use new_sci_compute_latlon_kernel_mod, only : compute_latlon_kernel_type + use sci_compute_latlon_kernel_mod, only : compute_latlon_kernel_type implicit none diff --git a/components/driver/source/driver_coordinates_mod.F90 b/components/driver/source/driver_coordinates_mod.F90 index bb6fc75ac..52cec5fc0 100644 --- a/components/driver/source/driver_coordinates_mod.F90 +++ b/components/driver/source/driver_coordinates_mod.F90 @@ -63,9 +63,9 @@ subroutine assign_coordinate_field(config, chi, panel_id, mesh) use reference_element_mod, only: reference_element_type use mesh_mod, only: mesh_type use local_mesh_mod, only: local_mesh_type - use new_sci_chi_transform_mod, only: get_inverse_mesh_rotation_matrix, & - get_to_rotate, & - get_stretch_factor + use sci_chi_transform_mod, only: get_inverse_mesh_rotation_matrix, & + get_to_rotate, & + get_stretch_factor implicit none diff --git a/components/driver/source/driver_fem_mod.f90 b/components/driver/source/driver_fem_mod.f90 index 3d5938023..43de2fafa 100644 --- a/components/driver/source/driver_fem_mod.f90 +++ b/components/driver/source/driver_fem_mod.f90 @@ -12,8 +12,8 @@ !> * Initialises function space chains for use by the model. module driver_fem_mod - use new_sci_chi_transform_mod, only: init_chi_transforms, & - final_chi_transforms + use sci_chi_transform_mod, only: init_chi_transforms, & + final_chi_transforms use config_mod, only: config_type use constants_mod, only: i_def, l_def, str_def use extrusion_mod, only: TWOD, PRIME_EXTRUSION diff --git a/components/science/source/algorithm/new_sci_geometric_constants_mod.x90 b/components/science/source/algorithm/new_sci_geometric_constants_mod.x90 deleted file mode 100644 index 71d4b265c..000000000 --- a/components/science/source/algorithm/new_sci_geometric_constants_mod.x90 +++ /dev/null @@ -1,1647 +0,0 @@ -!----------------------------------------------------------------------------- -! (C) Crown copyright 2021 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 Pre-computes and stores various geometric objects. -!> -!> @details This module controls the set up of various objects relating to -!> the geometry of the mesh that do not change during a run. These -!> objects are accessed from this module through appropriate 'get' -!> functions. -!------------------------------------------------------------------------------- - -module new_sci_geometric_constants_mod - - ! Infrastructure - use config_mod, only: config_type - use constants_mod, only: i_def, r_def, l_def, str_def - use extrusion_mod, only: TWOD, PRIME_EXTRUSION - use field_mod, only: field_type - use fs_continuity_mod, only: W0, W1, W2, W2H, W3, Wtheta - use function_space_collection_mod, only: function_space_collection - use function_space_mod, only: function_space_type - use integer_field_mod, only: integer_field_type - use inventory_by_mesh_mod, only: inventory_by_mesh_type - use inventory_by_local_mesh_mod, only: inventory_by_local_mesh_type - use local_mesh_mod, only: local_mesh_type - use log_mod, only: log_event, LOG_LEVEL_ERROR - use mesh_collection_mod, only: mesh_collection - use mesh_mod, only: mesh_type - use timing_mod, only: start_timing, stop_timing, & - tik, LPROF - - ! Configuration - use base_mesh_config_mod, only: geometry_spherical - use finite_element_config_mod, only: coord_system_native - - implicit none - - private - - ! Variables private to this module that can only be accessed by public - ! functions returning pointers to them - - ! ========================================================================== ! - ! Inventories for use in the rest of the model - ! ========================================================================== ! - ! Finite element representations of coordinates - type(inventory_by_mesh_type), target :: chi_inventory - type(inventory_by_mesh_type), target :: panel_id_inventory - type(inventory_by_mesh_type) :: extended_chi_inventory - - ! Basic geometric entities - type(inventory_by_mesh_type) :: dA_at_w2_inventory - type(inventory_by_mesh_type) :: dz_w3_inventory - type(inventory_by_mesh_type) :: detj_at_w3_inventory_fe - type(inventory_by_mesh_type) :: detj_at_w3_inventory_fv - type(inventory_by_mesh_type) :: detj_at_w2_inventory_fe - type(inventory_by_mesh_type) :: detj_at_w2_inventory_fv - type(inventory_by_mesh_type) :: delta_at_wtheta_inventory - type(inventory_by_mesh_type) :: dx_at_w2_inventory - type(inventory_by_mesh_type) :: dz_at_wtheta_inventory - type(inventory_by_local_mesh_type) :: dA_msl_proj_inventory - - ! 2D Longitude/latitude fields - type(inventory_by_local_mesh_type), target :: lat_w3_inventory_fe - type(inventory_by_local_mesh_type), target :: lat_w3_inventory_fv - type(inventory_by_local_mesh_type), target :: lat_w2_inventory_fe - type(inventory_by_local_mesh_type), target :: lat_w2_inventory_fv - type(inventory_by_local_mesh_type), target :: lat_w2h_inventory_fe - type(inventory_by_local_mesh_type), target :: lat_w2h_inventory_fv - type(inventory_by_local_mesh_type), target :: long_w3_inventory_fe - type(inventory_by_local_mesh_type), target :: long_w3_inventory_fv - type(inventory_by_local_mesh_type), target :: long_w2_inventory_fe - type(inventory_by_local_mesh_type), target :: long_w2_inventory_fv - type(inventory_by_local_mesh_type), target :: long_w2h_inventory_fe - type(inventory_by_local_mesh_type), target :: long_w2h_inventory_fv - - ! Heights of DoFs - type(inventory_by_mesh_type), target :: height_w0_inventory_fe - type(inventory_by_mesh_type), target :: height_w0_inventory_fv - type(inventory_by_mesh_type), target :: height_w1_inventory_fe - type(inventory_by_mesh_type), target :: height_w1_inventory_fv - type(inventory_by_mesh_type), target :: height_w2_inventory_fe - type(inventory_by_mesh_type), target :: height_w2_inventory_fv - type(inventory_by_mesh_type), target :: height_w2h_inventory_fe - type(inventory_by_mesh_type), target :: height_w2h_inventory_fv - type(inventory_by_mesh_type), target :: height_w3_inventory_fe - type(inventory_by_mesh_type), target :: height_w3_inventory_fv - type(inventory_by_mesh_type), target :: height_wth_inventory_fe - type(inventory_by_mesh_type), target :: height_wth_inventory_fv - - ! Face selectors, used to avoid doubly-iterating over horizontal faces - type(inventory_by_local_mesh_type) :: face_selector_ew_inventory - type(inventory_by_local_mesh_type) :: face_selector_ns_inventory - - ! ========================================================================== ! - ! Public functions for accessing the module contents - ! ========================================================================== ! - - public :: final_geometric_constants - public :: get_panel_id - public :: get_coordinates - public :: get_dA_at_w2 - public :: get_detj_at_w3_fv - public :: get_detj_at_w2_fv - public :: get_delta_at_wtheta - public :: get_dx_at_w2 - public :: get_face_selector_ew - public :: get_face_selector_ns - public :: get_chi_inventory - public :: get_panel_id_inventory - - public :: get_extended_coordinates - public :: get_detj_at_w3_fe - public :: get_detj_at_w2_fe - public :: get_dz_w3 - public :: get_dz_at_wtheta - public :: get_dA_msl_proj - public :: get_height_fe - public :: get_height_fv - public :: get_latitude_fe - public :: get_latitude_fv - public :: get_longitude_fe - public :: get_longitude_fv - - ! Private routines for creating constants - private :: compute_latlon - private :: compute_face_selectors - -contains - - ! ========================================================================== ! - ! Private routines for creating some particular constants - ! ========================================================================== ! - - !> @brief Private routine for computing longitude and latitude fields - !> @param[in] config Configuration object - !> @param[in,out] long_inventory Inventory containing longitude fields - !> @param[in,out] lat_inventory Inventory containing latitude fields - !> @param[in] mesh Mesh used to determine local mesh for - !! computing the fields for - !> @param[in] fs_id Identifier for function space to compute - !! longitude and latitude fields for - !> @param[in] use_fe Flag to indicate whether to use finite - !! element or finite volume cells - subroutine compute_latlon(config, long_inventory, lat_inventory, & - mesh, fs_id, use_fe) - - use new_sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type - - implicit none - - type(config_type), intent(in) :: config - - type(inventory_by_local_mesh_type), intent(inout) :: long_inventory - type(inventory_by_local_mesh_type), intent(inout) :: lat_inventory - type(mesh_type), intent(in) :: mesh - integer(kind=i_def), intent(in) :: fs_id - logical(kind=l_def), intent(in) :: use_fe - - ! Internal variables - type(mesh_type), pointer :: twod_mesh - type(local_mesh_type), pointer :: local_mesh - type(field_type), pointer :: lat - type(field_type), pointer :: long - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(function_space_type), pointer :: twod_fs - integer(kind=i_def) :: k_h, k_v - integer(tik) :: id - - integer(i_def) :: geometry, topology - integer(i_def) :: order_h, order_v - integer(i_def) :: coord_system - real(r_def) :: f_lat, f_lon - real(r_def) :: scaled_radius - - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() - - f_lat = config%base_mesh%f_lat() - f_lon = config%idealised%f_lon() - - if (use_fe) then - k_h = order_h - k_v = order_v - else - k_h = 0 - k_v = 0 - end if - - twod_mesh => mesh_collection%get_mesh(mesh, TWOD) - local_mesh => mesh%get_local_mesh() - twod_fs => function_space_collection%get_fs(twod_mesh, k_h, k_v, fs_id) - call lat_inventory%add_field(lat, twod_fs, local_mesh) - call long_inventory%add_field(long, twod_fs, local_mesh) - - if ( geometry == geometry_spherical ) then - chi => get_coordinates(mesh%get_id()) - panel_id => get_panel_id(mesh%get_id()) - call invoke( compute_latlon_kernel_type(lat, long, chi, panel_id, & - geometry, topology, & - coord_system, scaled_radius) ) - else - call invoke( setval_c(lat, f_lat), & - setval_c(long, f_lon) ) - end if - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - - end subroutine compute_latlon - - - !> @brief Private routine for computing face selectors fields - !> @param[in,out] ew_inventory Inventory containing East-West selectors - !> @param[in,out] ns_inventory Inventory containing North-South selectors - !> @param[in] mesh Mesh used to determine local mesh for - !! computing the fields for - subroutine compute_face_selectors(mesh) - - use reference_element_mod, only: S, W - use sci_set_any_int_dof_kernel_mod, only: set_any_int_dof_kernel_type - use sci_face_selector_kernel_mod, only: face_selector_kernel_type - - implicit none - - type(mesh_type), intent(in) :: mesh - - ! Internal variables - type(mesh_type), pointer :: twod_mesh - type(local_mesh_type), pointer :: local_mesh - type(integer_field_type), pointer :: face_selector_ew - type(integer_field_type), pointer :: face_selector_ns - type(integer_field_type) :: face_counter - type(function_space_type), pointer :: w2h_2d_fs - type(function_space_type), pointer :: w3_2d_fs - integer(tik) :: id - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - twod_mesh => mesh_collection%get_mesh(mesh, TWOD) - local_mesh => mesh%get_local_mesh() - w2h_2d_fs => function_space_collection%get_fs(twod_mesh, 0, 0, W2H) - w3_2d_fs => function_space_collection%get_fs(twod_mesh, 0, 0, W3) - - ! Temporary W2H field, tracking the count for each face - call face_counter%initialise( w2h_2d_fs ) - - call face_selector_ew_inventory%add_field( & - face_selector_ew, w3_2d_fs, local_mesh & - ) - call face_selector_ns_inventory%add_field( & - face_selector_ns, w3_2d_fs, local_mesh & - ) - - call invoke( int_setval_c(face_counter, 0), & - ! Do West and South faces for every cell - int_setval_c(face_selector_ew, 1), & - int_setval_c(face_selector_ns, 1), & - set_any_int_dof_kernel_type(face_counter, W, 1), & - set_any_int_dof_kernel_type(face_counter, S, 1), & - ! Determine where North and East faces are needed - face_selector_kernel_type(face_selector_ew, & - face_selector_ns, & - face_counter ) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - - end subroutine compute_face_selectors - - ! ========================================================================== ! - ! GETTERS FOR FINITE ELEMENT COORDINATE FIELDS - ! ========================================================================== ! - !> @brief Function to return a pointer to the panel_id - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The coordinate field array - function get_panel_id(mesh_id) result(panel_id_ptr) - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(mesh_type), pointer :: prime_extrusion_mesh - type(field_type), pointer :: panel_id_ptr - - mesh => mesh_collection%get_mesh(mesh_id) - if (mesh%get_extrusion_id() == TWOD) then - prime_extrusion_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) - call panel_id_inventory%get_field(prime_extrusion_mesh, panel_id_ptr) - else - call panel_id_inventory%get_field(mesh, panel_id_ptr) - end if - - end function get_panel_id - - !> @brief Returns a pointer to the coordinate field array - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The coordinate field array - function get_coordinates(mesh_id) result(coords_ptr) - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(mesh_type), pointer :: prime_extrusion_mesh - type(field_type), pointer :: coords_ptr(:) - - mesh => mesh_collection%get_mesh(mesh_id) - if (mesh%get_extrusion_id() == TWOD) then - prime_extrusion_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) - call chi_inventory%get_field_array(prime_extrusion_mesh, coords_ptr) - else - call chi_inventory%get_field_array(mesh, coords_ptr) - end if - - end function get_coordinates - - - !> @brief Returns a pointer to the extended coordinate field array - !> @param[in] config Configuration object - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The coordinate field array - function get_extended_coordinates(config, mesh_id) result(extended_chi) - - use sci_extend_chi_field_kernel_mod, only: extend_chi_field_kernel_type - - implicit none - - type(config_type), intent(in) :: config - integer(kind=i_def), intent(in) :: mesh_id - - type(mesh_type), pointer :: mesh - type(field_type), pointer :: extended_chi(:) - logical(kind=l_def) :: constant_exists - integer(kind=i_def) :: depth - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(function_space_type), pointer :: wchi_fs - - integer(tik) :: id - integer(i_def) :: coord_system - - coord_system = config%finite_element%coord_system() - - ! Initialise inventory if this is the first time getting this constant - if (.not. extended_chi_inventory%is_initialised()) then - call extended_chi_inventory%initialise(name="extended_chi") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = extended_chi_inventory%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - ! If this constant doesn't exist, create it - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - wchi_fs => chi(1)%get_function_space() - depth = mesh%get_halo_depth() - call extended_chi_inventory%add_field_array( & - extended_chi, wchi_fs, 3, mesh, halo_depth=depth & - ) - - if (coord_system /= coord_system_native) then - call log_event( & - "Extended coordinates only implemented for native " // & - "coord_system option", LOG_LEVEL_ERROR & - ) - end if - - call invoke( extend_chi_field_kernel_type(extended_chi, chi, & - panel_id, depth) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - else - ! Otherwise, return existing constant - call extended_chi_inventory%get_field_array(mesh, extended_chi) - end if - - end function get_extended_coordinates - - - ! ========================================================================== ! - ! GETTERS FOR BASIC GEOMETRIC ENTITIES - ! ========================================================================== ! - !> @brief Returns the areas of cell faces at W2 DoF locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The dA field - function get_dA_at_w2(mesh_id) result(dA_at_w2) - - use sci_calc_da_at_w2_kernel_mod, only: calc_dA_at_w2_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(field_type), pointer :: dA_at_w2 - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(function_space_type), pointer :: w2_k0_fs - integer(tik) :: id - - ! Initialise inventory if this is the first time getting this constant - if (.not. dA_at_w2_inventory%is_initialised()) then - call dA_at_w2_inventory%initialise(name="dA_at_w2") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = dA_at_w2_inventory%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - ! If this constant doesn't exist, create it - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w2_k0_fs => function_space_collection%get_fs(mesh, 0, 0, W2) - call dA_at_w2_inventory%add_field(dA_at_w2, w2_k0_fs, mesh) - - call invoke( setval_c(dA_at_w2, 0.0_r_def), & - calc_dA_at_w2_kernel_type(dA_at_w2, chi, panel_id) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - else - ! Otherwise, return existing constant - call dA_at_w2_inventory%get_field(mesh, dA_at_w2) - end if - - end function get_dA_at_w2 - - - !> @brief Returns the (finite element) Det(J) values at W3 dof locations - !> @param[in] config Configuration object - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The Det(J) field - function get_detj_at_w3_fe(config, mesh_id) result(detj_at_w3) - - ! @TODO #4487: update these imports - ! use sci_calc_detj_at_w3_kernel_mod, only: calc_detj_at_w3_kernel_type - use sci_compute_mass_matrix_kernel_w_scalar_mod, & - only: compute_mass_matrix_kernel_w_scalar_type - use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type - use operator_mod, only: operator_type - use quadrature_xyoz_mod, only: quadrature_xyoz_type - use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type - - implicit none - - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id - - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: detj_at_w3 - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(function_space_type), pointer :: w3_fs - ! @TODO #4487: arguments for calculating detj in old way - type(operator_type) :: mm_w3 - type(quadrature_xyoz_type) :: qr - logical(kind=l_def) :: extended_mesh - type(quadrature_rule_gaussian_type) :: quadrature_rule - integer(tik) :: id - - integer(i_def) :: nqp_h_exact, nqp_v_exact - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - - nqp_h_exact = config%finite_element%nqp_h_exact() - nqp_v_exact = config%finite_element%nqp_v_exact() - - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - detj_at_w3 => get_detj_at_w3_fv(mesh_id) - return - end if - - ! Check inventory is initialised - if (.not. detj_at_w3_inventory_fe%is_initialised()) then - ! Initialise all inventories together - call detj_at_w3_inventory_fe%initialise(name='detj_at_w3_fe') - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = detj_at_w3_inventory_fe%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - ! Create the object as it doesn't exist yet - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w3_fs => function_space_collection%get_fs(mesh, order_h, order_v, W3) - call detj_at_w3_inventory_fe%add_field(detj_at_w3, w3_fs, mesh) - - ! @TODO #4487: it is inefficient to calculate this via mass matrices - ! The proper method is preserved in the comment here - ! call invoke( calc_detj_at_w3_kernel_type(detj_at_w3, chi, panel_id) ) - call mm_w3%initialise( w3_fs, w3_fs ) - qr = quadrature_xyoz_type(nqp_h_exact, nqp_h_exact, nqp_v_exact, & - quadrature_rule) - extended_mesh = .false. - call invoke( compute_mass_matrix_kernel_w_scalar_type(mm_w3, & - chi, & - panel_id, & - extended_mesh, & - qr), & - setval_c(detj_at_w3, 0.0_r_def), & - mm_diagonal_kernel_type(detj_at_w3, mm_w3) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Get existing constant - call detj_at_w3_inventory_fe%get_field(mesh, detj_at_w3) - - end function get_detj_at_w3_fe - - - !> @brief Returns the (finite volume) Det(J) values at W3 dof locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The Det(J) field - function get_detj_at_w3_fv(mesh_id) result(detj_at_w3) - - ! @TODO #4487: update these imports - ! use sci_calc_detj_at_w3_kernel_mod, & - ! only: calc_detj_at_w3_kernel_type - use sci_compute_mass_matrix_kernel_w_scalar_mod, & - only: compute_mass_matrix_kernel_w_scalar_type - use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type - use operator_mod, only: operator_type - use quadrature_xyoz_mod, only: quadrature_xyoz_type - use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: detj_at_w3 - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(function_space_type), pointer :: w3_fs - ! @TODO #4487: arguments for calculating detj in old way - type(operator_type) :: mm_w3 - type(quadrature_xyoz_type) :: qr - logical(kind=l_def) :: extended_mesh - type(quadrature_rule_gaussian_type) :: quadrature_rule - integer(tik) :: id - - ! Check inventory is initialised - if (.not. detj_at_w3_inventory_fv%is_initialised()) then - ! Initialise all inventories together - call detj_at_w3_inventory_fv%initialise(name='detj_at_w3_fv') - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = detj_at_w3_inventory_fv%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - ! Create the object as it doesn't exist yet - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w3_fs => function_space_collection%get_fs(mesh, 0, 0, W3) - call detj_at_w3_inventory_fv%add_field(detj_at_w3, w3_fs, mesh) - - ! @TODO #4487: it is inefficient to calculate this via mass matrices - ! The proper method is preserved in the comment here - ! call invoke( calc_detj_at_w3_kernel_type(detj_at_w3, chi, panel_id) ) - call mm_w3%initialise( w3_fs, w3_fs ) - qr = quadrature_xyoz_type(3, quadrature_rule) - extended_mesh = .false. - call invoke( compute_mass_matrix_kernel_w_scalar_type(mm_w3, & - chi, & - panel_id, & - extended_mesh, & - qr), & - setval_c(detj_at_w3, 0.0_r_def), & - mm_diagonal_kernel_type(detj_at_w3, mm_w3) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Get existing constant - call detj_at_w3_inventory_fv%get_field(mesh, detj_at_w3) - - end function get_detj_at_w3_fv - - - !> @brief Returns the (finite element) Det(J) values at W2 dof locations - !> @param[in] config Configuration object - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The Det(J) field - function get_detj_at_w2_fe(config, mesh_id) result(detj_at_w2) - - use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type - use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type - - implicit none - - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id - - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: detj_at_w2 - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(field_type) :: multiplicity_w2 - type(function_space_type), pointer :: w2_fs - integer(tik) :: id - - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - detj_at_w2 => get_detj_at_w2_fv(mesh_id) - return - end if - - ! Check inventory is initialised - if (.not. detj_at_w2_inventory_fe%is_initialised()) then - ! Initialise all inventories together - call detj_at_w2_inventory_fe%initialise(name='detj_at_w2_fe') - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = detj_at_w2_inventory_fe%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - ! Create the object as it doesn't exist yet - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w2_fs => function_space_collection%get_fs(mesh, order_h, order_v, W2) - call multiplicity_w2%initialise( w2_fs ) - call detj_at_w2_inventory_fe%add_field(detj_at_w2, w2_fs, mesh) - - ! @TODO #4487: a small optimisation here is to multiply by rmultiplicity, - ! rather than computing and dividing by mulitplicity - call invoke( setval_c(detj_at_w2, 0.0_r_def), & - calc_detj_at_w2_kernel_type(detj_at_w2, chi, panel_id), & - setval_c(multiplicity_w2, 0.0_r_def), & - multiplicity_kernel_type(multiplicity_w2), & - inc_X_divideby_Y(detj_at_w2, multiplicity_w2) ) - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Get existing constant - call detj_at_w2_inventory_fe%get_field(mesh, detj_at_w2) - - end function get_detj_at_w2_fe - - - !> @brief Returns the (finite volume) Det(J) values at W2 dof locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The Det(J) field - function get_detj_at_w2_fv(mesh_id) result(detj_at_w2) - - use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type - use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: detj_at_w2 - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(field_type) :: multiplicity_w2 - type(function_space_type), pointer :: w2_fs - integer(tik) :: id - - ! Check inventory is initialised - if (.not. detj_at_w2_inventory_fv%is_initialised()) then - ! Initialise all inventories together - call detj_at_w2_inventory_fv%initialise(name='detj_at_w2_fv') - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = detj_at_w2_inventory_fv%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - ! Create the object as it doesn't exist yet - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w2_fs => function_space_collection%get_fs(mesh, 0, 0, W2) - call multiplicity_w2%initialise( w2_fs ) - call detj_at_w2_inventory_fv%add_field(detj_at_w2, w2_fs, mesh) - - ! @TODO #4487: a small optimisation here is to multiply by rmultiplicity, - ! rather than computing and dividing by mulitplicity - call invoke( setval_c(detj_at_w2, 0.0_r_def), & - calc_detj_at_w2_kernel_type(detj_at_w2, chi, panel_id), & - setval_c(multiplicity_w2, 0.0_r_def), & - multiplicity_kernel_type(multiplicity_w2), & - inc_X_divideby_Y(detj_at_w2, multiplicity_w2) ) - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Get existing constant - call detj_at_w2_inventory_fv%get_field(mesh, detj_at_w2) - - end function get_detj_at_w2_fv - - - !> @brief Returns a pointer to the vertical grid spacing, located at W3 DoFs - !> @param[in] config Configuration object - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The physical height difference of layers, at W3 - function get_dz_w3(config, mesh_id) result(dz_w3) - - use sci_get_dz_w3_kernel_mod, only: get_dz_w3_kernel_type - - implicit none - - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id - - type(mesh_type), pointer :: mesh - type(field_type), pointer :: dz_w3 - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: height_w2 - type(function_space_type), pointer :: w3_fs - integer(tik) :: id - - ! Initialise inventory if this is the first time getting this constant - if (.not. dz_w3_inventory%is_initialised()) then - call dz_w3_inventory%initialise(name="dz_w3") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = dz_w3_inventory%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - ! If this constant doesn't exist, create it - ! Get height first to avoid potentially timing twice - height_w2 => get_height_fv(config, W2, mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w3_fs => function_space_collection%get_fs(mesh, 0, 0, W3) - call dz_w3_inventory%add_field(dz_w3, w3_fs, mesh) - - call invoke( get_dz_w3_kernel_type(dz_w3, height_w2) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - else - ! Otherwise, return existing constant - call dz_w3_inventory%get_field(mesh, dz_w3) - end if - - end function get_dz_w3 - - - !> @brief Returns the delta_at_wtheta values at Wtheta DoF locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The delta_at_wtheta field - function get_delta_at_wtheta(mesh_id) result(delta_at_wtheta) - - use sci_calc_delta_at_wtheta_kernel_mod, & - only: calc_delta_at_wtheta_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: dx_at_w2 - type(field_type), pointer :: delta_at_wtheta - type(function_space_type), pointer :: wt_k0_fs - integer(tik) :: id - - ! Initialise inventory if it hasn't been done so already - if (.not. delta_at_wtheta_inventory%is_initialised()) then - call delta_at_wtheta_inventory%initialise(name="delta_at_wtheta") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = delta_at_wtheta_inventory%paired_object_exists(mesh_id) - - ! Create constant if it doesn't already exist - if (.not. constant_exists) then - wt_k0_fs => function_space_collection%get_fs(mesh, 0, 0, Wtheta) - dx_at_w2 => get_dx_at_w2(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - call delta_at_wtheta_inventory%add_field(delta_at_wtheta, wt_k0_fs, mesh) - - call invoke( calc_delta_at_wtheta_kernel_type(delta_at_wtheta, dx_at_w2) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Return constant - call delta_at_wtheta_inventory%get_field(mesh, delta_at_wtheta) - - end function get_delta_at_wtheta - - !> @brief Returns the dx_at_w2 values at W2 DoF locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The dx_at_w2 field - function get_dx_at_w2(mesh_id) result(dx_at_w2) - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: dx_at_w2 - type(field_type), pointer :: detj_at_w2 - type(field_type), pointer :: dA_at_w2 - type(function_space_type), pointer :: w2_fs - integer(tik) :: id - - ! Initialise inventory if it hasn't been done so already - if (.not. dx_at_w2_inventory%is_initialised()) then - call dx_at_w2_inventory%initialise(name="dx_at_w2") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = dx_at_w2_inventory%paired_object_exists(mesh_id) - - ! Create constant if it doesn't already exist - if (.not. constant_exists) then - w2_fs => function_space_collection%get_fs(mesh, 0, 0, W2) - detj_at_w2 => get_detj_at_w2_fv(mesh_id) - dA_at_w2 => get_dA_at_w2(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - call dx_at_w2_inventory%add_field(dx_at_w2, w2_fs, mesh) - call invoke( X_divideby_Y(dx_at_w2, detj_at_w2, dA_at_w2) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Return constant - call dx_at_w2_inventory%get_field(mesh, dx_at_w2) - - end function get_dx_at_w2 - - - !> @brief Returns the 1/dz values at lowest-order Wtheta DoF locations - !> @param[in] config Configuration object - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The dz_at_wtheta field - function get_dz_at_wtheta(config, mesh_id) result(dz_at_wtheta) - - use sci_calc_dz_face_kernel_mod, only: calc_dz_face_kernel_type - - implicit none - - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id - - type(mesh_type), pointer :: mesh - type(field_type), pointer :: dz_at_wtheta - type(function_space_type), pointer :: wtheta_k0_fs - type(field_type), pointer :: height_w3 - type(field_type), pointer :: height_wth - logical(kind=l_def) :: constant_exists - integer(tik) :: id - - ! Parameters of the cells - integer(i_def), parameter :: n_centres = 1_i_def - logical(l_def), parameter :: ign_surf = .false. - - ! Initialise inventory if it hasn't been done so already - if (.not. dz_at_wtheta_inventory%is_initialised()) then - call dz_at_wtheta_inventory%initialise(name="dz_at_wtheta") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = dz_at_wtheta_inventory%paired_object_exists(mesh_id) - - ! Create constant if it doesn't already exist - if (.not. constant_exists) then - ! NB: this assumes heights are in the lowest-order space - height_w3 => get_height_fv(config, W3, mesh_id) - height_wth => get_height_fv(config, Wtheta, mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - wtheta_k0_fs => function_space_collection%get_fs(mesh, 0, 0, Wtheta) - - call dz_at_wtheta_inventory%add_field(dz_at_wtheta, wtheta_k0_fs, mesh) - - call invoke( calc_dz_face_kernel_type(dz_at_wtheta, height_w3, & - height_wth, n_centres, ign_surf) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Return constant - call dz_at_wtheta_inventory%get_field(mesh, dz_at_wtheta) - - end function get_dz_at_wtheta - - - !> @brief Returns the surface area of a cell projected to mean sea level - !> i.e. ignoring the orographic effect on the area - !> @param[in] config Configuration object - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The dA_msl_proj field - function get_dA_msl_proj(config, mesh_id) result(dA_msl_proj) - - use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type - - implicit none - - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id - - integer(kind=i_def) :: local_mesh_id - type(mesh_type), pointer :: mesh - type(mesh_type), pointer :: prime_mesh - type(mesh_type), pointer :: twod_mesh - type(local_mesh_type), pointer :: local_mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: dA_msl_proj - type(field_type), pointer :: dA_at_w2 - type(function_space_type), pointer :: fs - integer(tik) :: id - - integer(i_def) :: geometry - real(r_def) :: planet_radius - real(r_def) :: domain_height - - geometry = config%base_mesh%geometry() - planet_radius = config%extrusion%planet_radius() - domain_height = config%extrusion%domain_height() - - ! Initialise inventory if it hasn't been done so already - if (.not. dA_msl_proj_inventory%is_initialised()) then - call dA_msl_proj_inventory%initialise(name="dA_msl_proj") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - local_mesh_id = local_mesh%get_id() - constant_exists = dA_msl_proj_inventory%paired_object_exists(local_mesh_id) - - ! Create constant if it doesn't already exist - if (.not. constant_exists) then - prime_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) - twod_mesh => mesh_collection%get_mesh(mesh, TWOD) - fs => function_space_collection%get_fs(twod_mesh, 0, 0, W3) - dA_at_w2 => get_dA_at_w2(prime_mesh%get_id()) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - call dA_msl_proj_inventory%add_field(dA_msl_proj, fs, local_mesh) - call invoke( calc_da_msl_proj_kernel_type(dA_at_w2, dA_msl_proj, & - planet_radius, domain_height, & - geometry, geometry_spherical) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Return constant - call dA_msl_proj_inventory%get_field(local_mesh, dA_msl_proj) - - end function get_dA_msl_proj - - - ! ========================================================================== ! - ! PHYSICAL COORDINATES OF DOFs - ! ========================================================================== ! - !> @brief Returns a pointer to the longitude of finite element DoFs - !> @param[in] config Configuration object - !> @param[in] space_id The space for which to get the longitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The longitude field - function get_longitude_fe(config, space_id, mesh_id) result(long_ptr) - - implicit none - - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: space_id - integer(i_def), intent(in) :: mesh_id - - type(mesh_type), pointer :: mesh - type(local_mesh_type), pointer :: local_mesh - type(inventory_by_local_mesh_type), pointer :: long_inventory - type(inventory_by_local_mesh_type), pointer :: lat_inventory - type(field_type), pointer :: long_ptr - logical(kind=l_def) :: constant_exists - character(len=str_def) :: inventory_name - - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - long_ptr => get_longitude_fv(config, space_id, mesh_id) - return - end if - - ! NB: Longitude and latitude fields are computed simultaneously - ! Determine inventory based on space - select case (space_id) - case (W2) - long_inventory => long_w2_inventory_fe - lat_inventory => lat_w2_inventory_fe - inventory_name = "_w2_fe" - case (W2H) - long_inventory => long_w2h_inventory_fe - lat_inventory => lat_w2h_inventory_fe - inventory_name = "_w2h_fe" - case (W3) - long_inventory => long_w3_inventory_fe - lat_inventory => lat_w3_inventory_fe - inventory_name = "_w3_fe" - case default - long_ptr => null() - call log_event("Longitude not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. long_inventory%is_initialised()) then - call long_inventory%initialise(name='longitude_'//trim(inventory_name)) - call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) - end if - - ! Create constant - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.true.) - end if - - call long_inventory%get_field(local_mesh, long_ptr) - - end function get_longitude_fe - - !> @brief Returns a pointer to the longitude of finite volume DoFs - !> @param[in] config Configuration object - !> @param[in] space_id The space for which to get the longitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The longitude field - function get_longitude_fv(config, space_id, mesh_id) result(long_ptr) - - implicit none - - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: space_id - integer(i_def), intent(in) :: mesh_id - - type(mesh_type), pointer :: mesh - type(local_mesh_type), pointer :: local_mesh - type(inventory_by_local_mesh_type), pointer :: long_inventory - type(inventory_by_local_mesh_type), pointer :: lat_inventory - type(field_type), pointer :: long_ptr - logical(kind=l_def) :: constant_exists - character(len=str_def) :: inventory_name - - ! NB: Longitude and latitude fields are computed simultaneously - ! Determine inventory based on space - select case (space_id) - case (W2) - long_inventory => long_w2_inventory_fv - lat_inventory => lat_w2_inventory_fv - inventory_name = "_w2_fv" - case (W2H) - long_inventory => long_w2h_inventory_fv - lat_inventory => lat_w2h_inventory_fv - inventory_name = "_w2h_fv" - case (W3) - long_inventory => long_w3_inventory_fv - lat_inventory => lat_w3_inventory_fv - inventory_name = "_w3_fv" - case default - long_ptr => null() - call log_event("Longitude not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. long_inventory%is_initialised()) then - call long_inventory%initialise(name='longitude_'//trim(inventory_name)) - call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) - end if - - ! Create constant - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.false.) - end if - - call long_inventory%get_field(local_mesh, long_ptr) - - end function get_longitude_fv - - - !> @brief Returns a pointer to the latitude of finite element DoFs - !> @param[in] config Configuration object - !> @param[in] space_id The space for which to get the latitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The latitude field - function get_latitude_fe(config, space_id, mesh_id) result(lat_ptr) - - implicit none - - type(config_type), intent(in) :: config - - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(local_mesh_type), pointer :: local_mesh - type(inventory_by_local_mesh_type), pointer :: long_inventory - type(inventory_by_local_mesh_type), pointer :: lat_inventory - type(field_type), pointer :: lat_ptr - logical(kind=l_def) :: constant_exists - character(len=str_def) :: inventory_name - - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - lat_ptr => get_latitude_fv(config, space_id, mesh_id) - return - end if - - ! NB: Longitude and latitude fields are computed simultaneously - ! Determine inventory based on space - select case (space_id) - case (W2) - long_inventory => long_w2_inventory_fe - lat_inventory => lat_w2_inventory_fe - inventory_name = "_w2_fe" - case (W2H) - long_inventory => long_w2h_inventory_fe - lat_inventory => lat_w2h_inventory_fe - inventory_name = "_w2h_fe" - case (W3) - long_inventory => long_w3_inventory_fe - lat_inventory => lat_w3_inventory_fe - inventory_name = "_w3_fe" - case default - lat_ptr => null() - call log_event("Latitude not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. lat_inventory%is_initialised()) then - call long_inventory%initialise(name='longitude_'//trim(inventory_name)) - call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) - end if - - ! Create constant - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.true.) - end if - - call lat_inventory%get_field(local_mesh, lat_ptr) - - end function get_latitude_fe - - - - !> @brief Returns a pointer to the latitude of finite volume DoFs - !> @param[in] config Configuration object - !> @param[in] space_id The space for which to get the latitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The latitude field - function get_latitude_fv(config, space_id, mesh_id) result(lat_ptr) - - implicit none - - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: space_id - integer(i_def), intent(in) :: mesh_id - - type(mesh_type), pointer :: mesh - type(local_mesh_type), pointer :: local_mesh - type(inventory_by_local_mesh_type), pointer :: long_inventory - type(inventory_by_local_mesh_type), pointer :: lat_inventory - type(field_type), pointer :: lat_ptr - logical(kind=l_def) :: constant_exists - character(len=str_def) :: inventory_name - - ! NB: Longitude and latitude fields are computed simultaneously - ! Determine inventory based on space - select case (space_id) - case (W2) - long_inventory => long_w2_inventory_fv - lat_inventory => lat_w2_inventory_fv - inventory_name = "_w2_fv" - case (W2H) - long_inventory => long_w2h_inventory_fv - lat_inventory => lat_w2h_inventory_fv - inventory_name = "_w2h_fv" - case (W3) - long_inventory => long_w3_inventory_fv - lat_inventory => lat_w3_inventory_fv - inventory_name = "_w3_fv" - case default - lat_ptr => null() - call log_event("Latitude not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. lat_inventory%is_initialised()) then - call long_inventory%initialise(name='longitude_'//trim(inventory_name)) - call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) - end if - - ! Create constant - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.false.) - end if - - call lat_inventory%get_field(local_mesh, lat_ptr) - - end function get_latitude_fv - - - !> @brief Returns a pointer to a finite element height field - !> @param[in] config Configuration object - !> @param[in] space_id The space of the desired height field - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return A height field - function get_height_fe(config, space_id, mesh_id) result(height) - - - use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type - use sci_height_discontinuous_kernel_mod, & - only: height_discontinuous_kernel_type - - implicit none - - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: space_id - integer(i_def), intent(in) :: mesh_id - - type(mesh_type), pointer :: mesh - type(inventory_by_mesh_type), pointer :: inventory - logical(kind=l_def) :: constant_exists - type(function_space_type), pointer :: space - type(field_type), pointer :: chi(:) - type(field_type), pointer :: height - type(field_type) :: rmultiplicity - type(field_type) :: nodal_multiplicity - type(field_type) :: ones - character(len=str_def) :: inventory_name - integer(tik) :: id - - real(r_def) :: scaled_radius - integer(i_def) :: geometry, coord_system - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - coord_system = config%finite_element%coord_system() - geometry = config%base_mesh%geometry() - scaled_radius = config%planet%scaled_radius() - - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - height => get_height_fv(config, space_id, mesh_id) - return - end if - - ! Determine inventory based on space - select case (space_id) - case (W0) - inventory => height_w0_inventory_fe - inventory_name = "height_w0_fe" - case (W1) - inventory => height_w1_inventory_fe - inventory_name = "height_w1_fe" - case (W2) - inventory => height_w2_inventory_fe - inventory_name = "height_w2_fe" - case (W2H) - inventory => height_w2h_inventory_fe - inventory_name = "height_w2h_fe" - case (W3) - inventory => height_w3_inventory_fe - inventory_name = "height_w3_fe" - case (Wtheta) - inventory => height_wth_inventory_fe - inventory_name = "height_wtheta_fe" - case default - height => null() - call log_event("Height not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. inventory%is_initialised()) then - call inventory%initialise(name=inventory_name) - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = inventory%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - ! If this constant doesn't exist, create it - chi => get_coordinates(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - space => function_space_collection%get_fs(mesh, & - order_h, & - order_v, & - space_id) - call inventory%add_field(height, space, mesh) - - select case (space_id) - ! Horizontally discontinuous spaces - case (W3, Wtheta) - call invoke( & - height_discontinuous_kernel_type( & - height, chi, geometry, coord_system, scaled_radius & - ) & - ) - - ! Horizontally continuous spaces - case default - ! Can't import multiplicity, so must calculate it - call ones%initialise( space ) - call nodal_multiplicity%initialise( space ) - call rmultiplicity%initialise( space ) - - call invoke( & - setval_c(ones, 1.0_r_def), & - setval_c(nodal_multiplicity, 0.0_r_def), & - multiplicity_kernel_type(nodal_multiplicity), & - X_divideby_Y(rmultiplicity, ones, nodal_multiplicity), & - setval_c(height, 0.0_r_def), & - height_continuous_kernel_type( & - height, chi, rmultiplicity, & - geometry, coord_system, scaled_radius & - ) & - ) - end select - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - else - call inventory%get_field(mesh, height) - end if - - end function get_height_fe - - - !> @brief Returns a pointer to a finite volume height field - !> @param[in] config Configuration object - !> @param[in] space_id The space of the desired height field - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return A height field - function get_height_fv(config, space_id, mesh_id) result(height) - - use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type - use sci_height_discontinuous_kernel_mod, & - only: height_discontinuous_kernel_type - - implicit none - - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: space_id - integer(i_def), intent(in) :: mesh_id - - type(mesh_type), pointer :: mesh - type(inventory_by_mesh_type), pointer :: inventory - logical(kind=l_def) :: constant_exists - type(function_space_type), pointer :: space - type(field_type), pointer :: chi(:) - type(field_type), pointer :: height - type(field_type) :: rmultiplicity - type(field_type) :: nodal_multiplicity - type(field_type) :: ones - character(len=str_def) :: inventory_name - integer(tik) :: id - - real(r_def) :: scaled_radius - integer(i_def) :: geometry, coord_system - - coord_system = config%finite_element%coord_system() - geometry = config%base_mesh%geometry() - scaled_radius = config%planet%scaled_radius() - - ! Determine inventory based on space - select case (space_id) - case (W0) - inventory => height_w0_inventory_fv - inventory_name = "height_w0_fv" - case (W1) - inventory => height_w1_inventory_fv - inventory_name = "height_w1_fv" - case (W2) - inventory => height_w2_inventory_fv - inventory_name = "height_w2_fv" - case (W2H) - inventory => height_w2h_inventory_fv - inventory_name = "height_w2h_fv" - case (W3) - inventory => height_w3_inventory_fv - inventory_name = "height_w3_fv" - case (Wtheta) - inventory => height_wth_inventory_fv - inventory_name = "height_wtheta_fv" - case default - height => null() - call log_event("Height not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. inventory%is_initialised()) then - call inventory%initialise(name=inventory_name) - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = inventory%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - ! If this constant doesn't exist, create it - chi => get_coordinates(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - space => function_space_collection%get_fs(mesh, 0, 0, space_id) - call inventory%add_field(height, space, mesh) - - select case (space_id) - ! Horizontally discontinuous spaces - case (W3, Wtheta) - call invoke( & - height_discontinuous_kernel_type( & - height, chi, geometry, coord_system, scaled_radius & - ) & - ) - - ! Horizontally continuous spaces - case default - ! Can't import multiplicity, so must calculate it - call ones%initialise( space ) - call nodal_multiplicity%initialise( space ) - call rmultiplicity%initialise( space ) - - call invoke( & - setval_c(ones, 1.0_r_def), & - setval_c(nodal_multiplicity, 0.0_r_def), & - multiplicity_kernel_type(nodal_multiplicity), & - X_divideby_Y(rmultiplicity, ones, nodal_multiplicity), & - setval_c(height, 0.0_r_def), & - height_continuous_kernel_type( & - height, chi, rmultiplicity, & - geometry, coord_system, scaled_radius & - ) & - ) - end select - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - else - call inventory%get_field(mesh, height) - end if - - end function get_height_fv - - - ! ========================================================================== ! - ! FACE SELECTORS - ! ========================================================================== ! - - !> @brief Returns a pointer to the east-west face selector - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The east-west face selector - function get_face_selector_ew(mesh_id) result(selector) - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh => null() - type(local_mesh_type), pointer :: local_mesh => null() - type(integer_field_type), pointer :: selector - logical(kind=l_def) :: constant_exists - - ! Initialise inventory if this is the first time getting this constant - if (.not. face_selector_ew_inventory%is_initialised()) then - call face_selector_ew_inventory%initialise(name="face_selector_ew") - call face_selector_ns_inventory%initialise(name="face_selector_ns") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = & - face_selector_ew_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) call compute_face_selectors(mesh) - - call face_selector_ew_inventory%get_field(local_mesh, selector) - - end function get_face_selector_ew - - !> @brief Returns a pointer to the north-south face selector - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The north-south face selector - function get_face_selector_ns(mesh_id) result(selector) - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh => null() - type(local_mesh_type), pointer :: local_mesh => null() - type(integer_field_type), pointer :: selector - logical(kind=l_def) :: constant_exists - - ! Initialise inventory if this is the first time getting this constant - if (.not. face_selector_ew_inventory%is_initialised()) then - call face_selector_ew_inventory%initialise(name="face_selector_ew") - call face_selector_ns_inventory%initialise(name="face_selector_ns") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = & - face_selector_ns_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) call compute_face_selectors(mesh) - - call face_selector_ns_inventory%get_field(local_mesh, selector) - - end function get_face_selector_ns - - ! ========================================================================== ! - ! GETTERS FOR INVENTORIES - ! ========================================================================== ! - ! These are two special inventories, which are set up in the driver - - !> @brief Returns a pointer to the chi inventory - function get_chi_inventory() result(inventory_ptr) - implicit none - type(inventory_by_mesh_type), pointer :: inventory_ptr - - inventory_ptr => chi_inventory - - end function get_chi_inventory - - !> @brief Returns a pointer to the panel_id inventory - function get_panel_id_inventory() result(inventory_ptr) - implicit none - type(inventory_by_mesh_type), pointer :: inventory_ptr - - inventory_ptr => panel_id_inventory - - end function get_panel_id_inventory - - ! ========================================================================== ! - ! FINALISE - ! ========================================================================== ! - !> @brief Explicitly reclaim memory from module scope variables - subroutine final_geometric_constants() - - implicit none - - call lat_w2_inventory_fe%clear() - call lat_w2_inventory_fv%clear() - call lat_w3_inventory_fe%clear() - call lat_w3_inventory_fv%clear() - call lat_w2h_inventory_fe%clear() - call lat_w2h_inventory_fv%clear() - call long_w2_inventory_fe%clear() - call long_w2_inventory_fv%clear() - call long_w3_inventory_fe%clear() - call long_w3_inventory_fv%clear() - call long_w2h_inventory_fe%clear() - call long_w2h_inventory_fv%clear() - call dA_at_w2_inventory%clear() - call height_wth_inventory_fe%clear() - call height_wth_inventory_fv%clear() - call height_w3_inventory_fe%clear() - call height_w3_inventory_fv%clear() - call height_w2_inventory_fe%clear() - call height_w2_inventory_fv%clear() - call height_w2h_inventory_fe%clear() - call height_w2h_inventory_fv%clear() - call height_w1_inventory_fe%clear() - call height_w1_inventory_fv%clear() - call height_w0_inventory_fe%clear() - call height_w0_inventory_fv%clear() - call dz_w3_inventory%clear() - call panel_id_inventory%clear() - call chi_inventory%clear() - call extended_chi_inventory%clear() - call detj_at_w3_inventory_fe%clear() - call detj_at_w3_inventory_fv%clear() - call detj_at_w2_inventory_fe%clear() - call detj_at_w2_inventory_fv%clear() - call delta_at_wtheta_inventory%clear() - call dx_at_w2_inventory%clear() - call dz_at_wtheta_inventory%clear() - call dA_msl_proj_inventory%clear() - - end subroutine final_geometric_constants - -end module new_sci_geometric_constants_mod diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90 b/components/science/source/algorithm/sci_geometric_constants_mod.x90 index e33f44e9a..eaa3ccf42 100644 --- a/components/science/source/algorithm/sci_geometric_constants_mod.x90 +++ b/components/science/source/algorithm/sci_geometric_constants_mod.x90 @@ -15,25 +15,26 @@ module sci_geometric_constants_mod ! Infrastructure - use constants_mod, only: i_def, r_def, l_def, str_def - use extrusion_mod, only: TWOD, PRIME_EXTRUSION - use field_mod, only: field_type - use fs_continuity_mod, only: W0, W1, W2, W2H, W3, Wtheta - use function_space_collection_mod, only: function_space_collection - use function_space_mod, only: function_space_type - use integer_field_mod, only: integer_field_type - use inventory_by_mesh_mod, only: inventory_by_mesh_type - use inventory_by_local_mesh_mod, only: inventory_by_local_mesh_type - use local_mesh_mod, only: local_mesh_type - use log_mod, only: log_event, LOG_LEVEL_ERROR - use mesh_collection_mod, only: mesh_collection - use mesh_mod, only: mesh_type - use timing_mod, only: start_timing, stop_timing, & - tik, LPROF + use config_mod, only: config_type + use constants_mod, only: i_def, r_def, l_def, str_def + use extrusion_mod, only: TWOD, PRIME_EXTRUSION + use field_mod, only: field_type + use fs_continuity_mod, only: W0, W1, W2, W2H, W3, Wtheta + use function_space_collection_mod, only: function_space_collection + use function_space_mod, only: function_space_type + use integer_field_mod, only: integer_field_type + use inventory_by_mesh_mod, only: inventory_by_mesh_type + use inventory_by_local_mesh_mod, only: inventory_by_local_mesh_type + use local_mesh_mod, only: local_mesh_type + use log_mod, only: log_event, LOG_LEVEL_ERROR + use mesh_collection_mod, only: mesh_collection + use mesh_mod, only: mesh_type + use timing_mod, only: start_timing, stop_timing, & + tik, LPROF ! Configuration - use finite_element_config_mod, only: element_order_h, & - element_order_v + use base_mesh_config_mod, only: geometry_spherical + use finite_element_config_mod, only: coord_system_native implicit none @@ -101,15 +102,20 @@ module sci_geometric_constants_mod public :: final_geometric_constants public :: get_panel_id public :: get_coordinates - public :: get_extended_coordinates public :: get_dA_at_w2 - public :: get_detj_at_w3_fe public :: get_detj_at_w3_fv - public :: get_detj_at_w2_fe public :: get_detj_at_w2_fv - public :: get_dz_w3 public :: get_delta_at_wtheta public :: get_dx_at_w2 + public :: get_face_selector_ew + public :: get_face_selector_ns + public :: get_chi_inventory + public :: get_panel_id_inventory + + public :: get_extended_coordinates + public :: get_detj_at_w3_fe + public :: get_detj_at_w2_fe + public :: get_dz_w3 public :: get_dz_at_wtheta public :: get_dA_msl_proj public :: get_height_fe @@ -118,10 +124,6 @@ module sci_geometric_constants_mod public :: get_latitude_fv public :: get_longitude_fe public :: get_longitude_fv - public :: get_face_selector_ew - public :: get_face_selector_ns - public :: get_chi_inventory - public :: get_panel_id_inventory ! Private routines for creating constants private :: compute_latlon @@ -134,6 +136,7 @@ contains ! ========================================================================== ! !> @brief Private routine for computing longitude and latitude fields + !> @param[in] config Configuration object !> @param[in,out] long_inventory Inventory containing longitude fields !> @param[in,out] lat_inventory Inventory containing latitude fields !> @param[in] mesh Mesh used to determine local mesh for @@ -142,15 +145,15 @@ contains !! longitude and latitude fields for !> @param[in] use_fe Flag to indicate whether to use finite !! element or finite volume cells - subroutine compute_latlon(long_inventory, lat_inventory, mesh, fs_id, use_fe) + subroutine compute_latlon(config, long_inventory, lat_inventory, & + mesh, fs_id, use_fe) - use base_mesh_config_mod, only: f_lat, geometry, & - geometry_spherical - use idealised_config_mod, only: f_lon - use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type + use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type implicit none + type(config_type), intent(in) :: config + type(inventory_by_local_mesh_type), intent(inout) :: long_inventory type(inventory_by_local_mesh_type), intent(inout) :: lat_inventory type(mesh_type), intent(in) :: mesh @@ -168,11 +171,28 @@ contains integer(kind=i_def) :: k_h, k_v integer(tik) :: id + integer(i_def) :: geometry, topology + integer(i_def) :: order_h, order_v + integer(i_def) :: coord_system + real(r_def) :: f_lat, f_lon + real(r_def) :: scaled_radius + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + coord_system = config%finite_element%coord_system() + scaled_radius = config%planet%scaled_radius() + + f_lat = config%base_mesh%f_lat() + f_lon = config%idealised%f_lon() + if (use_fe) then - k_h = element_order_h - k_v = element_order_v + k_h = order_h + k_v = order_v else k_h = 0 k_v = 0 @@ -187,9 +207,11 @@ contains if ( geometry == geometry_spherical ) then chi => get_coordinates(mesh%get_id()) panel_id => get_panel_id(mesh%get_id()) - call invoke( compute_latlon_kernel_type(lat, long, chi, panel_id) ) + call invoke( compute_latlon_kernel_type(lat, long, chi, panel_id, & + geometry, topology, & + coord_system, scaled_radius) ) else - call invoke( setval_c(lat, f_lat), & + call invoke( setval_c(lat, f_lat), & setval_c(long, f_lon) ) end if @@ -197,6 +219,7 @@ contains end subroutine compute_latlon + !> @brief Private routine for computing face selectors fields !> @param[in,out] ew_inventory Inventory containing East-West selectors !> @param[in,out] ns_inventory Inventory containing North-South selectors @@ -301,17 +324,20 @@ contains end function get_coordinates + !> @brief Returns a pointer to the extended coordinate field array + !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The coordinate field array - function get_extended_coordinates(mesh_id) result(extended_chi) + function get_extended_coordinates(config, mesh_id) result(extended_chi) - use finite_element_config_mod, only: coord_system, coord_system_native use sci_extend_chi_field_kernel_mod, only: extend_chi_field_kernel_type implicit none + type(config_type), intent(in) :: config integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(field_type), pointer :: extended_chi(:) logical(kind=l_def) :: constant_exists @@ -319,7 +345,11 @@ contains type(field_type), pointer :: chi(:) type(field_type), pointer :: panel_id type(function_space_type), pointer :: wchi_fs - integer(tik) :: id + + integer(tik) :: id + integer(i_def) :: coord_system + + coord_system = config%finite_element%coord_system() ! Initialise inventory if this is the first time getting this constant if (.not. extended_chi_inventory%is_initialised()) then @@ -360,6 +390,7 @@ contains end function get_extended_coordinates + ! ========================================================================== ! ! GETTERS FOR BASIC GEOMETRIC ENTITIES ! ========================================================================== ! @@ -368,7 +399,7 @@ contains !> @return The dA field function get_dA_at_w2(mesh_id) result(dA_at_w2) - use sci_calc_da_at_w2_kernel_mod, only: calc_dA_at_w2_kernel_type + use sci_calc_da_at_w2_kernel_mod, only: calc_dA_at_w2_kernel_type implicit none @@ -410,25 +441,27 @@ contains end function get_dA_at_w2 + !> @brief Returns the (finite element) Det(J) values at W3 dof locations + !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field - function get_detj_at_w3_fe(mesh_id) result(detj_at_w3) + function get_detj_at_w3_fe(config, mesh_id) result(detj_at_w3) ! @TODO #4487: update these imports ! use sci_calc_detj_at_w3_kernel_mod, only: calc_detj_at_w3_kernel_type use sci_compute_mass_matrix_kernel_w_scalar_mod, & only: compute_mass_matrix_kernel_w_scalar_type use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type - use finite_element_config_mod, only: nqp_h_exact, & - nqp_v_exact use operator_mod, only: operator_type use quadrature_xyoz_mod, only: quadrature_xyoz_type use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type implicit none - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh logical(kind=l_def) :: constant_exists type(field_type), pointer :: detj_at_w3 @@ -442,8 +475,17 @@ contains type(quadrature_rule_gaussian_type) :: quadrature_rule integer(tik) :: id + integer(i_def) :: nqp_h_exact, nqp_v_exact + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + + nqp_h_exact = config%finite_element%nqp_h_exact() + nqp_v_exact = config%finite_element%nqp_v_exact() + ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then + if (order_h == 0 .and. order_v == 0) then detj_at_w3 => get_detj_at_w3_fv(mesh_id) return end if @@ -464,8 +506,7 @@ contains ! Create the object as it doesn't exist yet if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - w3_fs => function_space_collection%get_fs(mesh, element_order_h, & - element_order_v, W3) + w3_fs => function_space_collection%get_fs(mesh, order_h, order_v, W3) call detj_at_w3_inventory_fe%add_field(detj_at_w3, w3_fs, mesh) ! @TODO #4487: it is inefficient to calculate this via mass matrices @@ -491,6 +532,7 @@ contains end function get_detj_at_w3_fe + !> @brief Returns the (finite volume) Det(J) values at W3 dof locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field @@ -563,17 +605,21 @@ contains end function get_detj_at_w3_fv + !> @brief Returns the (finite element) Det(J) values at W2 dof locations + !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field - function get_detj_at_w2_fe(mesh_id) result(detj_at_w2) + function get_detj_at_w2_fe(config, mesh_id) result(detj_at_w2) use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type implicit none - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh logical(kind=l_def) :: constant_exists type(field_type), pointer :: detj_at_w2 @@ -583,8 +629,13 @@ contains type(function_space_type), pointer :: w2_fs integer(tik) :: id + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then + if (order_h == 0 .and. order_v == 0) then detj_at_w2 => get_detj_at_w2_fv(mesh_id) return end if @@ -605,8 +656,7 @@ contains ! Create the object as it doesn't exist yet if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - w2_fs => function_space_collection%get_fs(mesh, element_order_h, & - element_order_v, W2) + w2_fs => function_space_collection%get_fs(mesh, order_h, order_v, W2) call multiplicity_w2%initialise( w2_fs ) call detj_at_w2_inventory_fe%add_field(detj_at_w2, w2_fs, mesh) @@ -625,6 +675,7 @@ contains end function get_detj_at_w2_fe + !> @brief Returns the (finite volume) Det(J) values at W2 dof locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field @@ -680,16 +731,20 @@ contains end function get_detj_at_w2_fv + !> @brief Returns a pointer to the vertical grid spacing, located at W3 DoFs + !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The physical height difference of layers, at W3 - function get_dz_w3(mesh_id) result(dz_w3) + function get_dz_w3(config, mesh_id) result(dz_w3) - use sci_get_dz_w3_kernel_mod, only: get_dz_w3_kernel_type + use sci_get_dz_w3_kernel_mod, only: get_dz_w3_kernel_type implicit none - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(field_type), pointer :: dz_w3 logical(kind=l_def) :: constant_exists @@ -708,7 +763,7 @@ contains if (.not. constant_exists) then ! If this constant doesn't exist, create it ! Get height first to avoid potentially timing twice - height_w2 => get_height_fv(W2, mesh_id) + height_w2 => get_height_fv(config, W2, mesh_id) if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) @@ -725,6 +780,7 @@ contains end function get_dz_w3 + !> @brief Returns the delta_at_wtheta values at Wtheta DoF locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The delta_at_wtheta field @@ -815,15 +871,18 @@ contains !> @brief Returns the 1/dz values at lowest-order Wtheta DoF locations + !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The dz_at_wtheta field - function get_dz_at_wtheta(mesh_id) result(dz_at_wtheta) + function get_dz_at_wtheta(config, mesh_id) result(dz_at_wtheta) use sci_calc_dz_face_kernel_mod, only: calc_dz_face_kernel_type implicit none - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(field_type), pointer :: dz_at_wtheta type(function_space_type), pointer :: wtheta_k0_fs @@ -847,8 +906,8 @@ contains ! Create constant if it doesn't already exist if (.not. constant_exists) then ! NB: this assumes heights are in the lowest-order space - height_w3 => get_height_fv(W3, mesh_id) - height_wth => get_height_fv(Wtheta, mesh_id) + height_w3 => get_height_fv(config, W3, mesh_id) + height_wth => get_height_fv(config, Wtheta, mesh_id) if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) @@ -867,19 +926,21 @@ contains end function get_dz_at_wtheta + !> @brief Returns the surface area of a cell projected to mean sea level !> i.e. ignoring the orographic effect on the area + !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The dA_msl_proj field - function get_dA_msl_proj(mesh_id) result(dA_msl_proj) + function get_dA_msl_proj(config, mesh_id) result(dA_msl_proj) - use base_mesh_config_mod, only: geometry, geometry_spherical - use extrusion_config_mod, only: planet_radius, domain_height use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type implicit none - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + integer(kind=i_def) :: local_mesh_id type(mesh_type), pointer :: mesh type(mesh_type), pointer :: prime_mesh @@ -891,6 +952,14 @@ contains type(function_space_type), pointer :: fs integer(tik) :: id + integer(i_def) :: geometry + real(r_def) :: planet_radius + real(r_def) :: domain_height + + geometry = config%base_mesh%geometry() + planet_radius = config%extrusion%planet_radius() + domain_height = config%extrusion%domain_height() + ! Initialise inventory if it hasn't been done so already if (.not. dA_msl_proj_inventory%is_initialised()) then call dA_msl_proj_inventory%initialise(name="dA_msl_proj") @@ -923,20 +992,23 @@ contains end function get_dA_msl_proj + ! ========================================================================== ! ! PHYSICAL COORDINATES OF DOFs ! ========================================================================== ! - !> @brief Returns a pointer to the longitude of finite element DoFs + !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the longitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The longitude field - function get_longitude_fe(space_id, mesh_id) result(long_ptr) + function get_longitude_fe(config, space_id, mesh_id) result(long_ptr) implicit none - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(local_mesh_type), pointer :: local_mesh type(inventory_by_local_mesh_type), pointer :: long_inventory @@ -945,9 +1017,14 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - long_ptr => get_longitude_fv(space_id, mesh_id) + if (order_h == 0 .and. order_v == 0) then + long_ptr => get_longitude_fv(config, space_id, mesh_id) return end if @@ -983,8 +1060,8 @@ contains constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.true.) + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.true.) end if call long_inventory%get_field(local_mesh, long_ptr) @@ -992,15 +1069,18 @@ contains end function get_longitude_fe !> @brief Returns a pointer to the longitude of finite volume DoFs + !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the longitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The longitude field - function get_longitude_fv(space_id, mesh_id) result(long_ptr) + function get_longitude_fv(config, space_id, mesh_id) result(long_ptr) implicit none - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(local_mesh_type), pointer :: local_mesh type(inventory_by_local_mesh_type), pointer :: long_inventory @@ -1041,22 +1121,26 @@ contains constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.false.) + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.false.) end if call long_inventory%get_field(local_mesh, long_ptr) end function get_longitude_fv + !> @brief Returns a pointer to the latitude of finite element DoFs + !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the latitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The latitude field - function get_latitude_fe(space_id, mesh_id) result(lat_ptr) + function get_latitude_fe(config, space_id, mesh_id) result(lat_ptr) implicit none + type(config_type), intent(in) :: config + integer(kind=i_def), intent(in) :: space_id integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh @@ -1067,9 +1151,14 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - lat_ptr => get_latitude_fv(space_id, mesh_id) + if (order_h == 0 .and. order_v == 0) then + lat_ptr => get_latitude_fv(config, space_id, mesh_id) return end if @@ -1105,24 +1194,29 @@ contains constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.true.) + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.true.) end if call lat_inventory%get_field(local_mesh, lat_ptr) end function get_latitude_fe + + !> @brief Returns a pointer to the latitude of finite volume DoFs + !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the latitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The latitude field - function get_latitude_fv(space_id, mesh_id) result(lat_ptr) + function get_latitude_fv(config, space_id, mesh_id) result(lat_ptr) implicit none - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(local_mesh_type), pointer :: local_mesh type(inventory_by_local_mesh_type), pointer :: long_inventory @@ -1163,31 +1257,33 @@ contains constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.false.) + call compute_latlon(config, long_inventory, lat_inventory, & + mesh, space_id, use_fe=.false.) end if call lat_inventory%get_field(local_mesh, lat_ptr) end function get_latitude_fv + !> @brief Returns a pointer to a finite element height field - !> @param[in] space The space of the desired height field - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] config Configuration object + !> @param[in] space_id The space of the desired height field + !> @param[in] mesh_id The ID of the mesh to get the object for !> @return A height field - function get_height_fe(space_id, mesh_id) result(height) + function get_height_fe(config, space_id, mesh_id) result(height) + use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type use sci_height_discontinuous_kernel_mod, & only: height_discontinuous_kernel_type - use base_mesh_config_mod, only: geometry - use finite_element_config_mod, only: coord_system - use planet_config_mod, only: scaled_radius implicit none - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(inventory_by_mesh_type), pointer :: inventory logical(kind=l_def) :: constant_exists @@ -1200,9 +1296,19 @@ contains character(len=str_def) :: inventory_name integer(tik) :: id + real(r_def) :: scaled_radius + integer(i_def) :: geometry, coord_system + integer(i_def) :: order_h, order_v + + order_h = config%finite_element%element_order_h() + order_v = config%finite_element%element_order_v() + coord_system = config%finite_element%coord_system() + geometry = config%base_mesh%geometry() + scaled_radius = config%planet%scaled_radius() + ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - height => get_height_fv(space_id, mesh_id) + if (order_h == 0 .and. order_v == 0) then + height => get_height_fv(config, space_id, mesh_id) return end if @@ -1245,9 +1351,10 @@ contains if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - space => function_space_collection%get_fs( & - mesh, element_order_h, element_order_v, space_id & - ) + space => function_space_collection%get_fs(mesh, & + order_h, & + order_v, & + space_id) call inventory%add_field(height, space, mesh) select case (space_id) @@ -1286,23 +1393,24 @@ contains end function get_height_fe + !> @brief Returns a pointer to a finite volume height field - !> @param[in] space The space of the desired height field - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] config Configuration object + !> @param[in] space_id The space of the desired height field + !> @param[in] mesh_id The ID of the mesh to get the object for !> @return A height field - function get_height_fv(space_id, mesh_id) result(height) + function get_height_fv(config, space_id, mesh_id) result(height) use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type use sci_height_discontinuous_kernel_mod, & only: height_discontinuous_kernel_type - use base_mesh_config_mod, only: geometry - use finite_element_config_mod, only: coord_system - use planet_config_mod, only: scaled_radius implicit none - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id + type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh type(inventory_by_mesh_type), pointer :: inventory logical(kind=l_def) :: constant_exists @@ -1315,6 +1423,13 @@ contains character(len=str_def) :: inventory_name integer(tik) :: id + real(r_def) :: scaled_radius + integer(i_def) :: geometry, coord_system + + coord_system = config%finite_element%coord_system() + geometry = config%base_mesh%geometry() + scaled_radius = config%planet%scaled_radius() + ! Determine inventory based on space select case (space_id) case (W0) @@ -1393,6 +1508,7 @@ contains end function get_height_fv + ! ========================================================================== ! ! FACE SELECTORS ! ========================================================================== ! diff --git a/components/science/source/algorithm/sci_mapping_constants_mod.x90 b/components/science/source/algorithm/sci_mapping_constants_mod.x90 index 54aa2f101..582c9bf74 100644 --- a/components/science/source/algorithm/sci_mapping_constants_mod.x90 +++ b/components/science/source/algorithm/sci_mapping_constants_mod.x90 @@ -48,7 +48,7 @@ module sci_mapping_constants_mod element_order_v ! Other algorithms - use sci_geometric_constants_mod, only: get_coordinates, & + use sci_geometric_constants_mod, only: get_coordinates, & get_panel_id ! Kernels diff --git a/components/science/source/kernel/geometry/new_sci_chi_transform_mod.F90 b/components/science/source/kernel/geometry/new_sci_chi_transform_mod.F90 deleted file mode 100644 index 219be0180..000000000 --- a/components/science/source/kernel/geometry/new_sci_chi_transform_mod.F90 +++ /dev/null @@ -1,637 +0,0 @@ -!------------------------------------------------------------------------------- -! (c) Crown copyright 2021 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 Routines for transforming the chi coordinate fields -!! -!! @details Contains routines for conversion of chi coordinate fields. These -!! are accessed through the chi2ABC interface functions, so that -!! which coord_system chi is in, it will convert the -!! coordinates to the ABC system -!------------------------------------------------------------------------------ -module new_sci_chi_transform_mod - -use constants_mod, only : r_def, i_def, l_def, & - str_def, EPS, PI, rmdi -use coord_transform_mod, only : alphabetar2xyz, & - alphabetar2llr, & - xyz2alphabetar, & - llr2xyz, xyz2llr, & - xyz2ll, & - mesh_rotation_matrix, & - schmidt_transform_xyz, & - inverse_schmidt_transform_xyz -use log_mod, only : log_event, & - log_scratch_space, & - LOG_LEVEL_ERROR, & - LOG_LEVEL_DEBUG, & - LOG_LEVEL_WARNING -use matrix_invert_mod, only : matrix_invert_3x3 - -! Configuration modules -use base_mesh_config_mod, only: geometry_spherical, & - geometry_planar, & - topology_fully_periodic -use finite_element_config_mod, only: coord_system_xyz, & - coord_system_native - -implicit none - -private - -! ---------------------------------------------------------------------------- ! -! Private matrices or values that need computing once -! ---------------------------------------------------------------------------- ! - -real(kind=r_def) :: chi2xyz_rot_mat(3,3) -real(kind=r_def) :: xyz2chi_rot_mat(3,3) -real(kind=r_def) :: stretch_factor -logical(kind=l_def) :: to_rotate -logical(kind=l_def) :: to_stretch - -! ---------------------------------------------------------------------------- ! -! Public subroutines -! ---------------------------------------------------------------------------- ! -public :: init_chi_transforms -public :: final_chi_transforms -public :: chi2xyz -public :: chi2abr -public :: chi2llr -public :: chir2xyz -public :: get_mesh_rotation_matrix -public :: get_inverse_mesh_rotation_matrix -public :: get_stretch_factor -public :: get_to_rotate -public :: get_to_stretch - -!------------------------------------------------------------------------------ -! Contained functions / subroutines -!------------------------------------------------------------------------------ -contains - -!------------------------------------------------------------------------------ -!> @brief Initialise the coordinate transform information -!! -!> @param[in] geometry -!> @param[in] topology -!> @param[in] mesh_collection Optional: a collection of meshes, which contain -!! metadata used to determine the rotation matrix -!! and stretching factors. -!> @param[in] north_pole_arg Optional: target north pole, used to generate -!! the rotation matrix. This is incompatible with -!! the mesh_collection argument, and ideally -!! should only be used for unit-testing. -!> @param[in] equator_lat_arg Optional: Latitude of the equator of the mesh, -!! allowing a stretching to be described. -!! This is incompatible with the mesh_collection -!! argument, and ideally should only be used for -!! unit-testing. -!------------------------------------------------------------------------------ -subroutine init_chi_transforms( geometry, & - topology, & - mesh_collection, & - north_pole_arg, equator_lat_arg ) - - use local_mesh_mod, only: local_mesh_type - use mesh_collection_mod, only: mesh_collection_type - use mesh_mod, only: mesh_type - - implicit none - - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - - type(mesh_collection_type), optional, intent(in) :: mesh_collection - real(kind=r_def), optional, intent(in) :: north_pole_arg(2) - real(kind=r_def), optional, intent(in) :: equator_lat_arg - - type(mesh_type), pointer :: mesh - type(local_mesh_type), pointer :: local_mesh - character(str_def), allocatable :: all_mesh_names(:) - - real(kind=r_def) :: north_pole(2) - real(kind=r_def) :: null_island(2) - real(kind=r_def) :: equatorial_latitude - - ! -------------------------------------------------------------------------- ! - ! Extract stretching and rotation information from mesh - ! -------------------------------------------------------------------------- ! - ! Begin by assuming no stretching and no rotation - to_stretch = .false. - to_rotate = .false. - north_pole(1) = PI - north_pole(2) = PI/2.0_r_def - null_island(1) = 0.0_r_def - null_island(2) = 0.0_r_def - equatorial_latitude = 0.0_r_def - - if ( present(mesh_collection) .and. & - (present(equator_lat_arg) .or. present(north_pole_arg)) ) then - call log_event( & - 'init_chi_transform: mesh_compatible argument cannot be passed with ' // & - 'another argument', LOG_LEVEL_ERROR & - ) - end if - - if (present(mesh_collection)) then - ! NB: - ! At this stage, we will assume that the stretching and rotation are the same - ! for all meshes. If they weren't, we would need to extract a different factor - ! and different rotation matrix for each mesh. The chi2*** transforms would - ! also need to take mesh_id as an argument, which would be a major API change - ! since it would need passing through each kernel. - ! Therefore, extract first mesh from collection ... - all_mesh_names = mesh_collection%get_mesh_names() - if (SIZE(all_mesh_names) > 0) then - mesh => mesh_collection%get_mesh(all_mesh_names(1)) - else - call log_event( & - 'init_chi_transform: unable to determine mesh rotation and ' // & - 'stretching because there are no meshes!', LOG_LEVEL_ERROR & - ) - end if - - ! Extract rotation and stretching information from global mesh - local_mesh => mesh%get_local_mesh() - north_pole = local_mesh%get_north_pole() - null_island = local_mesh%get_null_island() - equatorial_latitude = local_mesh%get_equatorial_latitude() - - ! If any variables are unset, set them to defaults here -------------------- - if ( abs(north_pole(1) - rmdi) < EPS & - .or. abs(north_pole(2) - rmdi) < EPS ) then - north_pole(1) = 0.0_r_def - north_pole(2) = PI/2.0_r_def - call log_event( & - 'Mesh North Pole not set, so using (lon=0, lat=pi/2) as default', & - LOG_LEVEL_WARNING & - ) - end if - if ( abs(null_island(1) - rmdi) < EPS & - .or. abs(null_island(2) - rmdi) < EPS ) then - null_island(1) = 0.0_r_def - null_island(2) = 0.0_r_def - call log_event( & - 'Mesh Null Island not set, so using (lon=0, lat=0) as default', & - LOG_LEVEL_WARNING & - ) - end if - if ( abs(equatorial_latitude - rmdi) < EPS .or. & - geometry == geometry_planar .or. topology /= topology_fully_periodic ) then - equatorial_latitude = 0.0_r_def - call log_event( & - 'Equatorial latitude for mesh not set, so using 0.0 as default', & - LOG_LEVEL_WARNING & - ) - end if - end if ! present(mesh_collection) - - if (present(north_pole_arg)) north_pole = north_pole_arg - if (present(equator_lat_arg)) equatorial_latitude = equator_lat_arg - - - ! Now that parameters have been read in, determine if stretching or rotation - ! are actually happening - to_stretch = abs(equatorial_latitude) > EPS - ! It's probably safer to check both the null island and the north pole here - to_rotate = ( abs(north_pole(2) - PI/2.0_r_def) > EPS & - .or. abs(null_island(1)) > EPS .or. abs(null_island(2)) > EPS ) - - ! Compute Schmidt stretch factor --------------------------------------------- - stretch_factor = sqrt( (1.0_r_def - sin(equatorial_latitude)) & - / (1.0_r_def + sin(equatorial_latitude)) ) - - ! Compute rotation matrix ---------------------------------------------------- - chi2xyz_rot_mat = mesh_rotation_matrix(north_pole) - - ! Compute inverse rotation matrix -------------------------------------------- - xyz2chi_rot_mat = matrix_invert_3x3(chi2xyz_rot_mat) - - write(log_scratch_space,'(A,L6,A,2E16.8)') & - 'Mesh rotation: ', to_rotate, ' north pole: ', north_pole(1), north_pole(2) - call log_event(log_scratch_space, LOG_LEVEL_DEBUG) - write(log_scratch_space,'(A,L6,A,E16.8,A,E16.8)') & - 'Mesh stretching: ', to_stretch, ' stretching factor: ', stretch_factor, & - ' latitude of equator: ', equatorial_latitude - call log_event(log_scratch_space, LOG_LEVEL_DEBUG) - -end subroutine init_chi_transforms - -!------------------------------------------------------------------------------ -!> @brief Nullify the coordinate transform values -!------------------------------------------------------------------------------ -subroutine final_chi_transforms() - - implicit none - - to_stretch = .false. - to_rotate = .false. - stretch_factor = rmdi - chi2xyz_rot_mat(:,:) = 0.0_r_def - xyz2chi_rot_mat(:,:) = 0.0_r_def - -end subroutine final_chi_transforms - - -!------------------------------------------------------------------------------- -!> @brief Transforms a coordinate field chi from any system into global -!> Cartesian (X,Y,Z) coordinates. If chi is in a spherical coordinate -!> system, the third coordinate should be height, and the scaled_radius -!> will be added to the height to give the radius before the coordinates -!> are transformed to (X,Y,Z) coordinates. -!! -!! @param[in] chi_1 The first coordinate field in -!! @param[in] chi_2 The second coordinate field in -!! @param[in] chi_3 The third coordinate field in -!! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[in] scaled_radius -!! @param[in] panel_id The mesh panel ID -!! @param[out] x The first coordinate field out (global Cartesian X) -!! @param[out] y The second coordinate field out (global Cartesian Y) -!! @param[out] z The third coordinate field out (global Cartesian Z) -!------------------------------------------------------------------------------- -subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - x, y, z ) - - implicit none - - integer(kind=i_def), intent(in) :: panel_id - real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 - real(kind=r_def), intent(out) :: x, y, z - - real(kind=r_def) :: xyz(3) - - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system - real(r_def), intent(in) :: scaled_radius - - if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then - ! chi already uses (geocentric) Cartesian coordinates - x = chi_1 - y = chi_2 - z = chi_3 - - else if (topology /= topology_fully_periodic) then - ! domain is a spherical LAM, using (lon,lat,z) coordinates - call llr2xyz(chi_1, chi_2, chi_3+scaled_radius, x, y, z) - - if (to_rotate) then - xyz(1) = x - xyz(2) = y - xyz(3) = z - - xyz = matmul(chi2xyz_rot_mat, xyz) - - x = xyz(1) - y = xyz(2) - z = xyz(3) - end if - - else - ! cubed-sphere coordinates - ! transform to native (X,Y,Z) coordinates - call alphabetar2xyz(chi_1, chi_2, chi_3+scaled_radius, panel_id, x, y, z) - - ! stretch, if necessary - if (to_stretch) then - xyz(1) = x - xyz(2) = y - xyz(3) = z - - xyz = schmidt_transform_xyz(xyz, stretch_factor) - - x = xyz(1) - y = xyz(2) - z = xyz(3) - end if - - ! rotate, if necessary - if (to_rotate) then - xyz(1) = x - xyz(2) = y - xyz(3) = z - - xyz = matmul(chi2xyz_rot_mat, xyz) - - x = xyz(1) - y = xyz(2) - z = xyz(3) - end if - end if - -end subroutine chi2xyz - - -!------------------------------------------------------------------------------- -!> @brief Transforms a coordinate field chi from any system into global -!> Cartesian (X,Y,Z) coordinates. If chi is in a spherical coordinate -!> system, the third coordinate should be radius (distinguishing this -!> function from chi2xyz above). Therefore this will not add the -!> scaled_radius to transform. -!! -!! @param[in] chi_1 The first coordinate field in -!! @param[in] chi_2 The second coordinate field in -!! @param[in] chi_3 The third coordinate field in -!! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[out] x The first coordinate field out (global Cartesian X) -!! @param[out] y The second coordinate field out (global Cartesian Y) -!! @param[out] z The third coordinate field out (global Cartesian Z) -!------------------------------------------------------------------------------- -subroutine chir2xyz( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, coord_system, & - x, y, z ) - - implicit none - - integer(kind=i_def), intent(in) :: panel_id - real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 - real(kind=r_def), intent(out) :: x, y, z - - real(kind=r_def) :: xyz(3) - - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system - - if (coord_system == coord_system_xyz .or. geometry == geometry_planar) then - ! chi already uses (geocentric) Cartesian coordinates - x = chi_1 - y = chi_2 - z = chi_3 - - else if (topology /= topology_fully_periodic) then - ! domain is a spherical LAM, using (lon,lat,z) coordinates - call llr2xyz(chi_1, chi_2, chi_3, x, y, z) - - if (to_rotate) then - xyz(1) = x - xyz(2) = y - xyz(3) = z - - xyz = matmul(chi2xyz_rot_mat, xyz) - - x = xyz(1) - y = xyz(2) - z = xyz(3) - end if - - else - ! cubed-sphere coordinates - ! transform to native (X,Y,Z) coordinates - call alphabetar2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) - - ! stretch, if necessary - if (to_stretch) then - xyz(1) = x - xyz(2) = y - xyz(3) = z - - xyz = schmidt_transform_xyz(xyz, stretch_factor) - - x = xyz(1) - y = xyz(2) - z = xyz(3) - end if - - ! rotate, if necessary - if (to_rotate) then - xyz(1) = x - xyz(2) = y - xyz(3) = z - - xyz = matmul(chi2xyz_rot_mat, xyz) - - x = xyz(1) - y = xyz(2) - z = xyz(3) - end if - end if - -end subroutine chir2xyz - - -!------------------------------------------------------------------------------- -!> @brief Transforms a coordinate field chi from any system into spherical polar -!> (longitude, latitude, radius) coordinates -!! -!! @param[in] chi_1 The first coordinate field in -!! @param[in] chi_2 The second coordinate field in -!! @param[in] chi_3 The third coordinate field in -!! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[in] scaled_radius -!! @param[out] longitude The first coordinate field out (longitude) -!! @param[out] latitude The second coordinate field out (latitude) -!! @param[out] radius The third coordinate field out (radius) -!------------------------------------------------------------------------------- -subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - lon, lat, radius ) - - implicit none - - integer(kind=i_def), intent(in) :: panel_id - real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 - real(kind=r_def), intent(out) :: lon, lat, radius - - real(kind=r_def) :: xyz(3) - - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system - real(r_def), intent(in) :: scaled_radius - - if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then - ! chi uses (geocentric) Cartesian coordinates - call xyz2llr(chi_1, chi_2, chi_3, lon, lat, radius) - - else if (topology /= topology_fully_periodic) then - ! domain is a spherical LAM, already using (lon,lat,z) coordinates - ! may need to rotate these to the physical (lon,lat) coordinates - - ! avoid conversions in computing radius - radius = chi_3 + scaled_radius - - if (to_rotate) then - call llr2xyz(chi_1, chi_2, radius, xyz(1), xyz(2), xyz(3)) - xyz = matmul(chi2xyz_rot_mat, xyz) - call xyz2ll(xyz(1), xyz(2), xyz(3), lon, lat) - else - lon = chi_1 - lat = chi_2 - end if - - else - ! cubed-sphere coordinates - ! transform to native (X,Y,Z) coordinates - radius = chi_3 + scaled_radius - - if (to_stretch .or. to_rotate) then - call alphabetar2xyz(chi_1, chi_2, radius, panel_id, xyz(1), xyz(2), xyz(3)) - - ! stretch, if necessary - if (to_stretch) then - xyz = schmidt_transform_xyz(xyz, stretch_factor) - end if - - ! rotate, if necessary - if (to_rotate) then - xyz = matmul(chi2xyz_rot_mat, xyz) - end if - - ! convert to spherical polar coordinates - call xyz2ll(xyz(1), xyz(2), xyz(3), lon, lat) - - else - call alphabetar2llr(chi_1, chi_2, radius, panel_id, lon, lat) - end if - - end if - -end subroutine chi2llr - - -!------------------------------------------------------------------------------- -!> @brief Transforms a coordinate field chi from any system into *native* -!! equiangular cubed sphere (alpha,beta,radius) coordinates -!! -!! @param[in] chi_1 The first coordinate field in -!! @param[in] chi_2 The second coordinate field in -!! @param[in] chi_3 The third coordinate field in -!! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[in] scaled_radius -!! @param[out] alpha The first coordinate field out (alpha) -!! @param[out] beta The second coordinate field out (beta) -!! @param[out] radius The third coordinate field out (radius) -!------------------------------------------------------------------------------- -subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - alpha, beta, radius ) - - implicit none - - integer(kind=i_def), intent(in) :: panel_id - real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 - real(kind=r_def), intent(out) :: alpha, beta, radius - - real(kind=r_def) :: xyz(3) - - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system - real(r_def), intent(in) :: scaled_radius - - if (topology /= topology_fully_periodic .or. geometry /= geometry_spherical) then - - call log_event( 'chi2abr can only be used on cubed-sphere meshes', & - LOG_LEVEL_ERROR ) - - else if (coord_system == coord_system_native) then - alpha = chi_1 - beta = chi_2 - radius = chi_3 + scaled_radius - - else - ! geocentric Cartesian coordinates - xyz(1) = chi_1 - xyz(2) = chi_2 - xyz(3) = chi_3 - - ! un-rotate, if necessary - if (to_rotate) then - xyz = matmul(xyz2chi_rot_mat, xyz) - end if - - ! un-stretch, if necessary - if (to_stretch) then - xyz = inverse_schmidt_transform_xyz(xyz, stretch_factor) - end if - - ! transform to equiangular cubed-sphere coordinates - call xyz2alphabetar(xyz(1), xyz(2), xyz(3), panel_id, alpha, beta, radius) - end if - -end subroutine chi2abr - -!------------------------------------------------------------------------------- -!> @brief Returns a pointer to the rotation matrix for transforming from the -!! native Cartesian coordinates to the physical Cartesian coordinates -!------------------------------------------------------------------------------- -function get_mesh_rotation_matrix() result(rot_mat) - - implicit none - real(kind=r_def) :: rot_mat(3,3) - - rot_mat = chi2xyz_rot_mat - -end function get_mesh_rotation_matrix - -!------------------------------------------------------------------------------- -!> @brief Returns a pointer to the inverse rotation matrix, transforming from -!! physical Cartesian coordinates to native Cartesian coordinates -!------------------------------------------------------------------------------- -function get_inverse_mesh_rotation_matrix() result(rot_mat) - - implicit none - real(kind=r_def) :: rot_mat(3,3) - - rot_mat = xyz2chi_rot_mat - -end function get_inverse_mesh_rotation_matrix - -!------------------------------------------------------------------------------- -!> @brief Returns the Schmidt transform stretch factor -!------------------------------------------------------------------------------- -function get_stretch_factor() result(stretch_factor_out) - - implicit none - real(kind=r_def) :: stretch_factor_out - - stretch_factor_out = stretch_factor - -end function get_stretch_factor - -!------------------------------------------------------------------------------- -!> @brief Returns whether coordinates are rotated -!------------------------------------------------------------------------------- -function get_to_rotate() result(to_rotate_out) - - implicit none - logical(kind=l_def) :: to_rotate_out - - to_rotate_out = to_rotate - -end function get_to_rotate - -!------------------------------------------------------------------------------- -!> @brief Returns whether coordinates are stretched -!------------------------------------------------------------------------------- -function get_to_stretch() result(to_stretch_out) - - implicit none - logical(kind=l_def) :: to_stretch_out - - to_stretch_out = to_stretch - -end function get_to_stretch - -end module new_sci_chi_transform_mod - diff --git a/components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 b/components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 deleted file mode 100644 index d14d1e09f..000000000 --- a/components/science/source/kernel/geometry/new_sci_compute_latlon_kernel_mod.F90 +++ /dev/null @@ -1,142 +0,0 @@ -!----------------------------------------------------------------------------- -! (C) Crown copyright 2019 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 Returns latitude and longitude fields -!> -module new_sci_compute_latlon_kernel_mod - - use argument_mod, only: arg_type, func_type, & - GH_FIELD, GH_SCALAR, & - GH_INTEGER, GH_REAL, & - GH_WRITE, GH_READ, & - ANY_SPACE_1, & - ANY_DISCONTINUOUS_SPACE_3, & - ANY_SPACE_9, GH_BASIS, & - CELL_COLUMN, GH_EVALUATOR - use constants_mod, only: r_def, i_def - use kernel_mod, only: kernel_type - use new_sci_chi_transform_mod, only: chi2llr - - implicit none - - private - - !--------------------------------------------------------------------------- - ! Public types - !--------------------------------------------------------------------------- - !> Metadata describing the kernel to PSyclone - !> - type, public, extends(kernel_type) :: compute_latlon_kernel_type - private - type(arg_type) :: meta_args(8) = (/ & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & - 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_SCALAR, GH_INTEGER, GH_READ), &! geometry - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system - arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius - /) - - type(func_type) :: meta_funcs(1) = (/ & - func_type(ANY_SPACE_9, GH_BASIS) & - /) - integer :: operates_on = CELL_COLUMN - integer :: gh_shape = GH_EVALUATOR - contains - procedure, nopass :: compute_latlon_code - end type - - - !--------------------------------------------------------------------------- - ! Contained functions/subroutines - !--------------------------------------------------------------------------- - public :: compute_latlon_code - -contains - -!> @brief Calculates the latitude and longitude fields from the x, y and z components -!> @details Will only work at lowest order for now -!> @param[in] nlayers The number of layers (always 1) -!> @param[in,out] latitude Latitude field data -!> @param[in,out] longitude Longitude field data -!> @param[in] chi_1 First component of the coordinate field -!> @param[in] chi_2 Second component of the coordinate field -!> @param[in] chi_3 Third component of the coordinate field -!> @param[in] panel_id A field giving the ID for mesh panels -!> @param[in] geometry -!> @param[in] topology -!> @param[in] coord_system -!> @param[in] scaled_radius -!> @param[in] ndf_x Number of degrees of freedom per cell for height -!> @param[in] undf_x Number of unique degrees of freedom for height -!> @param[in] map_x Dofmap for the cell at the base of the column for height -!> @param[in] ndf_chi The number of degrees of freedom per cell for chi -!> @param[in] undf_chi The 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] basis_chi Basis functions evaluated at nodal points for height -!> @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 -subroutine compute_latlon_code(nlayers, & - latitude, longitude, & - chi_1, chi_2, chi_3, & - panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - ndf_x, undf_x, map_x, & - ndf_chi, undf_chi, map_chi, & - basis_chi, & - ndf_pid, undf_pid, map_pid & - ) - - implicit none - - ! Arguments - integer(kind=i_def), intent(in) :: nlayers - integer(kind=i_def), intent(in) :: ndf_x, undf_x - integer(kind=i_def), intent(in) :: ndf_chi, undf_chi - integer(kind=i_def), intent(in) :: ndf_pid, undf_pid - - real(kind=r_def), dimension(undf_x), intent(inout) :: latitude, longitude - 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 - - integer(kind=i_def), intent(in) :: geometry - integer(kind=i_def), intent(in) :: topology - integer(kind=i_def), intent(in) :: coord_system - real(kind=r_def), intent(in) :: scaled_radius - - integer(kind=i_def), dimension(ndf_x), intent(in) :: map_x - integer(kind=i_def), dimension(ndf_chi), intent(in) :: map_chi - integer(kind=i_def), dimension(ndf_pid), intent(in) :: map_pid - real(kind=r_def), dimension(1, ndf_chi, ndf_x), intent(in) :: basis_chi - - ! Internal variables - integer(kind=i_def) :: df_chi, df_x, k, ipanel - real(kind=r_def) :: coords(3), lat, lon, radius - - ipanel = int(panel_id(map_pid(1)), i_def) - - do k = 0, nlayers-1 - do df_x = 1, ndf_x - coords(:) = 0.0_r_def - do df_chi = 1, ndf_chi - coords(1) = coords(1) + chi_1(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) - coords(2) = coords(2) + chi_2(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) - coords(3) = coords(3) + chi_3(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) - end do - call chi2llr(coords(1), coords(2), coords(3), ipanel, & - geometry, topology, coord_system, scaled_radius, & - lon, lat, radius) - latitude(map_x(df_x) + k) = lat - longitude(map_x(df_x) + k) = lon - end do - end do - -end subroutine compute_latlon_code - -end module new_sci_compute_latlon_kernel_mod diff --git a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 index 39ccfe0fb..0d9f4a84b 100644 --- a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 +++ b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 @@ -30,15 +30,12 @@ module sci_chi_transform_mod LOG_LEVEL_WARNING use matrix_invert_mod, only : matrix_invert_3x3 -use base_mesh_config_mod, only : geometry, & - geometry_spherical, & - geometry_planar, & - topology, & - topology_fully_periodic -use finite_element_config_mod, only : coord_system, & - coord_system_xyz, & - coord_system_native -use planet_config_mod, only : scaled_radius +! Configuration modules +use base_mesh_config_mod, only: geometry_spherical, & + geometry_planar, & + topology_fully_periodic +use finite_element_config_mod, only: coord_system_xyz, & + coord_system_native implicit none @@ -77,6 +74,8 @@ module sci_chi_transform_mod !------------------------------------------------------------------------------ !> @brief Initialise the coordinate transform information !! +!> @param[in] geometry +!> @param[in] topology !> @param[in] mesh_collection Optional: a collection of meshes, which contain !! metadata used to determine the rotation matrix !! and stretching factors. @@ -90,13 +89,14 @@ module sci_chi_transform_mod !! argument, and ideally should only be used for !! unit-testing. !------------------------------------------------------------------------------ -subroutine init_chi_transforms( geometry, topology, & - mesh_collection, & +subroutine init_chi_transforms( geometry, & + topology, & + mesh_collection, & north_pole_arg, equator_lat_arg ) - use local_mesh_mod, only : local_mesh_type - use mesh_collection_mod, only : mesh_collection_type - use mesh_mod, only : mesh_type + use local_mesh_mod, only: local_mesh_type + use mesh_collection_mod, only: mesh_collection_type + use mesh_mod, only: mesh_type implicit none @@ -118,7 +118,6 @@ subroutine init_chi_transforms( geometry, topology, & ! -------------------------------------------------------------------------- ! ! Extract stretching and rotation information from mesh ! -------------------------------------------------------------------------- ! - ! Begin by assuming no stretching and no rotation to_stretch = .false. to_rotate = .false. @@ -187,7 +186,7 @@ subroutine init_chi_transforms( geometry, topology, & LOG_LEVEL_WARNING & ) end if - end if + end if ! present(mesh_collection) if (present(north_pole_arg)) north_pole = north_pole_arg if (present(equator_lat_arg)) equatorial_latitude = equator_lat_arg @@ -247,11 +246,19 @@ end subroutine final_chi_transforms !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius +!! @param[in] panel_id The mesh panel ID !! @param[out] x The first coordinate field out (global Cartesian X) !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- -subroutine chi2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) +subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + x, y, z ) implicit none @@ -261,6 +268,11 @@ subroutine chi2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) real(kind=r_def) :: xyz(3) + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then ! chi already uses (geocentric) Cartesian coordinates x = chi_1 @@ -329,11 +341,16 @@ end subroutine chi2xyz !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system !! @param[out] x The first coordinate field out (global Cartesian X) !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- -subroutine chir2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) +subroutine chir2xyz( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, coord_system, & + x, y, z ) implicit none @@ -343,6 +360,10 @@ subroutine chir2xyz(chi_1, chi_2, chi_3, panel_id, x, y, z) real(kind=r_def) :: xyz(3) + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + if (coord_system == coord_system_xyz .or. geometry == geometry_planar) then ! chi already uses (geocentric) Cartesian coordinates x = chi_1 @@ -408,11 +429,18 @@ end subroutine chir2xyz !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius !! @param[out] longitude The first coordinate field out (longitude) !! @param[out] latitude The second coordinate field out (latitude) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2llr(chi_1, chi_2, chi_3, panel_id, lon, lat, radius) +subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + lon, lat, radius ) implicit none @@ -422,6 +450,11 @@ subroutine chi2llr(chi_1, chi_2, chi_3, panel_id, lon, lat, radius) real(kind=r_def) :: xyz(3) + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then ! chi uses (geocentric) Cartesian coordinates call xyz2llr(chi_1, chi_2, chi_3, lon, lat, radius) @@ -480,11 +513,18 @@ end subroutine chi2llr !! @param[in] chi_2 The second coordinate field in !! @param[in] chi_3 The third coordinate field in !! @param[in] panel_id The mesh panel ID +!! @param[in] geometry +!! @param[in] topology +!! @param[in] coord_system +!! @param[in] scaled_radius !! @param[out] alpha The first coordinate field out (alpha) !! @param[out] beta The second coordinate field out (beta) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2abr(chi_1, chi_2, chi_3, panel_id, alpha, beta, radius) +subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + alpha, beta, radius ) implicit none @@ -494,10 +534,15 @@ subroutine chi2abr(chi_1, chi_2, chi_3, panel_id, alpha, beta, radius) real(kind=r_def) :: xyz(3) + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + if (topology /= topology_fully_periodic .or. geometry /= geometry_spherical) then - call log_event( & - 'chi2abr can only be used on cubed-sphere meshes', LOG_LEVEL_ERROR & - ) + + call log_event( 'chi2abr can only be used on cubed-sphere meshes', & + LOG_LEVEL_ERROR ) else if (coord_system == coord_system_native) then alpha = chi_1 @@ -531,6 +576,7 @@ end subroutine chi2abr !! native Cartesian coordinates to the physical Cartesian coordinates !------------------------------------------------------------------------------- function get_mesh_rotation_matrix() result(rot_mat) + implicit none real(kind=r_def) :: rot_mat(3,3) @@ -543,6 +589,7 @@ end function get_mesh_rotation_matrix !! physical Cartesian coordinates to native Cartesian coordinates !------------------------------------------------------------------------------- function get_inverse_mesh_rotation_matrix() result(rot_mat) + implicit none real(kind=r_def) :: rot_mat(3,3) @@ -554,6 +601,7 @@ end function get_inverse_mesh_rotation_matrix !> @brief Returns the Schmidt transform stretch factor !------------------------------------------------------------------------------- function get_stretch_factor() result(stretch_factor_out) + implicit none real(kind=r_def) :: stretch_factor_out @@ -565,6 +613,7 @@ end function get_stretch_factor !> @brief Returns whether coordinates are rotated !------------------------------------------------------------------------------- function get_to_rotate() result(to_rotate_out) + implicit none logical(kind=l_def) :: to_rotate_out @@ -576,6 +625,7 @@ end function get_to_rotate !> @brief Returns whether coordinates are stretched !------------------------------------------------------------------------------- function get_to_stretch() result(to_stretch_out) + implicit none logical(kind=l_def) :: to_stretch_out diff --git a/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 b/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 index 1ca3f2776..993c0aec4 100644 --- a/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 @@ -8,14 +8,16 @@ module sci_compute_latlon_kernel_mod use argument_mod, only: arg_type, func_type, & - GH_FIELD, GH_REAL, & + GH_FIELD, GH_SCALAR, & + GH_INTEGER, GH_REAL, & GH_WRITE, GH_READ, & - ANY_SPACE_1, & + ANY_SPACE_1, & ANY_DISCONTINUOUS_SPACE_3, & ANY_SPACE_9, GH_BASIS, & CELL_COLUMN, GH_EVALUATOR use constants_mod, only: r_def, i_def use kernel_mod, only: kernel_type + use sci_chi_transform_mod, only: chi2llr implicit none @@ -29,12 +31,17 @@ module sci_compute_latlon_kernel_mod !> type, public, extends(kernel_type) :: compute_latlon_kernel_type private - type(arg_type) :: meta_args(4) = (/ & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & + type(arg_type) :: meta_args(8) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & + arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & 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, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius /) + type(func_type) :: meta_funcs(1) = (/ & func_type(ANY_SPACE_9, GH_BASIS) & /) @@ -61,6 +68,10 @@ module sci_compute_latlon_kernel_mod !> @param[in] chi_2 Second component of the coordinate field !> @param[in] chi_3 Third component of the coordinate field !> @param[in] panel_id A field giving the ID for mesh panels +!> @param[in] geometry +!> @param[in] topology +!> @param[in] coord_system +!> @param[in] scaled_radius !> @param[in] ndf_x Number of degrees of freedom per cell for height !> @param[in] undf_x Number of unique degrees of freedom for height !> @param[in] map_x Dofmap for the cell at the base of the column for height @@ -75,6 +86,8 @@ subroutine compute_latlon_code(nlayers, & latitude, longitude, & chi_1, chi_2, chi_3, & panel_id, & + geometry, topology, & + coord_system, scaled_radius, & ndf_x, undf_x, map_x, & ndf_chi, undf_chi, map_chi, & basis_chi, & @@ -93,6 +106,11 @@ subroutine compute_latlon_code(nlayers, & 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 + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + integer(kind=i_def), intent(in) :: coord_system + real(kind=r_def), intent(in) :: scaled_radius + integer(kind=i_def), dimension(ndf_x), intent(in) :: map_x integer(kind=i_def), dimension(ndf_chi), intent(in) :: map_chi integer(kind=i_def), dimension(ndf_pid), intent(in) :: map_pid @@ -112,7 +130,9 @@ subroutine compute_latlon_code(nlayers, & coords(2) = coords(2) + chi_2(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) coords(3) = coords(3) + chi_3(map_chi(df_chi)+k)*basis_chi(1,df_chi,df_x) end do - call chi2llr(coords(1), coords(2), coords(3), ipanel, lon, lat, radius) + call chi2llr(coords(1), coords(2), coords(3), ipanel, & + geometry, topology, coord_system, scaled_radius, & + lon, lat, radius) latitude(map_x(df_x) + k) = lat longitude(map_x(df_x) + k) = lon end do diff --git a/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 b/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 index e98fee09e..965ecacff 100644 --- a/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 @@ -19,7 +19,7 @@ module sci_nodal_xyz_coordinates_kernel_mod GH_BASIS, CELL_COLUMN, & GH_EVALUATOR use constants_mod, only : r_def, i_def -use new_sci_chi_transform_mod, only : chi2xyz +use sci_chi_transform_mod, only : chi2xyz implicit none diff --git a/components/science/source/kernel/inter_function_space/new_sci_w3_to_w2_displacement_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/new_sci_w3_to_w2_displacement_kernel_mod.F90 deleted file mode 100644 index 3f07d9f84..000000000 --- a/components/science/source/kernel/inter_function_space/new_sci_w3_to_w2_displacement_kernel_mod.F90 +++ /dev/null @@ -1,231 +0,0 @@ -!----------------------------------------------------------------------------- -! (C) Crown copyright 2024 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 Calculates the effective horizontal displacement corresponding to the -!! error when averaging a W3 to W2 points. -!> @details Uses the coordinate fields to compute the displacement between a -!! W2 point and the effective averaging point when averaging a scalar -!! field from W3 to W2. Only intended to be used on the cubed-sphere. -!! This kernel is only designed for lowest order finite elements. -module new_sci_w3_to_w2_displacement_kernel_mod - - use argument_mod, only : arg_type, func_type, & - GH_FIELD, GH_SCALAR, & - GH_REAL, GH_INTEGER, & - GH_READ, GH_INC, & - ANY_DISCONTINUOUS_SPACE_3, & - GH_BASIS, GH_EVALUATOR, & - CELL_COLUMN, GH_SCALAR, & - GH_LOGICAL - use fs_continuity_mod, only : W3, W2H, Wchi - use constants_mod, only : r_def, i_def - use kernel_mod, only : kernel_type - use reference_element_mod, only : E, W, N, S - - implicit none - - private - - !------------------------------------------------------------------------------- - ! Public types - !------------------------------------------------------------------------------- - !> The type declaration for the kernel. Contains the metadata needed by the PSy layer - type, public, extends(kernel_type) :: w3_to_w2_displacement_kernel_type - private - type(arg_type) :: meta_args(8) = (/ & - arg_type(GH_FIELD, GH_REAL, GH_INC, W2H), & - arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & - arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & - arg_type(GH_FIELD, GH_REAL, GH_READ, W3), & - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system - arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius - /) - type(func_type) :: meta_funcs(1) = (/ & - func_type(Wchi, GH_BASIS) & - /) - integer :: operates_on = CELL_COLUMN - integer :: gh_shape = GH_EVALUATOR - integer :: gh_evaluator_targets(2) = (/ W2H, W3 /) - contains - procedure, nopass :: w3_to_w2_displacement_code - end type - - !------------------------------------------------------------------------------- - ! Contained functions/subroutines - !------------------------------------------------------------------------------- - public :: w3_to_w2_displacement_code - - contains - - !> @brief Calculates the effective horizontal displacement corresponding to - !! the error when averaging a W3 to W2 points - !> @param[in] nlayers Number of layers - !> @param[in,out] displacement 2D W2H field containing the displacements - !! corresponding to the averaging error. This is - !! dimensionless, being divided by the cell width - !> @param[in] chi_1 The first coordinate field - !> @param[in] chi_2 The second coordinate field - !> @param[in] chi_3 The third coordinate field - !> @param[in] panel_id ID for panels of the underlying mesh - !> @param[in] dummy_w3 An unused dummy field in W3 - !> @param[in] geometry - !> @param[in] topology - !> @param[in] coord_system - !> @param[in] scaled_radius - !> @param[in] ndf_w2h Number of DoFs for W2H per cell - !> @param[in] undf_w2h Number of unique DoFs for W2H per partition - !> @param[in] map_w2h The DoF map for bottom layer cells for W2H - !> @param[in] ndf_chi Number of DoFs for Wchi per cell - !> @param[in] undf_chi Number of unique DoFs for Wchi per partition - !> @param[in] map_chi The DoF map for bottom layer cells for Wchi - !> @param[in] basis_chi_w2h Wchi basis functions evaluated at W2H points - !> @param[in] basis_chi_w3 Wchi basis functions evaluated at W3 points - !> @param[in] ndf_pid Number of DoFs for panel id per cell - !> @param[in] undf_pid Number of unique DoFs for panel id per partition - !> @param[in] map_pid The DoF map for bottom layer cells for panel ID - !> @param[in] ndf_w3 Number of DoFs for W3 per cell - !> @param[in] undf_w3 Number of unique DoFs for W3 per partition - !> @param[in] map_w3 The DoF map for bottom layer cells for W3 - subroutine w3_to_w2_displacement_code( nlayers, & - displacement, & - chi_1, & - chi_2, & - chi_3, & - panel_id, & - dummy_w3, & - geometry, & - topology, & - coord_system, & - scaled_radius, & - ndf_w2h, & - undf_w2h, & - map_w2h, & - ndf_chi, & - undf_chi, & - map_chi, & - basis_chi_w2h, & - basis_chi_w3, & - ndf_pid, & - undf_pid, & - map_pid, & - ndf_w3, & - undf_w3, & - map_w3 ) - - use new_sci_chi_transform_mod, only: chi2abr - - implicit none - - ! Arguments - integer(kind=i_def), intent(in) :: nlayers - integer(kind=i_def), intent(in) :: ndf_w2h, undf_w2h - integer(kind=i_def), intent(in) :: ndf_chi, undf_chi - integer(kind=i_def), intent(in) :: ndf_pid, undf_pid - integer(kind=i_def), intent(in) :: ndf_w3, undf_w3 - integer(kind=i_def), intent(in) :: map_w2h(ndf_w2h) - integer(kind=i_def), intent(in) :: map_chi(ndf_chi) - integer(kind=i_def), intent(in) :: map_pid(ndf_pid) - integer(kind=i_def), intent(in) :: map_w3(ndf_w3) - - real(kind=r_def), intent(inout) :: displacement(undf_w2h) - real(kind=r_def), intent(in) :: chi_1(undf_chi) - real(kind=r_def), intent(in) :: chi_2(undf_chi) - real(kind=r_def), intent(in) :: chi_3(undf_chi) - real(kind=r_def), intent(in) :: panel_id(undf_pid) - real(kind=r_def), intent(in) :: dummy_w3(undf_w3) - real(kind=r_def), intent(in) :: basis_chi_w2h(1,ndf_chi,ndf_w2h) - real(kind=r_def), intent(in) :: basis_chi_w3(1,ndf_chi,ndf_w3) - - integer(kind=i_def), intent(in) :: geometry - integer(kind=i_def), intent(in) :: topology - integer(kind=i_def), intent(in) :: coord_system - real(kind=r_def), intent(in) :: scaled_radius - - ! Vertical cell index - integer(kind=i_def) :: df_w2h, df_w3, df_chi - integer(kind=i_def) :: ipanel - real(kind=r_def) :: cell_width_opposite, cell_half_width_adjacent - real(kind=r_def) :: alpha_w3, beta_w3, dummy_r - real(kind=r_def) :: alpha_w2h(4), beta_w2h(4) - real(kind=r_def) :: chi1_at_dof, chi2_at_dof, chi3_at_dof - real(kind=r_def) :: e_alpha(3), e_beta(3) - real(kind=r_def) :: phi, varrho - - ipanel = int(panel_id(map_pid(1)), i_def) - - ! The output field is 2D so we can ignore layers - - ! Get alpha and beta values at each DoF - ! W3 points ---------------------------------------------------------------- - chi1_at_dof = 0.0_r_def - chi2_at_dof = 0.0_r_def - chi3_at_dof = 0.0_r_def - ! Get chi at this point and then transform to alpha/beta coords - df_w3 = 1 - do df_chi = 1, ndf_chi - chi1_at_dof = chi1_at_dof + & - basis_chi_w3(1,df_chi,df_w3) * chi_1(map_chi(df_chi)) - chi2_at_dof = chi2_at_dof + & - basis_chi_w3(1,df_chi,df_w3) * chi_2(map_chi(df_chi)) - chi3_at_dof = chi3_at_dof + & - basis_chi_w3(1,df_chi,df_w3) * chi_3(map_chi(df_chi)) - end do - call chi2abr(chi1_at_dof, chi2_at_dof, chi3_at_dof, ipanel, & - geometry, topology, coord_system, scaled_radius, & - alpha_w3, beta_w3, dummy_r) - - ! W2H points --------------------------------------------------------------- - do df_w2h = 1, 4 - chi1_at_dof = 0.0_r_def - chi2_at_dof = 0.0_r_def - chi3_at_dof = 0.0_r_def - ! Get chi at this point and then transform to alpha/beta coords - df_w3 = 1 - do df_chi = 1, ndf_chi - chi1_at_dof = chi1_at_dof + & - basis_chi_w2h(1,df_chi,df_w2h) * chi_1(map_chi(df_chi)) - chi2_at_dof = chi2_at_dof + & - basis_chi_w2h(1,df_chi,df_w2h) * chi_2(map_chi(df_chi)) - chi3_at_dof = chi3_at_dof + & - basis_chi_w2h(1,df_chi,df_w2h) * chi_3(map_chi(df_chi)) - end do - call chi2abr(chi1_at_dof, chi2_at_dof, chi3_at_dof, ipanel, & - geometry, topology, coord_system, scaled_radius, & - alpha_w2h(df_w2h), beta_w2h(df_w2h), dummy_r) - - end do - - ! Compute angle between basis functions ------------------------------------ - varrho = sqrt(1.0_r_def + (tan(alpha_w3))**2.0_r_def + (tan(beta_w3))**2.0_r_def) - e_alpha(1) = -tan(alpha_w3)*cos(beta_w3)/varrho - e_alpha(2) = 1.0_r_def/cos(beta_w3)/varrho - e_alpha(3) = -tan(alpha_w3)*sin(beta_w3)/varrho - e_beta(1) = -tan(beta_w3)*cos(alpha_w3)/varrho - e_beta(2) = -tan(beta_w3)*sin(alpha_w3)/varrho - e_beta(3) = 1.0_r_def/cos(alpha_w3)/varrho - phi = asin(dot_product(e_alpha, e_beta)) - - ! Compute contribution to displacement for each face ----------------------- - do df_w2h = 1, 4 - ! Take alpha / beta depending on the face - if (df_w2h == N .or. df_w2h == S) then - cell_half_width_adjacent = beta_w3 - beta_w2h(df_w2h) - cell_width_opposite = alpha_w2h(E) - alpha_w2h(W) - else - cell_half_width_adjacent = alpha_w3 - alpha_w2h(df_w2h) - cell_width_opposite = beta_w2h(N) - beta_w2h(S) - end if - - ! Half-factor for each side of the face -- could be rmultiplicity but - ! as this is on the cubed-sphere we can just take it to be 0.5 - displacement(map_w2h(df_w2h)) = displacement(map_w2h(df_w2h)) + & - 0.5_r_def * cell_half_width_adjacent * sin(phi) / cell_width_opposite - end do - - end subroutine w3_to_w2_displacement_code - -end module new_sci_w3_to_w2_displacement_kernel_mod diff --git a/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf b/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf index a408edcfa..aa7b748f6 100644 --- a/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf @@ -38,13 +38,13 @@ contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine setUp( this ) - use base_mesh_config_mod, only : geometry_planar, & - topology_fully_periodic - use new_sci_chi_transform_mod, only : init_chi_transforms - use finite_element_config_mod, only : cellshape_quadrilateral, & - coord_system_xyz - use feign_config_mod, only : feign_finite_element_config, & - feign_base_mesh_config + use base_mesh_config_mod, only: geometry_planar, & + topology_fully_periodic + use sci_chi_transform_mod, only: init_chi_transforms + use finite_element_config_mod, only: cellshape_quadrilateral, & + coord_system_xyz + use feign_config_mod, only: feign_finite_element_config, & + feign_base_mesh_config implicit none @@ -89,7 +89,7 @@ contains subroutine tearDown( this ) use config_loader_mod, only: final_configuration - use new_sci_chi_transform_mod, only: final_chi_transforms + use sci_chi_transform_mod, only: final_chi_transforms implicit none diff --git a/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf b/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf index 56c18b054..83d5aa391 100644 --- a/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf @@ -82,7 +82,7 @@ contains implicit none type(chi_parameters_type), intent(in) :: test_parameter - type(chi_transform_mod_test_type) :: new_test + type(chi_transform_mod_test_type) :: new_test new_test%source_coord_system = test_parameter%source_coord_system new_test%target_coord_system = test_parameter%target_coord_system @@ -240,7 +240,7 @@ contains class(chi_transform_mod_test_type), intent(inout) :: this - real(r_def) :: north_pole(2), equatorial_latitude + real(r_def) :: north_pole(2), equatorial_latitude select case ( this%source_coord_system ) case ( XYZ ) @@ -249,8 +249,7 @@ contains case ( LLH, LLH_rot ) this%src_coord_system = coord_system_native - this%topology = topology_non_periodic -! this%topology = topology_fully_periodic + this%topology = topology_non_periodic case ( ABH, ABH_stretch_rot ) this%src_coord_system = coord_system_native @@ -287,7 +286,7 @@ contains subroutine tearDown( this ) use sci_chi_transform_mod, only: final_chi_transforms - use config_loader_mod, only: final_configuration + use config_loader_mod, only: final_configuration implicit none @@ -302,7 +301,7 @@ contains @Test subroutine test_all( this ) - use sci_chi_transform_mod, only : chi2abr, chi2llr, chi2xyz, chir2xyz + use sci_chi_transform_mod, only: chi2abr, chi2llr, chi2xyz, chir2xyz implicit none @@ -313,16 +312,24 @@ contains select case ( this%target_coord_system ) case ( ABH ) call chi2abr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, new_coord_1, new_coord_2, new_coord_3) + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, this%scaled_radius, & + new_coord_1, new_coord_2, new_coord_3) case ( LLH ) call chi2llr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, this%scaled_radius, & + new_coord_1, new_coord_2, new_coord_3 ) case ( XYZ ) call chi2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, this%scaled_radius, & + new_coord_1, new_coord_2, new_coord_3 ) case ( R2XYZ ) call chir2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, new_coord_1, new_coord_2, new_coord_3 ) + this%panel_id, this%geometry, this%topology, & + this%src_coord_system, & + new_coord_1, new_coord_2, new_coord_3 ) end select ! Check if answers are correct diff --git a/components/science/unit-test/kernel/geometry/new_chi_transform_mod_test.pf b/components/science/unit-test/kernel/geometry/new_chi_transform_mod_test.pf deleted file mode 100644 index 88b6e6803..000000000 --- a/components/science/unit-test/kernel/geometry/new_chi_transform_mod_test.pf +++ /dev/null @@ -1,352 +0,0 @@ -!------------------------------------------------------------------------------- -! (c) Crown copyright 2021 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 new_chi_transform_mod_test - - use, intrinsic :: iso_fortran_env, only : real64 - - use constants_mod, only : i_def, r_def, str_long, PI, rmdi - - use base_mesh_config_mod, only: geometry_spherical, & - geometry_planar, & - topology_fully_periodic, & - topology_non_periodic - - use finite_element_config_mod, only: coord_system_native, & - coord_system_xyz - - use funit - - implicit none - - public :: new_chi_transform_mod_test_type, test_all, get_chi_parameters, & - test_chi_constructor - - @testParameter - type, public, extends(AbstractTestParameter) :: chi_parameters_type - integer(i_def) :: source_coord_system - integer(i_def) :: target_coord_system - integer(i_def) :: panel_id - real(r_def) :: source_chi_1 - real(r_def) :: source_chi_2 - real(r_def) :: source_chi_3 - real(r_def) :: target_chi_1 - real(r_def) :: target_chi_2 - real(r_def) :: target_chi_3 - contains - procedure :: toString - end type chi_parameters_type - - @TestCase(testParameters={get_chi_parameters()}, constructor=test_chi_constructor) - type, extends(ParameterizedTestCase) :: new_chi_transform_mod_test_type - private - integer(i_def) :: source_coord_system - integer(i_def) :: target_coord_system - integer(i_def) :: panel_id - real(r_def) :: source_chi_1 - real(r_def) :: source_chi_2 - real(r_def) :: source_chi_3 - real(r_def) :: target_chi_1 - real(r_def) :: target_chi_2 - real(r_def) :: target_chi_3 - - integer(i_def) :: src_coord_system - integer(i_def) :: topology - integer(i_def) :: geometry - real(r_def) :: scaled_radius - - contains - procedure setUp - procedure tearDown - procedure test_all - end type new_chi_transform_mod_test_type - - ! Add my own parameters for the different coordinate system cases - integer(i_def), parameter :: ABH = 1 - integer(i_def), parameter :: LLH = 2 - integer(i_def), parameter :: XYZ = 3 - integer(i_def), parameter :: R2XYZ = 4 - integer(i_def), parameter :: LLH_rot = 5 - integer(i_def), parameter :: ABH_stretch_rot = 6 - - real(r_def), parameter :: planet_radius = 14.0_r_def - real(r_def), parameter :: scaling = 1.0_r_def - -contains - - function test_chi_constructor( test_parameter ) result ( new_test ) - - implicit none - - type(chi_parameters_type), intent(in) :: test_parameter - type(new_chi_transform_mod_test_type) :: new_test - - new_test%source_coord_system = test_parameter%source_coord_system - new_test%target_coord_system = test_parameter%target_coord_system - new_test%panel_id = test_parameter%panel_id - new_test%source_chi_1 = test_parameter%source_chi_1 - new_test%source_chi_2 = test_parameter%source_chi_2 - new_test%source_chi_3 = test_parameter%source_chi_3 - new_test%target_chi_1 = test_parameter%target_chi_1 - new_test%target_chi_2 = test_parameter%target_chi_2 - new_test%target_chi_3 = test_parameter%target_chi_3 - - end function test_chi_constructor - - function toString( this ) result( output_string ) - - implicit none - - class( chi_parameters_type ), intent( in ) :: this - character(:), allocatable :: output_string - - character(:), allocatable :: source_string, target_string - - select case ( this%source_coord_system ) - case ( XYZ ) - source_string = 'XYZ' - case ( LLH ) - source_string = 'LLH' - case ( ABH ) - source_string = 'ABH' - case ( LLH_rot ) - source_string = 'LLH rot' - case ( ABH_stretch_rot ) - source_string = 'ABH stretch+rot' - end select - - select case ( this%target_coord_system ) - case ( XYZ ) - target_string = 'XYZ' - case ( LLH ) - target_string = 'LLH' - case ( ABH ) - target_string = 'ABH' - case ( R2XYZ ) - target_string = 'R2XYZ' - end select - - output_string = trim( source_string // '2' // target_string ) - - end function toString - - function get_chi_parameters() result ( chi_parameters ) - - implicit none - - type(chi_parameters_type) :: chi_parameters(15) - - integer(i_def) :: panel_id, pid_rot - real(r_def) :: radius, height - real(r_def) :: alpha, beta - real(r_def) :: alpha_sr, beta_sr - real(r_def) :: X, Y, Z - real(r_def) :: lon, lat - real(r_def) :: lon_rot, lat_rot - real(r_def) :: varrho - - ! Consider a particular point on the sphere - ! Give the coordinates for this point in each coordinate system - ! Try to choose non-trivial analytic values - panel_id = 2 - height = 5.0_r_def - radius = planet_radius + height - - ! Start with special choices of alpha and beta - alpha = PI / 6.0_r_def - beta = - PI / 12.0_r_def - - ! varrho is sqrt(1 + tan(alpha)**2 + tan(beta)**2) - ! For our alpha and beta, tan(alpha) = sqrt(3)/3 and tan(beta) = 2 - sqrt(3) - varrho = sqrt(25.0_r_def / 3.0_r_def - 4.0_r_def * sqrt(3.0_r_def)) - - ! for panel 2, x=-r*tan(alpha)/varrho, y=r/varrho, z=r*tan(beta)/varrho - X = -19.0_r_def*sqrt(3.0_r_def) / 3.0_r_def / varrho - Y = 19.0_r_def / varrho - Z = -19.0_r_def*(2.0_r_def - sqrt(3.0_r_def)) / varrho - - ! for panel 2, lon=pi/2 + alpha, lat=atan(tan(beta)/sqrt(1+tan(alpha)**2))) - lon = 2.0_r_def * PI / 3.0_r_def - lat = -atan(sqrt(3.0_r_def) * (2.0_r_def - sqrt(3.0_r_def)) / 2.0_r_def) - - ! Rotated lon, lat coordinates -- computed offline - ! Rotate north pole to (90, 0) - lon_rot = -2.0053150793200873_r_def - lat_rot = 1.0039712567034795_r_def - - ! Stretched and rotated alpha, beta coordinates -- computed offline - ! Rotate north pole to (-90, 0) and stretch factor of 1/sqrt(3) - pid_rot = 6 - alpha_sr = 0.14467932028782213_r_def - beta_sr = 0.30419085098985305_r_def - - ! The arguments below are the parameters defined in chi_parameters_type - - chi_parameters = [ chi_parameters_type(ABH, ABH, panel_id, & - alpha, beta, height, & - alpha, beta, radius), & - chi_parameters_type(ABH, LLH, panel_id, & - alpha, beta, height, & - lon, lat, radius), & - chi_parameters_type(ABH, XYZ, panel_id, & - alpha, beta, height, & - X, Y, Z), & - chi_parameters_type(ABH_stretch_rot, LLH, pid_rot, & - alpha_sr, beta_sr, height, & - lon, lat, radius), & - chi_parameters_type(ABH_stretch_rot, XYZ, pid_rot, & - alpha_sr, beta_sr, height, & - X, Y, Z), & - chi_parameters_type(LLH, LLH, panel_id, & - lon, lat, height, & - lon, lat, radius), & - chi_parameters_type(LLH, XYZ, panel_id, & - lon, lat, height, & - X, Y, Z), & - chi_parameters_type(LLH_rot, LLH, panel_id, & - lon_rot, lat_rot, height, & - lon, lat, radius), & - chi_parameters_type(LLH_rot, XYZ, panel_id, & - lon_rot, lat_rot, height, & - X, Y, Z), & - chi_parameters_type(XYZ, ABH, panel_id, & - X, Y, Z, & - alpha, beta, radius), & - chi_parameters_type(XYZ, LLH, panel_id, & - X, Y, Z, & - lon, lat, radius), & - chi_parameters_type(XYZ, XYZ, panel_id, & - X, Y, Z, X, Y, Z), & - chi_parameters_type(ABH, R2XYZ, panel_id, & - alpha, beta, radius, & - X, Y, Z), & - chi_parameters_type(LLH, R2XYZ, panel_id, & - lon, lat, radius, & - X, Y, Z), & - chi_parameters_type(XYZ, R2XYZ, panel_id, & - X, Y, Z, X, Y, Z) ] - - end function get_chi_parameters - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine setUp( this ) - - use new_sci_chi_transform_mod, only: init_chi_transforms - - implicit none - - class(new_chi_transform_mod_test_type), intent(inout) :: this - - real(r_def) :: north_pole(2), equatorial_latitude - - select case ( this%source_coord_system ) - case ( XYZ ) - this%src_coord_system = coord_system_xyz - this%topology = topology_fully_periodic - - case ( LLH, LLH_rot ) - this%src_coord_system = coord_system_native - this%topology = topology_non_periodic - - case ( ABH, ABH_stretch_rot ) - this%src_coord_system = coord_system_native - this%topology = topology_fully_periodic - end select - - this%geometry = geometry_spherical - this%scaled_radius = planet_radius*scaling - - if ( this%source_coord_system == LLH_rot ) then - north_pole(1) = PI/2.0_r_def - north_pole(2) = 0.0_r_def - call init_chi_transforms(this%geometry, & - this%topology, & - north_pole_arg=north_pole) - else if ( this%source_coord_system == ABH_stretch_rot ) then - north_pole(1) = -PI/2.0_r_def - north_pole(2) = 0.0_r_def - equatorial_latitude = PI/6.0_r_def - call init_chi_transforms(this%geometry, & - this%topology, & - north_pole_arg=north_pole, & - equator_lat_arg=equatorial_latitude) - else - ! Non-rotated or stretched case - call init_chi_transforms(this%geometry, & - this%topology) - - end if - - end subroutine setUp - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine tearDown( this ) - - use new_sci_chi_transform_mod, only: final_chi_transforms - use config_loader_mod, only: final_configuration - - implicit none - - class(new_chi_transform_mod_test_type), intent(inout) :: this - - call final_configuration() - call final_chi_transforms() - - end subroutine tearDown - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @Test - subroutine test_all( this ) - - use new_sci_chi_transform_mod, only: chi2abr, chi2llr, chi2xyz, chir2xyz - - implicit none - - class(new_chi_transform_mod_test_type), intent(inout) :: this - - real(kind=r_def) :: tol, new_coord_1, new_coord_2, new_coord_3 - - select case ( this%target_coord_system ) - case ( ABH ) - call chi2abr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, this%geometry, this%topology, & - this%src_coord_system, this%scaled_radius, & - new_coord_1, new_coord_2, new_coord_3) - case ( LLH ) - call chi2llr(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, this%geometry, this%topology, & - this%src_coord_system, this%scaled_radius, & - new_coord_1, new_coord_2, new_coord_3 ) - case ( XYZ ) - call chi2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, this%geometry, this%topology, & - this%src_coord_system, this%scaled_radius, & - new_coord_1, new_coord_2, new_coord_3 ) - case ( R2XYZ ) - call chir2xyz(this%source_chi_1, this%source_chi_2, this%source_chi_3, & - this%panel_id, this%geometry, this%topology, & - this%src_coord_system, & - new_coord_1, new_coord_2, new_coord_3 ) - end select - - ! Check if answers are correct - if ( r_def == real64 ) then - tol = 1e-12_r_def - @assertEqual( this%target_chi_1, new_coord_1, tol ) - @assertEqual( this%target_chi_2, new_coord_2, tol ) - @assertEqual( this%target_chi_3, new_coord_3, tol ) - else - tol = 10.0_r_def*spacing( new_coord_1 ) - @assertEqual( this%target_chi_1, new_coord_1, tol ) - tol = 10.0_r_def*spacing( new_coord_2 ) - @assertEqual( this%target_chi_2, new_coord_2, tol ) - tol = 10.0_r_def*spacing( new_coord_3 ) - @assertEqual( this%target_chi_3, new_coord_3, tol ) - end if - - end subroutine test_all - -end module new_chi_transform_mod_test diff --git a/components/science/unit-test/kernel/geometry/new_compute_latlon_kernel_mod_test.pf b/components/science/unit-test/kernel/geometry/new_compute_latlon_kernel_mod_test.pf deleted file mode 100644 index c3b71d6f0..000000000 --- a/components/science/unit-test/kernel/geometry/new_compute_latlon_kernel_mod_test.pf +++ /dev/null @@ -1,139 +0,0 @@ -!----------------------------------------------------------------------------- -! (C) Crown copyright 2019 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 new_compute_latlon_kernel_mod_test - - use constants_mod, only : i_def, r_def, pi, imdi, rmdi - use get_unit_test_m3x3_dofmap_mod, & - only : get_w3_m3x3_dofmap, get_wchi_m3x3_dofmap - use get_unit_test_m3x3_q3x3x3_sizes_mod, & - only : get_w3_m3x3_q3x3x3_size, get_wchi_m3x3_q3x3x3_size - use get_unit_test_q3x3x3_basis_mod, & - only : get_wchi_q3x3x3_basis - - use funit - - use finite_element_config_mod, only: coord_system_xyz - - implicit none - - private - public :: set_up, tear_down, test_all - - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @before - subroutine set_up() - - use new_sci_chi_transform_mod, only: init_chi_transforms - - implicit none - - call init_chi_transforms(imdi, imdi) - - end subroutine set_up - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @after - subroutine tear_down() - - use new_sci_chi_transform_mod, only: final_chi_transforms - - implicit none - - call final_chi_transforms() - - end subroutine tear_down - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @Test - subroutine test_all() - - use new_sci_compute_latlon_kernel_mod, only: compute_latlon_code - - implicit none - - real(r_def), parameter :: tol = 1.0e-12_r_def - integer(i_def), parameter :: nlayers = 1 - integer(i_def) :: k, df_w3 - - integer(i_def) :: ndf_w3, undf_w3, ndf_chi, undf_chi - integer(i_def) :: unused - integer(i_def), allocatable :: map_w3(:,:), map_chi(:,:) - real(r_def), allocatable :: chi_1(:), chi_2(:), chi_3(:), panel_id(:) - real(r_def), allocatable :: basis_chi(:,:,:,:) - - real(r_def), allocatable :: latitude(:), longitude(:) - real(r_def), allocatable :: lat_answer(:), lon_answer(:) - - integer(i_def), parameter :: geometry = imdi - integer(i_def), parameter :: topology = imdi - integer(i_def), parameter :: coord_system = coord_system_xyz - real(r_def), parameter :: scaled_radius = rmdi - - call get_w3_m3x3_q3x3x3_size( ndf_w3, undf_w3, unused, & - unused, unused, unused, & - unused, nlayers=nlayers) - call get_w3_m3x3_dofmap( map_w3 ) - call get_wchi_m3x3_q3x3x3_size( ndf_chi, undf_chi, unused, & - unused, unused, unused, & - unused, nlayers=nlayers) - call get_wchi_m3x3_dofmap( map_chi ) - - call get_wchi_q3x3x3_basis( basis_chi ) - - ! Test latlon kernel - allocate( latitude(undf_w3) ) - allocate( longitude(undf_w3) ) - allocate( chi_1(undf_chi) ) - allocate( chi_2(undf_chi) ) - allocate( chi_3(undf_chi) ) - allocate( panel_id(undf_w3) ) - allocate( lat_answer(undf_w3) ) - allocate( lon_answer(undf_w3) ) - - chi_1(:) = 1.0_r_def - chi_2(:) = 2.0_r_def - chi_3(:) = 1.0_r_def - panel_id(:) = 1.0_r_def - - ! Call the kernel - call compute_latlon_code(nlayers, & - latitude, longitude, & - chi_1, chi_2, chi_3, & - panel_id, & - geometry, & - topology, & - coord_system, & - scaled_radius, & - ndf_w3, undf_w3, map_w3(:,1), & - ndf_chi, undf_chi, map_chi(:,1), & - basis_chi(:,:,1,:), & - ndf_w3, undf_w3, map_w3 & - ) - - !Test the answer - k = 0 - df_w3 = 1 - lon_answer(map_w3(df_w3,1) + k) = 1.1071487177940904_r_def ! - lat_answer(map_w3(df_w3,1) + k) = 0.42053433528396511_r_def ! - @assertEqual(lat_answer(map_w3(df_w3,1) + k), latitude(map_w3(df_w3,1) + k), tol) - @assertEqual(lon_answer(map_w3(df_w3,1) + k), longitude(map_w3(df_w3,1) + k), tol) - - deallocate( latitude ) - deallocate( longitude ) - deallocate( chi_1 ) - deallocate( chi_2 ) - deallocate( chi_3 ) - deallocate( panel_id ) - deallocate( lat_answer ) - deallocate( lon_answer ) - - end subroutine test_all - -end module new_compute_latlon_kernel_mod_test diff --git a/components/science/unit-test/kernel/inter_function_space/new_w3_to_w2_displacement_kernel_mod_test.pf b/components/science/unit-test/kernel/inter_function_space/new_w3_to_w2_displacement_kernel_mod_test.pf deleted file mode 100644 index 18dea4c81..000000000 --- a/components/science/unit-test/kernel/inter_function_space/new_w3_to_w2_displacement_kernel_mod_test.pf +++ /dev/null @@ -1,175 +0,0 @@ -!----------------------------------------------------------------------------- -! (c) Crown copyright 2024 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 kernel to compute errors in W3 to W2 averaging -module new_w3_to_w2_displacement_kernel_mod_test - - use constants_mod, only: i_def, r_def, PI, l_def - use reference_element_mod, only: S, E, N, W - - use base_mesh_config_mod, only: geometry_spherical, & - topology_fully_periodic - use finite_element_config_mod, only: coord_system_native - - use funit - - - implicit none - - private - public :: set_up, tear_down, test_all - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @before - subroutine set_up() - - use sci_chi_transform_mod, only: init_chi_transforms - - implicit none - - call init_chi_transforms(geometry_spherical, topology_fully_periodic) - - end subroutine set_up - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @after - subroutine tear_down() - - use sci_chi_transform_mod, only: final_chi_transforms - - implicit none - - call final_chi_transforms() - - end subroutine tear_down - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - @test - subroutine test_all() - - use new_sci_w3_to_w2_displacement_kernel_mod, only: w3_to_w2_displacement_code - use get_unit_test_w2hnodal_basis_mod, only: get_wchi_w2hnodal_basis - use get_unit_test_w3nodal_basis_mod, only: get_wchi_w3nodal_basis - - implicit none - - real(r_def), parameter :: tol = 1.0e-2_r_def - real(r_def), parameter :: dalpha = 0.05_r_def - real(r_def), parameter :: dbeta = 0.05_r_def - real(r_def), parameter :: alpha0 = -PI/4.0_r_def - real(r_def), parameter :: beta0 = PI/6.0_r_def - real(r_def), parameter :: dz = 2.0_r_def - - integer(i_def), parameter :: geometry = geometry_spherical - integer(i_def), parameter :: topology = topology_fully_periodic - integer(i_def), parameter :: coord_system = coord_system_native - real(r_def), parameter :: scaled_radius = 1900000.0_r_def - - ! Non-periodic 3x3x3 domain - integer(i_def), parameter :: ncells = 2 - integer(i_def), parameter :: nlayers = 1 - integer(i_def), parameter :: ndf_w2h = 4 - integer(i_def), parameter :: undf_w2h = 7 - integer(i_def), parameter :: ndf_chi = 8 - integer(i_def), parameter :: undf_chi = ndf_chi*nlayers*ncells - integer(i_def), parameter :: ndf_w3 = 1 - integer(i_def), parameter :: undf_w3 = ncells*nlayers - integer(i_def) :: map_w2h(ndf_w2h,ncells) - integer(i_def) :: map_w3(ndf_w3,ncells) - integer(i_def) :: map_chi(ndf_chi,ncells) - real(r_def), allocatable :: basis_chi_w3(:,:,:) - real(r_def), allocatable :: basis_chi_w2h(:,:,:) - - ! Fields - real(r_def) :: displacement(undf_w2h) - real(r_def) :: chi_1(undf_chi) - real(r_def) :: chi_2(undf_chi) - real(r_def) :: chi_3(undf_chi) - real(r_def) :: panel_id(undf_w3) - real(r_def) :: dummy_w3(undf_w3) - real(r_def) :: answer, phi - - integer(i_def) :: cell - - ! ------------------------------------------------------------------------ ! - ! Make DoF maps - ! ------------------------------------------------------------------------ ! - ! Two cells - map_w3 = reshape([1 , 2], [ndf_w3, ncells]) - map_w2h = reshape([1, 2, 3, 4, 5, 1, 6, 7], [ndf_w2h, ncells]) - map_chi = reshape([1, 2, 3, 4, 5, 6, 7, 8, & - 9, 10, 11, 12, 13, 14, 15, 16], [ndf_chi, ncells]) - - ! ------------------------------------------------------------------------ ! - ! Get basis functions - ! ------------------------------------------------------------------------ ! - - call get_wchi_w3nodal_basis(basis_chi_w3) - call get_wchi_w2hnodal_basis(basis_chi_w2h) - - ! ------------------------------------------------------------------------ ! - ! Set up initial chi field - ! ------------------------------------------------------------------------ ! - - chi_1 = (/ alpha0, alpha0 + dalpha, alpha0, alpha0 + dalpha, & - alpha0, alpha0 + dalpha, alpha0, alpha0 + dalpha, & - beta0, beta0 + dbeta, beta0, beta0 + dbeta, & - beta0, beta0 + dbeta, beta0, beta0 + dbeta /) - chi_2 = (/ beta0, beta0, beta0 + dbeta, beta0 + dbeta, & - beta0, beta0, beta0 + dbeta, beta0 + dbeta, & - alpha0, alpha0, alpha0 + dalpha, alpha0 + dalpha, & - alpha0, alpha0, alpha0 + dalpha, alpha0 + dalpha /) - chi_3 = (/ 0.0_r_def, 0.0_r_def, 0.0_r_def, 0.0_r_def, dz, dz, dz, dz, & - 0.0_r_def, 0.0_r_def, 0.0_r_def, 0.0_r_def, dz, dz, dz, dz /) - panel_id(1) = 1.0_r_def - panel_id(2) = 4.0_r_def - - ! ------------------------------------------------------------------------ ! - ! Set up answer - ! ------------------------------------------------------------------------ ! - - ! Approximate angle between alpha and beta coordinates at (alpha0=-pi/4, beta0=pi/6) - phi = 0.361367_r_def - answer = 0.5_r_def*dalpha/dbeta*sin(phi) - - ! ------------------------------------------------------------------------ ! - ! Run - ! ------------------------------------------------------------------------ ! - - ! Initialise data - displacement(:) = 0.0_r_def - - do cell = 1, ncells - - call w3_to_w2_displacement_code( nlayers, & - displacement, & - chi_1, chi_2, chi_3, & - panel_id, & - dummy_w3, & - geometry, topology, & - coord_system, scaled_radius, & - ndf_w2h, undf_w2h, map_w2h(:,cell), & - ndf_chi, undf_chi, map_chi(:,cell), & - basis_chi_w2h, basis_chi_w3, & - ndf_w3, undf_w3, map_w3(:,cell), & - ndf_w3, undf_w3, map_w3(:,cell) ) - end do - - ! ------------------------------------------------------------------------ ! - ! Check - ! ------------------------------------------------------------------------ ! - - ! Only check the first DoF as this is the only shared value between panels - @assertEqual(answer, displacement(1), tol) - - deallocate(basis_chi_w3) - deallocate(basis_chi_w2h) - - end subroutine test_all - -end module new_w3_to_w2_displacement_kernel_mod_test From f08b8039a7d3b096f80b1d603b6384bfd4931af4 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Thu, 26 Mar 2026 14:49:18 +0000 Subject: [PATCH 18/44] Pass args, not config_type --- .../algorithm/sci_geometric_constants_mod.x90 | 353 ++++++++++-------- 1 file changed, 202 insertions(+), 151 deletions(-) diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90 b/components/science/source/algorithm/sci_geometric_constants_mod.x90 index eaa3ccf42..50582eef1 100644 --- a/components/science/source/algorithm/sci_geometric_constants_mod.x90 +++ b/components/science/source/algorithm/sci_geometric_constants_mod.x90 @@ -15,7 +15,6 @@ module sci_geometric_constants_mod ! Infrastructure - use config_mod, only: config_type use constants_mod, only: i_def, r_def, l_def, str_def use extrusion_mod, only: TWOD, PRIME_EXTRUSION use field_mod, only: field_type @@ -136,7 +135,6 @@ contains ! ========================================================================== ! !> @brief Private routine for computing longitude and latitude fields - !> @param[in] config Configuration object !> @param[in,out] long_inventory Inventory containing longitude fields !> @param[in,out] lat_inventory Inventory containing latitude fields !> @param[in] mesh Mesh used to determine local mesh for @@ -145,21 +143,29 @@ contains !! longitude and latitude fields for !> @param[in] use_fe Flag to indicate whether to use finite !! element or finite volume cells - subroutine compute_latlon(config, long_inventory, lat_inventory, & - mesh, fs_id, use_fe) + subroutine compute_latlon( long_inventory, lat_inventory, & + mesh, fs_id, use_fe, & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type implicit none - type(config_type), intent(in) :: config - type(inventory_by_local_mesh_type), intent(inout) :: long_inventory type(inventory_by_local_mesh_type), intent(inout) :: lat_inventory type(mesh_type), intent(in) :: mesh integer(kind=i_def), intent(in) :: fs_id logical(kind=l_def), intent(in) :: use_fe + integer(i_def), intent(in) :: geometry, topology + integer(i_def), intent(in) :: order_h, order_v + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: f_lat, f_lon + real(r_def), intent(in) :: scaled_radius + ! Internal variables type(mesh_type), pointer :: twod_mesh type(local_mesh_type), pointer :: local_mesh @@ -171,25 +177,8 @@ contains integer(kind=i_def) :: k_h, k_v integer(tik) :: id - integer(i_def) :: geometry, topology - integer(i_def) :: order_h, order_v - integer(i_def) :: coord_system - real(r_def) :: f_lat, f_lon - real(r_def) :: scaled_radius - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() - - f_lat = config%base_mesh%f_lat() - f_lon = config%idealised%f_lon() - if (use_fe) then k_h = order_h k_v = order_v @@ -326,17 +315,17 @@ contains !> @brief Returns a pointer to the extended coordinate field array - !> @param[in] config Configuration object - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] coord_system Finite-Element coordinate system enumeration + !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The coordinate field array - function get_extended_coordinates(config, mesh_id) result(extended_chi) + function get_extended_coordinates(coord_system, mesh_id) result(extended_chi) use sci_extend_chi_field_kernel_mod, only: extend_chi_field_kernel_type implicit none - type(config_type), intent(in) :: config - integer(kind=i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: coord_system + integer(i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(field_type), pointer :: extended_chi(:) @@ -349,8 +338,6 @@ contains integer(tik) :: id integer(i_def) :: coord_system - coord_system = config%finite_element%coord_system() - ! Initialise inventory if this is the first time getting this constant if (.not. extended_chi_inventory%is_initialised()) then call extended_chi_inventory%initialise(name="extended_chi") @@ -443,10 +430,17 @@ contains !> @brief Returns the (finite element) Det(J) values at W3 dof locations - !> @param[in] config Configuration object + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] element_order_h + !> @param[in] element_order_v + !> @param[in] nqp_h_exact + !> @param[in] nqp_v_exact !> @return The Det(J) field - function get_detj_at_w3_fe(config, mesh_id) result(detj_at_w3) + function get_detj_at_w3_fe( mesh_id, & + element_order_h, element_order_v, & + nqp_h_exact, nqp_v_exact) & + result( detj_at_w3 ) ! @TODO #4487: update these imports ! use sci_calc_detj_at_w3_kernel_mod, only: calc_detj_at_w3_kernel_type @@ -459,8 +453,9 @@ contains implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: element_order_h, element_order_v + integer(i_def), intent(in) :: nqp_h_exact, nqp_v_exact type(mesh_type), pointer :: mesh logical(kind=l_def) :: constant_exists @@ -475,17 +470,8 @@ contains type(quadrature_rule_gaussian_type) :: quadrature_rule integer(tik) :: id - integer(i_def) :: nqp_h_exact, nqp_v_exact - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - - nqp_h_exact = config%finite_element%nqp_h_exact() - nqp_v_exact = config%finite_element%nqp_v_exact() - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then + if ( element_order_h == 0 .and. element_order_v == 0) then detj_at_w3 => get_detj_at_w3_fv(mesh_id) return end if @@ -506,7 +492,10 @@ contains ! Create the object as it doesn't exist yet if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - w3_fs => function_space_collection%get_fs(mesh, order_h, order_v, W3) + w3_fs => function_space_collection%get_fs( mesh, & + element_order_h, & + element_order_v, & + W3 ) call detj_at_w3_inventory_fe%add_field(detj_at_w3, w3_fs, mesh) ! @TODO #4487: it is inefficient to calculate this via mass matrices @@ -607,18 +596,18 @@ contains !> @brief Returns the (finite element) Det(J) values at W2 dof locations - !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field - function get_detj_at_w2_fe(config, mesh_id) result(detj_at_w2) + function get_detj_at_w2_fe( mesh_id, element_order_h, element_order_v ) & + result( detj_at_w2 ) use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: element_order_h, element_order_v type(mesh_type), pointer :: mesh logical(kind=l_def) :: constant_exists @@ -631,11 +620,8 @@ contains integer(i_def) :: order_h, order_v - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then + if (element_order_h == 0 .and. element_order_v == 0) then detj_at_w2 => get_detj_at_w2_fv(mesh_id) return end if @@ -656,7 +642,10 @@ contains ! Create the object as it doesn't exist yet if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - w2_fs => function_space_collection%get_fs(mesh, order_h, order_v, W2) + w2_fs => function_space_collection%get_fs( mesh, & + element_order_h, & + element_order_v, & + W2 ) call multiplicity_w2%initialise( w2_fs ) call detj_at_w2_inventory_fe%add_field(detj_at_w2, w2_fs, mesh) @@ -733,18 +722,22 @@ contains !> @brief Returns a pointer to the vertical grid spacing, located at W3 DoFs - !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The physical height difference of layers, at W3 - function get_dz_w3(config, mesh_id) result(dz_w3) + function get_dz_w3( mesh_id, & + geometry, coord_system, scaled_radius ) & + result( dz_w3 ) use sci_get_dz_w3_kernel_mod, only: get_dz_w3_kernel_type implicit none - type(config_type), intent(in) :: config integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + type(mesh_type), pointer :: mesh type(field_type), pointer :: dz_w3 logical(kind=l_def) :: constant_exists @@ -763,7 +756,9 @@ contains if (.not. constant_exists) then ! If this constant doesn't exist, create it ! Get height first to avoid potentially timing twice - height_w2 => get_height_fv(config, W2, mesh_id) + height_w2 => get_height_fv( W2, mesh_id, & + geometry, coord_system, & + scaled_radius ) if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) @@ -871,17 +866,21 @@ contains !> @brief Returns the 1/dz values at lowest-order Wtheta DoF locations - !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The dz_at_wtheta field - function get_dz_at_wtheta(config, mesh_id) result(dz_at_wtheta) + function get_dz_at_wtheta( mesh_id, & + geometry, coord_system, scaled_radius ) & + result( dz_at_wtheta ) use sci_calc_dz_face_kernel_mod, only: calc_dz_face_kernel_type implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id + + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius type(mesh_type), pointer :: mesh type(field_type), pointer :: dz_at_wtheta @@ -906,8 +905,12 @@ contains ! Create constant if it doesn't already exist if (.not. constant_exists) then ! NB: this assumes heights are in the lowest-order space - height_w3 => get_height_fv(config, W3, mesh_id) - height_wth => get_height_fv(config, Wtheta, mesh_id) + height_w3 => get_height_fv( W3, mesh_id, & + geometry, coord_system, & + scaled_radius ) + height_wth => get_height_fv( Wtheta, mesh_id, & + geometry, coord_system, & + scaled_radius ) if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) @@ -929,17 +932,19 @@ contains !> @brief Returns the surface area of a cell projected to mean sea level !> i.e. ignoring the orographic effect on the area - !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The dA_msl_proj field - function get_dA_msl_proj(config, mesh_id) result(dA_msl_proj) + function get_dA_msl_proj( mesh_id, geometry, planet_radius, domain_height ) & + result( dA_msl_proj ) use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type implicit none - type(config_type), intent(in) :: config integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + real(r_def), intent(in) :: planet_radius + real(r_def), intent(in) :: domain_height integer(kind=i_def) :: local_mesh_id type(mesh_type), pointer :: mesh @@ -952,14 +957,6 @@ contains type(function_space_type), pointer :: fs integer(tik) :: id - integer(i_def) :: geometry - real(r_def) :: planet_radius - real(r_def) :: domain_height - - geometry = config%base_mesh%geometry() - planet_radius = config%extrusion%planet_radius() - domain_height = config%extrusion%domain_height() - ! Initialise inventory if it hasn't been done so already if (.not. dA_msl_proj_inventory%is_initialised()) then call dA_msl_proj_inventory%initialise(name="dA_msl_proj") @@ -997,17 +994,27 @@ contains ! PHYSICAL COORDINATES OF DOFs ! ========================================================================== ! !> @brief Returns a pointer to the longitude of finite element DoFs - !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the longitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The longitude field - function get_longitude_fe(config, space_id, mesh_id) result(long_ptr) + function get_longitude_fe( space_id, mesh_id, & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) & + result( long_ptr ) implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: space_id - integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + integer(i_def), intent(in) :: element_order_h, element_order_v + integer(i_def), intent(in) :: geometry, topology + integer(i_def), intent(in) :: coord_system + + real(r_def), intent(in) :: f_lat, f_lon + real(r_def), intent(in) :: scaled_radius type(mesh_type), pointer :: mesh type(local_mesh_type), pointer :: local_mesh @@ -1017,14 +1024,13 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - long_ptr => get_longitude_fv(config, space_id, mesh_id) + if (element_order_h == 0 .and. element_order_v == 0) then + long_ptr => get_longitude_fv( space_id, mesh_id, & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) return end if @@ -1060,8 +1066,12 @@ contains constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.true.) + call compute_latlon( long_inventory, lat_inventory, & + mesh, space_id, use_fe=.true., & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) end if call long_inventory%get_field(local_mesh, long_ptr) @@ -1069,17 +1079,27 @@ contains end function get_longitude_fe !> @brief Returns a pointer to the longitude of finite volume DoFs - !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the longitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The longitude field - function get_longitude_fv(config, space_id, mesh_id) result(long_ptr) + function get_longitude_fv( space_id, mesh_id, & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) & + result( long_ptr ) implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: space_id - integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + integer(i_def), intent(in) :: element_order_h, element_order_v + integer(i_def), intent(in) :: geometry, topology + integer(i_def), intent(in) :: coord_system + + real(r_def), intent(in) :: f_lat, f_lon + real(r_def), intent(in) :: scaled_radius type(mesh_type), pointer :: mesh type(local_mesh_type), pointer :: local_mesh @@ -1121,8 +1141,12 @@ contains constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.false.) + call compute_latlon( long_inventory, lat_inventory, & + mesh, space_id, use_fe=.false., & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) end if call long_inventory%get_field(local_mesh, long_ptr) @@ -1131,18 +1155,29 @@ contains !> @brief Returns a pointer to the latitude of finite element DoFs - !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the latitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The latitude field - function get_latitude_fe(config, space_id, mesh_id) result(lat_ptr) + function get_latitude_fe( space_id, mesh_id, & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) & + result( lat_ptr ) + implicit none - type(config_type), intent(in) :: config + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + integer(i_def), intent(in) :: element_order_h, element_order_v + integer(i_def), intent(in) :: geometry, topology + integer(i_def), intent(in) :: coord_system + + real(r_def), intent(in) :: f_lat, f_lon + real(r_def), intent(in) :: scaled_radius - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(local_mesh_type), pointer :: local_mesh type(inventory_by_local_mesh_type), pointer :: long_inventory @@ -1151,14 +1186,13 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - lat_ptr => get_latitude_fv(config, space_id, mesh_id) + if (element_order_h == 0 .and. element_order_v == 0) then + lat_ptr => get_latitude_fv( space_id, mesh_id, & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) return end if @@ -1194,8 +1228,12 @@ contains constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.true.) + call compute_latlon( long_inventory, lat_inventory, & + mesh, space_id, use_fe=.true., & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) end if call lat_inventory%get_field(local_mesh, lat_ptr) @@ -1205,17 +1243,27 @@ contains !> @brief Returns a pointer to the latitude of finite volume DoFs - !> @param[in] config Configuration object !> @param[in] space_id The space for which to get the latitude of DoFs for !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The latitude field - function get_latitude_fv(config, space_id, mesh_id) result(lat_ptr) + function get_latitude_fv( space_id, mesh_id, & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) & + result( lat_ptr ) implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: space_id - integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + integer(i_def), intent(in) :: element_order_h, element_order_v + integer(i_def), intent(in) :: geometry, topology + integer(i_def), intent(in) :: coord_system + + real(r_def), intent(in) :: f_lat, f_lon + real(r_def), intent(in) :: scaled_radius type(mesh_type), pointer :: mesh type(local_mesh_type), pointer :: local_mesh @@ -1257,8 +1305,12 @@ contains constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) if (.not. constant_exists) then - call compute_latlon(config, long_inventory, lat_inventory, & - mesh, space_id, use_fe=.false.) + call compute_latlon( long_inventory, lat_inventory, & + mesh, space_id, use_fe=.false., & + geometry, topology, & + element_order_h, element_order_v, & + coord_system, f_lat, f_lon, & + scaled_radius ) end if call lat_inventory%get_field(local_mesh, lat_ptr) @@ -1267,11 +1319,13 @@ contains !> @brief Returns a pointer to a finite element height field - !> @param[in] config Configuration object !> @param[in] space_id The space of the desired height field !> @param[in] mesh_id The ID of the mesh to get the object for !> @return A height field - function get_height_fe(config, space_id, mesh_id) result(height) + function get_height_fe( space_id, mesh_id, & + geometry, element_order_h, element_order_v, & + coord_system, scaled_radius ) & + result( height ) use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type @@ -1280,9 +1334,15 @@ contains implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: space_id - integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: coord_system + integer(i_def), intent(in) :: element_order_h + integer(i_def), intent(in) :: element_order_v + + real(r_def), intent(in) :: scaled_radius type(mesh_type), pointer :: mesh type(inventory_by_mesh_type), pointer :: inventory @@ -1296,19 +1356,11 @@ contains character(len=str_def) :: inventory_name integer(tik) :: id - real(r_def) :: scaled_radius - integer(i_def) :: geometry, coord_system - integer(i_def) :: order_h, order_v - - order_h = config%finite_element%element_order_h() - order_v = config%finite_element%element_order_v() - coord_system = config%finite_element%coord_system() - geometry = config%base_mesh%geometry() - scaled_radius = config%planet%scaled_radius() - ! If running at lowest order, use finite volume - if (order_h == 0 .and. order_v == 0) then - height => get_height_fv(config, space_id, mesh_id) + if (element_order_h == 0 .and. element_order_v == 0) then + height => get_height_fv( space_id, mesh_id, & + geometry, coord_system, & + scaled_radius ) return end if @@ -1351,10 +1403,10 @@ contains if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - space => function_space_collection%get_fs(mesh, & - order_h, & - order_v, & - space_id) + space => function_space_collection%get_fs( mesh, & + element_order_h, & + element_order_v, & + space_id ) call inventory%add_field(height, space, mesh) select case (space_id) @@ -1395,21 +1447,27 @@ contains !> @brief Returns a pointer to a finite volume height field - !> @param[in] config Configuration object !> @param[in] space_id The space of the desired height field !> @param[in] mesh_id The ID of the mesh to get the object for !> @return A height field - function get_height_fv(config, space_id, mesh_id) result(height) + function get_height_fv( space_id, mesh_id, & + geometry, coord_system, & + scaled_radius ) & + result( height ) + use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type - use sci_height_discontinuous_kernel_mod, & + use sci_height_discontinuous_kernel_mod, & only: height_discontinuous_kernel_type implicit none - type(config_type), intent(in) :: config - integer(i_def), intent(in) :: space_id - integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: space_id + integer(i_def), intent(in) :: mesh_id + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius type(mesh_type), pointer :: mesh type(inventory_by_mesh_type), pointer :: inventory @@ -1423,13 +1481,6 @@ contains character(len=str_def) :: inventory_name integer(tik) :: id - real(r_def) :: scaled_radius - integer(i_def) :: geometry, coord_system - - coord_system = config%finite_element%coord_system() - geometry = config%base_mesh%geometry() - scaled_radius = config%planet%scaled_radius() - ! Determine inventory based on space select case (space_id) case (W0) From 98f849f3aa85a73eb0f6a04e3de3793dc058b9c8 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Tue, 31 Mar 2026 11:57:15 +0100 Subject: [PATCH 19/44] Updates --- applications/coupled/source/coupled.f90 | 3 +- applications/io_demo/source/io_demo.f90 | 4 +- applications/lbc_demo/source/lbc_demo.f90 | 4 +- .../source/simple_diffusion.f90 | 4 +- applications/skeleton/source/skeleton.f90 | 4 +- .../driver/source/driver_coordinates_mod.F90 | 26 +- components/driver/source/driver_fem_mod.f90 | 22 +- components/driver/source/driver_log_mod.f90 | 18 +- components/driver/source/driver_mesh_mod.f90 | 2 +- .../driver/source/mesh/create_mesh_mod.f90 | 6 +- .../driver/source/mesh/multigrid_mod.f90 | 29 +- .../algorithm/sci_geometric_constants_mod.x90 | 30 +- .../algorithm/sci_mapping_constants_mod.x90 | 259 +++++++++++------- 13 files changed, 258 insertions(+), 153 deletions(-) diff --git a/applications/coupled/source/coupled.f90 b/applications/coupled/source/coupled.f90 index 6d1b058ec..00abd995c 100644 --- a/applications/coupled/source/coupled.f90 +++ b/applications/coupled/source/coupled.f90 @@ -50,7 +50,8 @@ program coupled call init_config( filename, coupled_required_namelists, & config=modeldb%config ) - call init_logger( modeldb, & + call init_logger( modeldb%config, & + modeldb%mpi%get_comm(), & program_name//"_"//cpl_component_name ) write(log_scratch_space,'(A)') & diff --git a/applications/io_demo/source/io_demo.f90 b/applications/io_demo/source/io_demo.f90 index 3c288e4c8..cbd310409 100644 --- a/applications/io_demo/source/io_demo.f90 +++ b/applications/io_demo/source/io_demo.f90 @@ -60,7 +60,9 @@ program io_demo deallocate( filename ) - call init_logger(modeldb, program_name) + call init_logger( modeldb%config, & + modeldb%mpi%get_comm(), & + program_name ) subroutine_timers = modeldb%config%io%subroutine_timers() timer_output_path = modeldb%config%io%timer_output_path() diff --git a/applications/lbc_demo/source/lbc_demo.f90 b/applications/lbc_demo/source/lbc_demo.f90 index 898892bd8..0f53931d6 100644 --- a/applications/lbc_demo/source/lbc_demo.f90 +++ b/applications/lbc_demo/source/lbc_demo.f90 @@ -45,7 +45,9 @@ program lbc_demo call init_config(filename, required_namelists, & config=modeldb%config) - call init_logger( modeldb, program_name ) + call init_logger( modeldb%config, & + modeldb%mpi%get_comm(), & + program_name ) ! Before anything else, test that the mesh provided was a regional domain. ! This application is not intended for cubed-sphere meshes. diff --git a/applications/simple_diffusion/source/simple_diffusion.f90 b/applications/simple_diffusion/source/simple_diffusion.f90 index bb984d20d..d6d01842f 100644 --- a/applications/simple_diffusion/source/simple_diffusion.f90 +++ b/applications/simple_diffusion/source/simple_diffusion.f90 @@ -45,7 +45,9 @@ program simple_diffusion simple_diffusion_required_namelists, & config=modeldb%config ) - call init_logger( modeldb, program_name ) + call init_logger( modeldb%config, & + modeldb%mpi%get_comm(), & + program_name ) write(log_scratch_space,& '("Application built with ", A, "-bit real numbers")') & diff --git a/applications/skeleton/source/skeleton.f90 b/applications/skeleton/source/skeleton.f90 index 57002571a..03da201ab 100644 --- a/applications/skeleton/source/skeleton.f90 +++ b/applications/skeleton/source/skeleton.f90 @@ -45,7 +45,9 @@ program skeleton call init_config( filename, skeleton_required_namelists, & config=modeldb%config ) - call init_logger( modeldb, program_name ) + call init_logger( modeldb%config, & + modeldb%mpi%get_comm(), & + program_name ) write(log_scratch_space,'(A)') & 'Application built with '// trim(precision_real) // & diff --git a/components/driver/source/driver_coordinates_mod.F90 b/components/driver/source/driver_coordinates_mod.F90 index 52cec5fc0..bbab70901 100644 --- a/components/driver/source/driver_coordinates_mod.F90 +++ b/components/driver/source/driver_coordinates_mod.F90 @@ -7,7 +7,7 @@ !> @brief Module to assign the values of the coordinates of the mesh to a field. module driver_coordinates_mod - use config_mod, only: config_type +! use config_mod, only: config_type use constants_mod, only: r_def, i_def, l_def, & radians_to_degrees, & i_halo_index, eps, pi @@ -56,7 +56,9 @@ module driver_coordinates_mod !> @param[in,out] chi Model coordinate array of size 3 of fields !> @param[in] panel_id Field giving the ID of mesh panels !> @param[in] mesh Mesh on which this field is attached - subroutine assign_coordinate_field(config, chi, panel_id, mesh) + subroutine assign_coordinate_field(chi, panel_id, mesh, & + geometry, topology, & + coord_system, scaled_radius ) use domain_mod, only: domain_type use field_mod, only: field_type, field_proxy_type @@ -69,12 +71,17 @@ subroutine assign_coordinate_field(config, chi, panel_id, mesh) implicit none - type(config_type), intent(in) :: config +! type(config_type), intent(in) :: config type( field_type ), intent( inout ) :: chi(3) type( field_type ), intent( inout ) :: panel_id type( mesh_type ), intent( in ), pointer :: mesh + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + integer(i_def), pointer :: map(:,:) integer(i_def), pointer :: map_pid(:,:) real(kind=r_def), pointer :: dof_coords(:,:) @@ -108,15 +115,10 @@ subroutine assign_coordinate_field(config, chi, panel_id, mesh) real(kind=r_def) :: inverse_rot_matrix(3,3) real(kind=r_def) :: stretch_factor - integer(i_def) :: geometry - integer(i_def) :: topology - integer(i_def) :: coord_system - real(r_def) :: scaled_radius - - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() +!!$ geometry = config%base_mesh%geometry() +!!$ topology = config%base_mesh%topology() +!!$ coord_system = config%finite_element%coord_system() +!!$ scaled_radius = config%planet%scaled_radius() nullify( map, map_pid, dof_coords, reference_element ) diff --git a/components/driver/source/driver_fem_mod.f90 b/components/driver/source/driver_fem_mod.f90 index 43de2fafa..387a8608b 100644 --- a/components/driver/source/driver_fem_mod.f90 +++ b/components/driver/source/driver_fem_mod.f90 @@ -12,10 +12,8 @@ !> * Initialises function space chains for use by the model. module driver_fem_mod - use sci_chi_transform_mod, only: init_chi_transforms, & - final_chi_transforms use config_mod, only: config_type - use constants_mod, only: i_def, l_def, str_def + use constants_mod, only: i_def, r_def, l_def, str_def use extrusion_mod, only: TWOD, PRIME_EXTRUSION use field_mod, only: field_type use fs_continuity_mod, only: W0, W2, W3, Wtheta, Wchi, W2v, W2h @@ -37,6 +35,9 @@ module driver_fem_mod use mesh_mod, only: mesh_type use mesh_collection_mod, only: mesh_collection + use sci_chi_transform_mod, only: init_chi_transforms, & + final_chi_transforms + implicit none private @@ -70,16 +71,19 @@ subroutine init_fem(config, chi_inventory, panel_id_inventory) integer(i_def) :: chi_space, coord, i character(str_def) :: mesh_name - integer(i_def) :: coord_order, geometry, topology + integer(i_def) :: coord_order, geometry, topology, coord_system + real(r_def) :: scaled_radius call log_event( 'FEM specifics: creating function spaces...', & log_level_info ) nullify(mesh, twod_mesh, fs) - coord_order = config%finite_element%coord_order() - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + coord_system = config%finite_element%coord_system() + coord_order = config%finite_element%coord_order() + scaled_radius = config%planet%scaled_radius() ! ======================================================================== ! ! Initialise coordinates @@ -136,7 +140,9 @@ subroutine init_fem(config, chi_inventory, panel_id_inventory) end do ! Set coordinate fields -------------------------------------------------- - call assign_coordinate_field(config, chi, panel_id, mesh) + call assign_coordinate_field(chi, panel_id, mesh, & + geometry, topology, & + coord_system, scaled_radius) ! Add fields to inventory call chi_inventory%copy_field_array(chi, mesh) diff --git a/components/driver/source/driver_log_mod.f90 b/components/driver/source/driver_log_mod.f90 index 2d3db8330..2b0919a5f 100644 --- a/components/driver/source/driver_log_mod.f90 +++ b/components/driver/source/driver_log_mod.f90 @@ -2,7 +2,8 @@ module driver_log_mod use constants_mod, only: i_def, l_def use convert_to_upper_mod, only: convert_to_upper -use driver_modeldb_mod, only: modeldb_type +!use driver_modeldb_mod, only: modeldb_type +use config_mod, only: config_type use lfric_mpi_mod, only: lfric_comm_type use log_mod, only: log_event, & log_set_level, & @@ -36,23 +37,22 @@ module driver_log_mod !> @param[in] communicator MPI communicator to use for logging. !> @param[in] program_name Identifies the running program. !> -subroutine init_logger(modeldb, program_name) +subroutine init_logger(config, communicator, program_name) implicit none - type(modeldb_type), intent(in) :: modeldb - character(len=*), intent(in) :: program_name - - type(lfric_comm_type) :: communicator + type(config_type), intent(in) :: config + type(lfric_comm_type), intent(in) :: communicator + character(len=*), intent(in) :: program_name integer(i_def) :: log_level integer(i_def) :: run_log_level logical(l_def) :: log_to_rank_zero_only - communicator = modeldb%mpi%get_comm() +! communicator = modeldb%mpi%get_comm() - run_log_level = modeldb%config%logging%run_log_level() - log_to_rank_zero_only = modeldb%config%logging%log_to_rank_zero_only() + run_log_level = config%logging%run_log_level() + log_to_rank_zero_only = config%logging%log_to_rank_zero_only() call initialise_logging( communicator%get_comm_mpi_val(), program_name, & log_to_rank_zero_only=log_to_rank_zero_only) diff --git a/components/driver/source/driver_mesh_mod.f90 b/components/driver/source/driver_mesh_mod.f90 index dc524efcf..9f526b8d7 100644 --- a/components/driver/source/driver_mesh_mod.f90 +++ b/components/driver/source/driver_mesh_mod.f90 @@ -110,7 +110,7 @@ subroutine init_mesh( config, & class(extrusion_type), intent(in) :: extrusion logical(l_def), intent(in) :: inner_halo_tiles - integer(i_def), intent(in) :: tile_size(2) + integer(i_def), intent(in) :: tile_size(:,:) integer(i_def), intent(in) :: stencil_depths_in(:) logical(l_def), intent(in) :: check_partitions diff --git a/components/driver/source/mesh/create_mesh_mod.f90 b/components/driver/source/mesh/create_mesh_mod.f90 index 8aec9e0cc..3bcef4152 100644 --- a/components/driver/source/mesh/create_mesh_mod.f90 +++ b/components/driver/source/mesh/create_mesh_mod.f90 @@ -109,7 +109,7 @@ subroutine create_mesh_multiple( local_mesh_names, extrusion, & character(str_def), intent(in) :: local_mesh_names(:) class(extrusion_type), intent(in) :: extrusion logical(l_def), intent(in) :: inner_halo_tiles - integer(i_def), intent(in) :: tile_size(2) + integer(i_def), intent(in) :: tile_size(:,:) character(str_def), intent(in), & optional :: alt_name(:) @@ -132,8 +132,8 @@ subroutine create_mesh_multiple( local_mesh_names, extrusion, & end if do i=1, size(local_mesh_names) - call create_mesh_single( local_mesh_names(i), extrusion, & - inner_halo_tiles, tile_size, & + call create_mesh_single( local_mesh_names(i), extrusion, & + inner_halo_tiles, tile_size(:,i), & alt_name=names(i) ) end do diff --git a/components/driver/source/mesh/multigrid_mod.f90 b/components/driver/source/mesh/multigrid_mod.f90 index 365b8b638..eb63a1643 100644 --- a/components/driver/source/mesh/multigrid_mod.f90 +++ b/components/driver/source/mesh/multigrid_mod.f90 @@ -9,7 +9,8 @@ module multigrid_mod use extrusion_mod, only: extrusion_type, prime_extrusion, & shifted, double_level use config_mod, only: config_type - use constants_mod, only: i_def, l_def, str_def + use constants_mod, only: i_def, l_def, str_def, imdi + use log_mod, only: log_event, log_level_error implicit none @@ -27,18 +28,19 @@ module multigrid_mod !> !> @return tile_size !> -subroutine get_multigrid_tile_size( config, local_mesh_names, extrusion, & - tile_size ) +!!$subroutine get_multigrid_tile_size( config, local_mesh_names, extrusion, & +!!$ tile_size ) - implicit none - - type(config_type), intent(in) :: config - character(str_def), intent(in) :: local_mesh_names(:) - type(extrusion_type), intent(in) :: extrusion +function get_multigrid_tile_size( config, local_mesh_names, extrusion) & + result ( tile_size ) - integer(i_def), intent(inout) :: tile_size(:,:) + implicit none + type(config_type), intent(in) :: config + character(str_def), intent(in) :: local_mesh_names(:) + class(extrusion_type), intent(in) :: extrusion + integer(i_def), allocatable :: tile_size(:,:) integer(i_def) :: multigrid_level integer(i_def) :: max_multigrid_level @@ -47,6 +49,9 @@ subroutine get_multigrid_tile_size( config, local_mesh_names, extrusion, & character(str_def), allocatable :: chain_mesh_tags(:) + integer(i_def) :: extrusion_id, i + character(str_def) :: name + !========================================================================= ! This whole section should probably be in gungho science. It allows the ! Gungho multigrid scheme to override the tile settings in the @@ -75,6 +80,10 @@ subroutine get_multigrid_tile_size( config, local_mesh_names, extrusion, & call log_event('no max multigrid level set', log_level_error) end if + if (allocated(tile_size)) deallocate(tile_size) + allocate(tile_size(2,(size(local_mesh_names)))) + tile_size = imdi + do i=1, size(local_mesh_names) set_tile_size = .false. name =local_mesh_names(i) @@ -107,6 +116,6 @@ subroutine get_multigrid_tile_size( config, local_mesh_names, extrusion, & end if ! Coarsen multigrid_tiles -end subroutine get_multigrid_tile_size +end function get_multigrid_tile_size end module multigrid_mod diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90 b/components/science/source/algorithm/sci_geometric_constants_mod.x90 index 50582eef1..dc24c8086 100644 --- a/components/science/source/algorithm/sci_geometric_constants_mod.x90 +++ b/components/science/source/algorithm/sci_geometric_constants_mod.x90 @@ -161,7 +161,7 @@ contains logical(kind=l_def), intent(in) :: use_fe integer(i_def), intent(in) :: geometry, topology - integer(i_def), intent(in) :: order_h, order_v + integer(i_def), intent(in) :: element_order_h, element_order_v integer(i_def), intent(in) :: coord_system real(r_def), intent(in) :: f_lat, f_lon real(r_def), intent(in) :: scaled_radius @@ -180,8 +180,8 @@ contains if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) if (use_fe) then - k_h = order_h - k_v = order_v + k_h = element_order_h + k_v = element_order_v else k_h = 0 k_v = 0 @@ -318,7 +318,7 @@ contains !> @param[in] coord_system Finite-Element coordinate system enumeration !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The coordinate field array - function get_extended_coordinates(coord_system, mesh_id) result(extended_chi) + function get_extended_coordinates(mesh_id, coord_system) result(extended_chi) use sci_extend_chi_field_kernel_mod, only: extend_chi_field_kernel_type @@ -336,7 +336,6 @@ contains type(function_space_type), pointer :: wchi_fs integer(tik) :: id - integer(i_def) :: coord_system ! Initialise inventory if this is the first time getting this constant if (.not. extended_chi_inventory%is_initialised()) then @@ -618,8 +617,6 @@ contains type(function_space_type), pointer :: w2_fs integer(tik) :: id - integer(i_def) :: order_h, order_v - ! If running at lowest order, use finite volume if (element_order_h == 0 .and. element_order_v == 0) then detj_at_w2 => get_detj_at_w2_fv(mesh_id) @@ -934,7 +931,8 @@ contains !> i.e. ignoring the orographic effect on the area !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The dA_msl_proj field - function get_dA_msl_proj( mesh_id, geometry, planet_radius, domain_height ) & + function get_dA_msl_proj( mesh_id, & + geometry, planet_radius, domain_height ) & result( dA_msl_proj ) use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type @@ -1024,6 +1022,8 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name + logical(l_def), parameter :: use_fe = .true. + ! If running at lowest order, use finite volume if (element_order_h == 0 .and. element_order_v == 0) then long_ptr => get_longitude_fv( space_id, mesh_id, & @@ -1067,7 +1067,7 @@ contains if (.not. constant_exists) then call compute_latlon( long_inventory, lat_inventory, & - mesh, space_id, use_fe=.true., & + mesh, space_id, use_fe, & geometry, topology, & element_order_h, element_order_v, & coord_system, f_lat, f_lon, & @@ -1109,6 +1109,8 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name + logical(l_def), parameter :: use_fe = .false. + ! NB: Longitude and latitude fields are computed simultaneously ! Determine inventory based on space select case (space_id) @@ -1142,7 +1144,7 @@ contains if (.not. constant_exists) then call compute_latlon( long_inventory, lat_inventory, & - mesh, space_id, use_fe=.false., & + mesh, space_id, use_fe, & geometry, topology, & element_order_h, element_order_v, & coord_system, f_lat, f_lon, & @@ -1186,6 +1188,8 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name + logical(l_def), parameter :: use_fe = .true. + ! If running at lowest order, use finite volume if (element_order_h == 0 .and. element_order_v == 0) then lat_ptr => get_latitude_fv( space_id, mesh_id, & @@ -1229,7 +1233,7 @@ contains if (.not. constant_exists) then call compute_latlon( long_inventory, lat_inventory, & - mesh, space_id, use_fe=.true., & + mesh, space_id, use_fe, & geometry, topology, & element_order_h, element_order_v, & coord_system, f_lat, f_lon, & @@ -1273,6 +1277,8 @@ contains logical(kind=l_def) :: constant_exists character(len=str_def) :: inventory_name + logical(l_def), parameter :: use_fe = .false. + ! NB: Longitude and latitude fields are computed simultaneously ! Determine inventory based on space select case (space_id) @@ -1306,7 +1312,7 @@ contains if (.not. constant_exists) then call compute_latlon( long_inventory, lat_inventory, & - mesh, space_id, use_fe=.false., & + mesh, space_id, use_fe, & geometry, topology, & element_order_h, element_order_v, & coord_system, f_lat, f_lon, & diff --git a/components/science/source/algorithm/sci_mapping_constants_mod.x90 b/components/science/source/algorithm/sci_mapping_constants_mod.x90 index 582c9bf74..f6e2c9950 100644 --- a/components/science/source/algorithm/sci_mapping_constants_mod.x90 +++ b/components/science/source/algorithm/sci_mapping_constants_mod.x90 @@ -15,7 +15,7 @@ module sci_mapping_constants_mod ! Infrastructure - use config_mod, only: config_type +! use config_mod, only: config_type use constants_mod, only: i_def, r_def, l_def, str_def use copy_field_alg_mod, only: copy_field use extrusion_mod, only: PRIME_EXTRUSION, & @@ -46,7 +46,6 @@ module sci_mapping_constants_mod ! Configuration use finite_element_config_mod, only: element_order_h, & element_order_v - ! Other algorithms use sci_geometric_constants_mod, only: get_coordinates, & get_panel_id @@ -202,16 +201,23 @@ contains !! (W3, W3, Wtheta) to a vector-valued field in W2 !> @param[in] config Configuration object !> @param[in] mesh The mesh to compute the operators for - subroutine create_spherical_components_to_w2_projection(config, mesh) + subroutine create_spherical_components_to_w2_projection( mesh, & + geometry, topology, & + coord_system, scaled_radius ) use sci_compute_map_u_operators_kernel_mod, & only: compute_map_u_operators_kernel_type implicit none - type(config_type), intent(in) :: config +! type(config_type), intent(in) :: config type(mesh_type), pointer, intent(in) :: mesh + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + integer(kind=i_def) :: mesh_id type(function_space_type), pointer :: w2_fs type(function_space_type), pointer :: w3_fs @@ -223,15 +229,12 @@ contains type(operator_type), pointer :: u_lat_map type(operator_type), pointer :: u_up_map - integer(i_def) :: geometry - integer(i_def) :: topology - integer(i_def) :: coord_system - real(r_def) :: scaled_radius - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() + +!!$ geometry = config%base_mesh%geometry() +!!$ topology = config%base_mesh%topology() +!!$ coord_system = config%finite_element%coord_system() +!!$ scaled_radius = config%planet%scaled_radius() if (.not. u_lon_map_inventory%is_initialised()) then call u_lon_map_inventory%initialise(name='u_lon_map') @@ -273,16 +276,24 @@ contains !! (W3, W3, Wtheta) to a vector-valued field in W2 !> @param[in] config Configuration object !> @param[in] mesh The mesh to compute the operators for - subroutine create_spherical_components_to_w2_sample(config, mesh) + subroutine create_spherical_components_to_w2_sample( mesh, & + geometry, topology, & + coord_system, scaled_radius ) use sci_compute_sample_u_ops_kernel_mod, & only: compute_sample_u_ops_kernel_type implicit none - type(config_type), intent(in) :: config +! type(config_type), intent(in) :: config type(mesh_type), pointer, intent(in) :: mesh + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + integer(kind=i_def) :: mesh_id type(function_space_type), pointer :: w2_fs type(function_space_type), pointer :: w3_fs @@ -294,15 +305,10 @@ contains type(operator_type), pointer :: u_up_sample integer(tik) :: id - integer(i_def) :: geometry - integer(i_def) :: topology - integer(i_def) :: coord_system - real(r_def) :: scaled_radius - - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() +!!$ geometry = config%base_mesh%geometry() +!!$ topology = config%base_mesh%topology() +!!$ coord_system = config%finite_element%coord_system() +!!$ scaled_radius = config%planet%scaled_radius() if (.not. u_lon_sample_inventory%is_initialised()) then call u_lon_sample_inventory%initialise(name='u_lon_sample') @@ -881,11 +887,17 @@ contains !> @brief Returns a pointer to the u_lon mapping operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The mapping operator for u_lon to W2 - function get_u_lon_map(mesh_id) result(u_lon_map_op) + function get_u_lon_map(mesh_id, geometry, topology, & + coord_system, scaled_radius ) result(u_lon_map_op) implicit none - integer(kind=i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + type(mesh_type), pointer :: mesh type(operator_type), pointer :: u_lon_map_op logical(kind=l_def) :: constant_exists @@ -898,7 +910,10 @@ contains mesh => mesh_collection%get_mesh(mesh_id) constant_exists = u_lon_map_inventory%paired_object_exists(mesh_id) - if (.not. constant_exists) call create_spherical_components_to_w2_projection(mesh) + if (.not. constant_exists) then + call create_spherical_components_to_w2_projection(mesh, geometry, topology, & + coord_system, scaled_radius) + end if ! Return constant call u_lon_map_inventory%get_operator(mesh, u_lon_map_op) @@ -908,11 +923,17 @@ contains !> @brief Returns a pointer to the u_lat mapping operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The mapping operator for u_lat to W2 - function get_u_lat_map(mesh_id) result(u_lat_map_op) + function get_u_lat_map(mesh_id, geometry, topology, & + coord_system, scaled_radius) result(u_lat_map_op) implicit none - integer(kind=i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + type(mesh_type), pointer :: mesh type(operator_type), pointer :: u_lat_map_op logical(kind=l_def) :: constant_exists @@ -925,7 +946,11 @@ contains mesh => mesh_collection%get_mesh(mesh_id) constant_exists = u_lat_map_inventory%paired_object_exists(mesh_id) - if (.not. constant_exists) call create_spherical_components_to_w2_projection(mesh) + if (.not. constant_exists) then + call create_spherical_components_to_w2_projection(mesh, & + geometry, topology, & + coord_system, scaled_radius) + end if ! Return constant call u_lat_map_inventory%get_operator(mesh, u_lat_map_op) @@ -935,11 +960,17 @@ contains !> @brief Returns a pointer to the u_up mapping operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The mapping operator for u_up to W2 - function get_u_up_map(mesh_id) result(u_up_map_op) + function get_u_up_map(mesh_id, geometry, topology, & + coord_system, scaled_radius) result(u_up_map_op) implicit none - integer(kind=i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + type(mesh_type), pointer :: mesh type(operator_type), pointer :: u_up_map_op logical(kind=l_def) :: constant_exists @@ -952,7 +983,11 @@ contains mesh => mesh_collection%get_mesh(mesh_id) constant_exists = u_up_map_inventory%paired_object_exists(mesh_id) - if (.not. constant_exists) call create_spherical_components_to_w2_projection(mesh) + if (.not. constant_exists) then + call create_spherical_components_to_w2_projection( mesh, & + geometry, topology, & + coord_system, scaled_radius ) + end if ! Return constant call u_up_map_inventory%get_operator(mesh, u_up_map_op) @@ -962,11 +997,19 @@ contains !> @brief Returns a pointer to the u_lon sampling operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The sampling operator for u_lon to W2 - function get_u_lon_sample(mesh_id) result(u_lon_sample_op) + function get_u_lon_sample(mesh_id, & + geometry, topology, & + coord_system, scaled_radius) & + result(u_lon_sample_op) implicit none - integer(kind=i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + type(mesh_type), pointer :: mesh type(operator_type), pointer :: u_lon_sample_op logical(kind=l_def) :: constant_exists @@ -979,7 +1022,11 @@ contains mesh => mesh_collection%get_mesh(mesh_id) constant_exists = u_lon_sample_inventory%paired_object_exists(mesh_id) - if (.not. constant_exists) call create_spherical_components_to_w2_sample(mesh) + if (.not. constant_exists) then + call create_spherical_components_to_w2_sample(mesh, & + geometry, topology, & + coord_system, scaled_radius) + end if ! Return constant call u_lon_sample_inventory%get_operator(mesh, u_lon_sample_op) @@ -989,11 +1036,18 @@ contains !> @brief Returns a pointer to the u_lat sampling operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The sampling operator for u_lat to W2 - function get_u_lat_sample(mesh_id) result(u_lat_sample_op) + function get_u_lat_sample(mesh_id, & + geometry, topology, & + coord_system, scaled_radius) result(u_lat_sample_op) implicit none - integer(kind=i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + type(mesh_type), pointer :: mesh type(operator_type), pointer :: u_lat_sample_op logical(kind=l_def) :: constant_exists @@ -1006,7 +1060,11 @@ contains mesh => mesh_collection%get_mesh(mesh_id) constant_exists = u_lat_sample_inventory%paired_object_exists(mesh_id) - if (.not. constant_exists) call create_spherical_components_to_w2_sample(mesh) + if (.not. constant_exists) then + call create_spherical_components_to_w2_sample(mesh, & + geometry, topology, & + coord_system, scaled_radius) + end if ! Return constant call u_lat_sample_inventory%get_operator(mesh, u_lat_sample_op) @@ -1016,11 +1074,18 @@ contains !> @brief Returns a pointer to the u_up sampling operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The sampling operator for u_up to W2 - function get_u_up_sample(mesh_id) result(u_up_sample_op) + function get_u_up_sample(mesh_id, & + geometry, topology, & + coord_system, scaled_radius) result(u_up_sample_op) implicit none - integer(kind=i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + type(mesh_type), pointer :: mesh type(operator_type), pointer :: u_up_sample_op logical(kind=l_def) :: constant_exists @@ -1033,7 +1098,11 @@ contains mesh => mesh_collection%get_mesh(mesh_id) constant_exists = u_up_sample_inventory%paired_object_exists(mesh_id) - if (.not. constant_exists) call create_spherical_components_to_w2_sample(mesh) + if (.not. constant_exists) then + call create_spherical_components_to_w2_sample( mesh, & + geometry, topology, & + coord_system, scaled_radius ) + end if ! Return constant call u_up_sample_inventory%get_operator(mesh, u_up_sample_op) @@ -1044,13 +1113,16 @@ contains !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The projection operator - function get_project_lon_dot_to_w1(config, mesh_id) result(proj_op) + function get_project_lon_dot_to_w1( mesh_id, geometry, topology, coord_system, scaled_radius ) result( proj_op ) implicit none - type(config_type), intent(in) :: config + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius - integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(operator_type), pointer :: proj_op logical(kind=l_def) :: constant_exists @@ -1062,16 +1134,6 @@ contains integer(kind=i_def), parameter :: xdirection = 1_i_def integer(tik) :: id - integer(i_def) :: geometry - integer(i_def) :: topology - integer(i_def) :: coord_system - real(r_def) :: scaled_radius - - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() - ! Check inventory is initialised if (.not. project_lon_dot_to_w1_inventory%is_initialised()) then call project_lon_dot_to_w1_inventory%initialise( & @@ -1118,13 +1180,18 @@ contains !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The projection operator - function get_project_lat_dot_to_w1(config, mesh_id) result(proj_op) + function get_project_lat_dot_to_w1( mesh_id, geometry, topology, coord_system, scaled_radius ) result( proj_op ) implicit none - type(config_type), intent(in) :: config +! type(config_type), intent(in) :: config + + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius - integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(operator_type), pointer :: proj_op logical(kind=l_def) :: constant_exists @@ -1136,15 +1203,15 @@ contains integer(kind=i_def), parameter :: ydirection = 2_i_def integer(tik) :: id - integer(i_def) :: geometry - integer(i_def) :: topology - integer(i_def) :: coord_system - real(r_def) :: scaled_radius - - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() +!!$ integer(i_def) :: geometry +!!$ integer(i_def) :: topology +!!$ integer(i_def) :: coord_system +!!$ real(r_def) :: scaled_radius +!!$ +!!$ geometry = config%base_mesh%geometry() +!!$ topology = config%base_mesh%topology() +!!$ coord_system = config%finite_element%coord_system() +!!$ scaled_radius = config%planet%scaled_radius() ! Check inventory is initialised if (.not. project_lat_dot_to_w1_inventory%is_initialised()) then @@ -1192,14 +1259,19 @@ contains !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The projection operator - function get_project_r_dot_to_w1(config, mesh_id) result(proj_op) + function get_project_r_dot_to_w1( mesh_id, geometry, topology, coord_system, scaled_radius ) result(proj_op) implicit none - type(config_type), intent(in) :: config +! type(config_type), intent(in) :: config - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + + type(mesh_type), pointer :: mesh type(operator_type), pointer :: proj_op logical(kind=l_def) :: constant_exists type(function_space_type), pointer :: w1_fs @@ -1209,16 +1281,12 @@ contains type(quadrature_xyoz_type), pointer :: qr integer(kind=i_def), parameter :: zdirection = 3_i_def integer(tik) :: id - - integer(i_def) :: geometry - integer(i_def) :: topology - integer(i_def) :: coord_system - real(r_def) :: scaled_radius - - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() +!!$ +!!$ +!!$ geometry = config%base_mesh%geometry() +!!$ topology = config%base_mesh%topology() +!!$ coord_system = config%finite_element%coord_system() +!!$ scaled_radius = config%planet%scaled_radius() ! Check inventory is initialised if (.not. project_r_dot_to_w1_inventory%is_initialised()) then @@ -1264,15 +1332,25 @@ contains !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The displacement field used for correcting mappings from W3 to W2 - function get_w3_to_w2_displacement(config, mesh_id) result(w3_to_w2_displacement) + function get_w3_to_w2_displacement(mesh_id,& + geometry,& + topology,& + coord_system,& + scaled_radius) result(w3_to_w2_displacement) use sci_w3_to_w2_displacement_kernel_mod, & only: w3_to_w2_displacement_kernel_type implicit none - type(config_type), intent(in) :: config +! type(config_type), intent(in) :: config + + + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius - integer(kind=i_def), intent(in) :: mesh_id type(mesh_type), pointer :: mesh type(local_mesh_type), pointer :: local_mesh type(field_type), pointer :: w3_to_w2_displacement @@ -1283,16 +1361,11 @@ contains type(function_space_type), pointer :: w2h_k0_fs type(function_space_type), pointer :: w3_k0_fs integer(tik) :: id - - integer(i_def) :: geometry - integer(i_def) :: topology - integer(i_def) :: coord_system - real(r_def) :: scaled_radius - - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() +!!$ +!!$ geometry = config%base_mesh%geometry() +!!$ topology = config%base_mesh%topology() +!!$ coord_system = config%finite_element%coord_system() +!!$ scaled_radius = config%planet%scaled_radius() ! Initialise inventory if this is the first time getting this constant if (.not. w3_to_w2_displacement_inventory%is_initialised()) then From e560f49d2485d692b04bca5ce0c67520853696d9 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Tue, 31 Mar 2026 23:29:33 +0100 Subject: [PATCH 20/44] updates --- components/driver/source/driver_fem_mod.f90 | 12 +++++++++--- components/driver/source/mesh/multigrid_mod.f90 | 11 +++++------ .../source/algorithm/sci_mapping_constants_mod.x90 | 4 +++- 3 files changed, 17 insertions(+), 10 deletions(-) diff --git a/components/driver/source/driver_fem_mod.f90 b/components/driver/source/driver_fem_mod.f90 index 387a8608b..7532356a9 100644 --- a/components/driver/source/driver_fem_mod.f90 +++ b/components/driver/source/driver_fem_mod.f90 @@ -13,7 +13,7 @@ module driver_fem_mod use config_mod, only: config_type - use constants_mod, only: i_def, r_def, l_def, str_def + use constants_mod, only: i_def, r_def, l_def, str_def, imdi use extrusion_mod, only: TWOD, PRIME_EXTRUSION use field_mod, only: field_type use fs_continuity_mod, only: W0, W2, W3, Wtheta, Wchi, W2v, W2h @@ -79,8 +79,14 @@ subroutine init_fem(config, chi_inventory, panel_id_inventory) nullify(mesh, twod_mesh, fs) - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() + if (config%namelist_exists('base_mesh')) then + geometry = config%base_mesh%geometry() + topology = config%base_mesh%topology() + else + geometry = imdi + topology = imdi + end if + coord_system = config%finite_element%coord_system() coord_order = config%finite_element%coord_order() scaled_radius = config%planet%scaled_radius() diff --git a/components/driver/source/mesh/multigrid_mod.f90 b/components/driver/source/mesh/multigrid_mod.f90 index eb63a1643..d0ba3f626 100644 --- a/components/driver/source/mesh/multigrid_mod.f90 +++ b/components/driver/source/mesh/multigrid_mod.f90 @@ -66,11 +66,14 @@ function get_multigrid_tile_size( config, local_mesh_names, extrusion) & max_multigrid_level = config%multigrid%max_tiled_multigrid_level() chain_mesh_tags = config%multigrid%chain_mesh_tags() - extrusion_id = extrusion%get_id() - !========================================================================= + if (allocated(tile_size)) deallocate(tile_size) + allocate(tile_size(2,(size(local_mesh_names)))) + tile_size = imdi + if (coarsen_multigrid_tiles) then + extrusion_id = extrusion%get_id() select case (extrusion_id) case(prime_extrusion, shifted, double_level) @@ -80,10 +83,6 @@ function get_multigrid_tile_size( config, local_mesh_names, extrusion) & call log_event('no max multigrid level set', log_level_error) end if - if (allocated(tile_size)) deallocate(tile_size) - allocate(tile_size(2,(size(local_mesh_names)))) - tile_size = imdi - do i=1, size(local_mesh_names) set_tile_size = .false. name =local_mesh_names(i) diff --git a/components/science/source/algorithm/sci_mapping_constants_mod.x90 b/components/science/source/algorithm/sci_mapping_constants_mod.x90 index f6e2c9950..3f65e4b2f 100644 --- a/components/science/source/algorithm/sci_mapping_constants_mod.x90 +++ b/components/science/source/algorithm/sci_mapping_constants_mod.x90 @@ -1259,7 +1259,9 @@ contains !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The projection operator - function get_project_r_dot_to_w1( mesh_id, geometry, topology, coord_system, scaled_radius ) result(proj_op) + function get_project_r_dot_to_w1( mesh_id, & + geometry, topology, & + coord_system, scaled_radius ) result(proj_op) implicit none From 41c315121ef35191df5980c9a33384bc1f986635 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 1 Apr 2026 11:39:04 +0100 Subject: [PATCH 21/44] Updates --- .../coupled/source/driver/coupled_driver_mod.f90 | 15 ++++++++++----- .../io_demo/source/driver/io_demo_driver_mod.f90 | 15 ++++++++++----- .../source/driver/lbc_demo_driver_mod.f90 | 16 +++++++++++----- .../driver/simple_diffusion_driver_mod.f90 | 16 +++++++++++----- .../source/driver/skeleton_driver_mod.f90 | 16 +++++++++++----- 5 files changed, 53 insertions(+), 25 deletions(-) diff --git a/applications/coupled/source/driver/coupled_driver_mod.f90 b/applications/coupled/source/driver/coupled_driver_mod.f90 index c94fa4b0c..831361115 100644 --- a/applications/coupled/source/driver/coupled_driver_mod.f90 +++ b/applications/coupled/source/driver/coupled_driver_mod.f90 @@ -75,7 +75,8 @@ subroutine initialise( program_name, modeldb, calendar ) integer(i_def) :: geometry integer(i_def) :: method integer(i_def) :: number_of_layers - integer(i_def) :: tile_size(2) + integer(i_def) :: tile_size_x + integer(i_def) :: tile_size_y real(r_def) :: domain_bottom real(r_def) :: domain_height real(r_def) :: scaled_radius @@ -84,6 +85,7 @@ subroutine initialise( program_name, modeldb, calendar ) logical :: inner_halo_tiles logical :: prepartitioned + integer(i_def), allocatable :: tile_size(:,:) integer(i_def) :: i integer(i_def), parameter :: one_layer = 1_i_def @@ -98,12 +100,12 @@ subroutine initialise( program_name, modeldb, calendar ) prepartitioned = modeldb%config%base_mesh%prepartitioned() if (prepartitioned) then - tile_size(1) = 1 - tile_size(2) = 1 + tile_size_x = 1 + tile_size_y = 1 inner_halo_tiles = .false. else - tile_size(1) = modeldb%config%partitioning%tile_size_x() - tile_size(2) = modeldb%config%partitioning%tile_size_y() + tile_size_x = modeldb%config%partitioning%tile_size_x() + tile_size_y = modeldb%config%partitioning%tile_size_y() inner_halo_tiles = modeldb%config%partitioning%inner_halo_tiles() end if @@ -135,6 +137,9 @@ subroutine initialise( program_name, modeldb, calendar ) ! Create the required meshes stencil_depth = 1 apply_partition_check = .false. + allocate(tile_size(2,size(base_mesh_names))) + tile_size(1,:) = tile_size_x + tile_size(2,:) = tile_size_y call init_mesh( modeldb%config, & modeldb%mpi%get_comm_rank(), & modeldb%mpi%get_comm_size(), & diff --git a/applications/io_demo/source/driver/io_demo_driver_mod.f90 b/applications/io_demo/source/driver/io_demo_driver_mod.f90 index f26f3be0a..d072aebb2 100644 --- a/applications/io_demo/source/driver/io_demo_driver_mod.f90 +++ b/applications/io_demo/source/driver/io_demo_driver_mod.f90 @@ -87,7 +87,8 @@ subroutine initialise(program_name, modeldb) integer(i_def) :: geometry integer(i_def) :: method integer(i_def) :: number_of_layers - integer(i_def) :: tile_size(2) + integer(i_def) :: tile_size_x + integer(i_def) :: tile_size_y real(r_def) :: domain_bottom real(r_def) :: domain_height real(r_def) :: scaled_radius @@ -98,6 +99,7 @@ subroutine initialise(program_name, modeldb) logical :: multifile_io logical :: io_benchmark + integer(i_def), allocatable :: tile_size(:,:) integer(i_def), parameter :: one_layer = 1_i_def integer(i_def) :: i @@ -119,12 +121,12 @@ subroutine initialise(program_name, modeldb) io_benchmark = modeldb%config%io_demo%io_benchmark() if (prepartitioned) then - tile_size(1) = 1 - tile_size(2) = 1 + tile_size_x = 1 + tile_size_y = 1 inner_halo_tiles = .false. else - tile_size(1) = modeldb%config%partitioning%tile_size_x() - tile_size(2) = modeldb%config%partitioning%tile_size_y() + tile_size_x = modeldb%config%partitioning%tile_size_x() + tile_size_y = modeldb%config%partitioning%tile_size_y() inner_halo_tiles = modeldb%config%partitioning%inner_halo_tiles() end if @@ -175,6 +177,9 @@ subroutine initialise(program_name, modeldb) ! --------------------------------------------------------- stencil_depth = 1 check_partitions = .false. + allocate(tile_size(2,size(base_mesh_names))) + tile_size(1,:) = tile_size_x + tile_size(2,:) = tile_size_y call init_mesh( modeldb%config, & modeldb%mpi%get_comm_rank(), & modeldb%mpi%get_comm_size(), & diff --git a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 index c9b126878..28ea706c3 100644 --- a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 +++ b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 @@ -86,7 +86,8 @@ subroutine initialise( program_name, modeldb) integer(i_def) :: geometry integer(i_def) :: method integer(i_def) :: number_of_layers - integer(i_def) :: tile_size(2) + integer(i_def) :: tile_size_x + integer(i_def) :: tile_size_y real(r_def) :: domain_bottom real(r_def) :: domain_height real(r_def) :: scaled_radius @@ -104,6 +105,7 @@ subroutine initialise( program_name, modeldb) integer :: i + integer(i_def), allocatable :: tile_size(:,:) integer(i_def), parameter :: one_layer = 1_i_def !======================================================================= @@ -119,12 +121,12 @@ subroutine initialise( program_name, modeldb) prepartitioned = modeldb%config%base_mesh%prepartitioned() if (prepartitioned) then - tile_size(1) = 1 - tile_size(2) = 1 + tile_size_x = 1 + tile_size_y = 1 inner_halo_tiles = .false. else - tile_size(1) = modeldb%config%partitioning%tile_size_x() - tile_size(2) = modeldb%config%partitioning%tile_size_y() + tile_size_x = modeldb%config%partitioning%tile_size_x() + tile_size_y = modeldb%config%partitioning%tile_size_y() inner_halo_tiles = modeldb%config%partitioning%inner_halo_tiles() end if @@ -198,6 +200,10 @@ subroutine initialise( program_name, modeldb) !------------------------------------------------------------------------- stencil_depth = 1 check_partitions = .false. + allocate(tile_size(2,size(base_mesh_names))) + tile_size(1,:) = tile_size_x + tile_size(2,:) = tile_size_y + call init_mesh( modeldb%config, & modeldb%mpi%get_comm_rank(), & modeldb%mpi%get_comm_size(), & diff --git a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 index 4812c5af5..8853926ef 100644 --- a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 +++ b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 @@ -84,7 +84,8 @@ subroutine initialise( program_name, modeldb) integer(i_def) :: geometry integer(i_def) :: method integer(i_def) :: number_of_layers - integer(i_def) :: tile_size(2) + integer(i_def) :: tile_size_x + integer(i_def) :: tile_size_y real(r_def) :: domain_bottom real(r_def) :: domain_height real(r_def) :: scaled_radius @@ -93,6 +94,7 @@ subroutine initialise( program_name, modeldb) logical :: inner_halo_tiles logical :: prepartitioned + integer(i_def), allocatable :: tile_size(:,:) integer(i_def), parameter :: one_layer = 1_i_def integer(i_def) :: i @@ -108,12 +110,12 @@ subroutine initialise( program_name, modeldb) prepartitioned = modeldb%config%base_mesh%prepartitioned() if (prepartitioned) then - tile_size(1) = 1 - tile_size(2) = 1 + tile_size_x = 1 + tile_size_y = 1 inner_halo_tiles = .false. else - tile_size(1) = modeldb%config%partitioning%tile_size_x() - tile_size(2) = modeldb%config%partitioning%tile_size_y() + tile_size_x = modeldb%config%partitioning%tile_size_x() + tile_size_y = modeldb%config%partitioning%tile_size_y() inner_halo_tiles = modeldb%config%partitioning%inner_halo_tiles() end if @@ -164,6 +166,10 @@ subroutine initialise( program_name, modeldb) ! --------------------------------------------------------- stencil_depth = 1 check_partitions = .false. + allocate(tile_size(2,size(base_mesh_names))) + tile_size(1,:) = tile_size_x + tile_size(2,:) = tile_size_y + call init_mesh( modeldb%config, & modeldb%mpi%get_comm_rank(), & modeldb%mpi%get_comm_size(), & diff --git a/applications/skeleton/source/driver/skeleton_driver_mod.f90 b/applications/skeleton/source/driver/skeleton_driver_mod.f90 index 2498bb0ee..7ea174ca3 100644 --- a/applications/skeleton/source/driver/skeleton_driver_mod.f90 +++ b/applications/skeleton/source/driver/skeleton_driver_mod.f90 @@ -79,7 +79,8 @@ subroutine initialise(program_name, modeldb) integer(i_def) :: geometry integer(i_def) :: method integer(i_def) :: number_of_layers - integer(i_def) :: tile_size(2) + integer(i_def) :: tile_size_x + integer(i_def) :: tile_size_y real(r_def) :: domain_bottom real(r_def) :: domain_height real(r_def) :: scaled_radius @@ -88,6 +89,7 @@ subroutine initialise(program_name, modeldb) logical :: inner_halo_tiles logical :: prepartitioned + integer(i_def), allocatable :: tile_size(:,:) integer(i_def) :: i integer(i_def), parameter :: one_layer = 1_i_def @@ -109,12 +111,12 @@ subroutine initialise(program_name, modeldb) prepartitioned = modeldb%config%base_mesh%prepartitioned() if (prepartitioned) then - tile_size(1) = 1 - tile_size(2) = 1 + tile_size_x = 1 + tile_size_y = 1 inner_halo_tiles = .false. else - tile_size(1) = modeldb%config%partitioning%tile_size_x() - tile_size(2) = modeldb%config%partitioning%tile_size_y() + tile_size_x = modeldb%config%partitioning%tile_size_x() + tile_size_y = modeldb%config%partitioning%tile_size_y() inner_halo_tiles = modeldb%config%partitioning%inner_halo_tiles() end if @@ -156,6 +158,10 @@ subroutine initialise(program_name, modeldb) !----------------------------------------------------------------------- stencil_depth = 1 apply_partition_check = .false. + allocate(tile_size(2,size(base_mesh_names))) + tile_size(1,:) = tile_size_x + tile_size(2,:) = tile_size_y + call init_mesh( modeldb%config, & modeldb%mpi%get_comm_rank(), & modeldb%mpi%get_comm_size(), & From c1220e0889cbb811951f09ff2d58d53c3bf734c6 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Thu, 2 Apr 2026 11:53:28 +0100 Subject: [PATCH 22/44] Tidy up and don't pass config type to initialise lfrix-xios as it will run foul of some apps --- .../driver/multifile_io/multifile_io_mod.F90 | 17 +++++-- components/driver/source/driver_io_mod.F90 | 26 +++++++--- .../lfric_xios_context_test.f90 | 12 +++-- .../lfric_xios_cyclic_temporal_test.f90 | 11 ++-- .../lfric_xios_temporal_iodef_test.f90 | 12 +++-- .../lfric_xios_temporal_test.f90 | 11 ++-- .../lfric_xios_time_read_test.f90 | 11 ++-- .../integration-test/test_db_mod.f90 | 2 +- .../source/lfric_xios_context_mod.f90 | 24 ++++++--- .../source/lfric_xios_setup_mod.x90 | 51 ++++++++++--------- 10 files changed, 117 insertions(+), 60 deletions(-) diff --git a/applications/io_demo/source/driver/multifile_io/multifile_io_mod.F90 b/applications/io_demo/source/driver/multifile_io/multifile_io_mod.F90 index 78bb61e9e..5f2acba77 100644 --- a/applications/io_demo/source/driver/multifile_io/multifile_io_mod.F90 +++ b/applications/io_demo/source/driver/multifile_io/multifile_io_mod.F90 @@ -9,7 +9,7 @@ module multifile_io_mod use calendar_mod, only: calendar_type - use constants_mod, only: str_def, i_def + use constants_mod, only: str_def, i_def, r_def use driver_model_data_mod, only: model_data_type use driver_modeldb_mod, only: modeldb_type use empty_io_context_mod, only: empty_io_context_type @@ -123,11 +123,21 @@ subroutine step_multifile_io(modeldb, chi_inventory, panel_id_inventory) procedure(event_action), pointer :: context_advance procedure(callback_clock_arg), pointer :: before_close + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + nullify(mesh) nullify(chi) nullify(panel_id) nullify(before_close) + geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() + coord_system = modeldb%config%finite_element%coord_system() + scaled_radius = modeldb%config%planet%scaled_radius() + call iter%initialise(modeldb%config%multifile_io) do while (iter%has_next()) @@ -159,11 +169,12 @@ subroutine step_multifile_io(modeldb, chi_inventory, panel_id_inventory) allocate(tmp_calendar, source=step_calendar_type(time_origin, time_start)) - call io_context%initialise_xios_context( modeldb%config, & - modeldb%mpi%get_comm(), & + call io_context%initialise_xios_context( modeldb%mpi%get_comm(), & chi, panel_id, & modeldb%clock, tmp_calendar, & before_close, & + geometry, topology, & + coord_system, scaled_radius, & start_at_zero=.true. ) ! Attach context advancement to the model's clock diff --git a/components/driver/source/driver_io_mod.F90 b/components/driver/source/driver_io_mod.F90 index d1301dbba..a4f69a324 100644 --- a/components/driver/source/driver_io_mod.F90 +++ b/components/driver/source/driver_io_mod.F90 @@ -10,7 +10,7 @@ !> module driver_io_mod - use constants_mod, only: str_def, i_def, l_def + use constants_mod, only: str_def, i_def, l_def, r_def use driver_modeldb_mod, only: modeldb_type use driver_model_data_mod, only: model_data_type use empty_io_context_mod, only: empty_io_context_type @@ -197,6 +197,11 @@ subroutine init_xios_io_context( context_name, & integer(i_def) :: num_meshes, i, j + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + mesh => null() chi => null() panel_id => null() @@ -207,6 +212,11 @@ subroutine init_xios_io_context( context_name, & !============================================================== + geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() + coord_system = modeldb%config%finite_element%coord_system() + scaled_radius = modeldb%config%planet%scaled_radius() + call tmp_io_context%initialise(context_name) call modeldb%io_contexts%add_context(tmp_io_context) call modeldb%io_contexts%get_io_context(context_name, io_context) @@ -251,23 +261,27 @@ subroutine init_xios_io_context( context_name, & call alt_panel_id_ptr%copy_field_serial(alt_panel_ids(i)) end do - call io_context%initialise_xios_context( modeldb%config, & - modeldb%mpi%get_comm(), & + call io_context%initialise_xios_context( modeldb%mpi%get_comm(), & chi, panel_id, & modeldb%clock, & modeldb%calendar, & before_close, & + geometry, topology, & + coord_system, & + scaled_radius, & alt_coords, & alt_panel_ids ) deallocate(alt_coords) deallocate(alt_panel_ids) else - call io_context%initialise_xios_context( modeldb%config, & - modeldb%mpi%get_comm(), & + call io_context%initialise_xios_context( modeldb%mpi%get_comm(), & chi, panel_id, & modeldb%clock, & modeldb%calendar, & - before_close ) + before_close, & + geometry, topology, & + coord_system, & + scaled_radius ) end if ! Attach context advancement to the model's clock diff --git a/components/lfric-xios/integration-test/lfric_xios_context_test.f90 b/components/lfric-xios/integration-test/lfric_xios_context_test.f90 index cedb3edbd..73811cecf 100644 --- a/components/lfric-xios/integration-test/lfric_xios_context_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_context_test.f90 @@ -32,11 +32,15 @@ program lfric_xios_context_test allocate(io_context) call io_context%initialise( "test_io_context", 1, 10 ) - call io_context%initialise_xios_context( test_db%config, & - test_db%comm, & - test_db%chi, test_db%panel_id, & + call io_context%initialise_xios_context( test_db%comm, & + test_db%chi, test_db%panel_id, & test_db%clock, test_db%calendar, & - before_close ) + before_close, & + test_db%config%base_mesh%geometry(), & + test_db%config%base_mesh%topology(), & + test_db%config%finite_element%coord_system(), & + test_db%config%planet%scaled_radius() ) + deallocate(io_context) ! ============================== Finish test ================================= diff --git a/components/lfric-xios/integration-test/lfric_xios_cyclic_temporal_test.f90 b/components/lfric-xios/integration-test/lfric_xios_cyclic_temporal_test.f90 index ec17738e4..a67048327 100644 --- a/components/lfric-xios/integration-test/lfric_xios_cyclic_temporal_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_cyclic_temporal_test.f90 @@ -64,11 +64,14 @@ program lfric_xios_cyclic_temporal_test fields_in_file=test_db%temporal_fields ) ) before_close => null() - call io_context%initialise_xios_context( test_db%config, & - test_db%comm, & - test_db%chi, test_db%panel_id, & + call io_context%initialise_xios_context( test_db%comm, & + test_db%chi, test_db%panel_id, & test_db%clock, test_db%calendar, & - before_close ) + before_close, & + test_db%config%base_mesh%geometry(), & + test_db%config%base_mesh%topology(), & + test_db%config%finite_element%coord_system(), & + test_db%config%planet%scaled_radius() ) context_advance => advance diff --git a/components/lfric-xios/integration-test/lfric_xios_temporal_iodef_test.f90 b/components/lfric-xios/integration-test/lfric_xios_temporal_iodef_test.f90 index 2689e3d27..1c3e8a303 100644 --- a/components/lfric-xios/integration-test/lfric_xios_temporal_iodef_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_temporal_iodef_test.f90 @@ -58,12 +58,14 @@ program lfric_xios_temporal_iodef_test fields_in_file=test_db%temporal_fields ) ) before_close => null() - call io_context%initialise_xios_context( test_db%config, & - test_db%comm, & - test_db%chi, test_db%panel_id, & + call io_context%initialise_xios_context( test_db%comm, & + test_db%chi, test_db%panel_id, & test_db%clock, test_db%calendar, & - before_close ) - + before_close, & + test_db%config%base_mesh%geometry(), & + test_db%config%base_mesh%topology(), & + test_db%config%finite_element%coord_system(), & + test_db%config%planet%scaled_radius() ) context_advance => advance context_actor => io_context diff --git a/components/lfric-xios/integration-test/lfric_xios_temporal_test.f90 b/components/lfric-xios/integration-test/lfric_xios_temporal_test.f90 index 57bb0d047..572ce0193 100644 --- a/components/lfric-xios/integration-test/lfric_xios_temporal_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_temporal_test.f90 @@ -62,11 +62,14 @@ program lfric_xios_temporal_test fields_in_file=test_db%temporal_fields ) ) before_close => null() - call io_context%initialise_xios_context( test_db%config, & - test_db%comm, & - test_db%chi, test_db%panel_id, & + call io_context%initialise_xios_context( test_db%comm, & + test_db%chi, test_db%panel_id, & test_db%clock, test_db%calendar, & - before_close ) + before_close, & + test_db%config%base_mesh%geometry(), & + test_db%config%base_mesh%topology(), & + test_db%config%finite_element%coord_system(), & + test_db%config%planet%scaled_radius() ) context_advance => advance diff --git a/components/lfric-xios/integration-test/lfric_xios_time_read_test.f90 b/components/lfric-xios/integration-test/lfric_xios_time_read_test.f90 index c108a2a99..2f453a381 100755 --- a/components/lfric-xios/integration-test/lfric_xios_time_read_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_time_read_test.f90 @@ -31,11 +31,14 @@ program lfric_xios_time_read_test allocate(io_context) call io_context%initialise( "test_io_context", 1, 10 ) - call io_context%initialise_xios_context( test_db%config, & - test_db%comm, & - test_db%chi, test_db%panel_id, & + call io_context%initialise_xios_context( test_db%comm, & + test_db%chi, test_db%panel_id, & test_db%clock, test_db%calendar, & - before_close ) + before_close, & + test_db%config%base_mesh%geometry(), & + test_db%config%base_mesh%topology(), & + test_db%config%finite_element%coord_system(), & + test_db%config%planet%scaled_radius() ) allocate(check(10)) check = [ xios_date(2024, 1, 1, 15, 1, 0), & diff --git a/components/lfric-xios/integration-test/test_db_mod.f90 b/components/lfric-xios/integration-test/test_db_mod.f90 index 028dc97cb..f2f95e485 100644 --- a/components/lfric-xios/integration-test/test_db_mod.f90 +++ b/components/lfric-xios/integration-test/test_db_mod.f90 @@ -9,6 +9,7 @@ module test_db_mod use calendar_mod, only: calendar_type use cli_mod, only: parse_command_line + use config_mod, only: config_type use config_loader_mod, only: read_configuration use constants_mod, only: i_def, r_def, str_def, imdi, & r_second, i_timestep @@ -31,7 +32,6 @@ module test_db_mod finalise_logging, & log_set_level, log_event, & LOG_LEVEL_TRACE, LOG_LEVEL_ERROR - use config_mod, only: config_type use lfric_xios_read_mod, only: read_field_generic use lfric_xios_write_mod, only: write_field_generic use local_mesh_collection_mod, only: local_mesh_collection_type, & diff --git a/components/lfric-xios/source/lfric_xios_context_mod.f90 b/components/lfric-xios/source/lfric_xios_context_mod.f90 index 7845afb0a..e4b5429c5 100644 --- a/components/lfric-xios/source/lfric_xios_context_mod.f90 +++ b/components/lfric-xios/source/lfric_xios_context_mod.f90 @@ -9,8 +9,7 @@ module lfric_xios_context_mod use calendar_mod, only : calendar_type use clock_mod, only : clock_type - use config_mod, only : config_type - use constants_mod, only : i_def, & + use constants_mod, only : i_def, r_def, & r_second, i_timestep, & l_def use field_mod, only : field_type @@ -82,20 +81,26 @@ end subroutine initialise_lfric_xios_context !> @brief Set up an XIOS context. !> - !> @param [in] config Configuration object. !> @param [in] communicator MPI communicator used by context. !> @param [in] chi Array of coordinate fields !> @param [in] panel_id Panel ID field !> @param [in] model_clock The model clock. !> @param [in] calendar The model calendar. !> @param [in] before_close Routine to be called before context closes + !> @param [in] geometry + !> @param [in] topology + !> @param [in] coord_system + !> @param [in] scaled_radius !> @param [in] alt_coords Array of coordinate fields for alternative meshes !> @param [in] alt_panel_ids Panel ID fields for alternative meshes subroutine initialise_xios_context( this, & - config, communicator, & + communicator, & chi, panel_id, & model_clock, calendar, & before_close, & + geometry, topology, & + coord_system, & + scaled_radius, & alt_coords, & alt_panel_ids, & start_at_zero ) @@ -104,7 +109,6 @@ subroutine initialise_xios_context( this, & class(lfric_xios_context_type), intent(inout) :: this - type(config_type), intent(in) :: config type(lfric_comm_type), intent(in) :: communicator type(field_type), intent(in) :: chi(:) type(field_type), intent(in) :: panel_id @@ -112,6 +116,12 @@ subroutine initialise_xios_context( this, & class(calendar_type), intent(in) :: calendar procedure(callback_clock_arg), pointer, & intent(in) :: before_close + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + integer(i_def), intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + type(field_type), optional, intent(in) :: alt_coords(:,:) type(field_type), optional, intent(in) :: alt_panel_ids(:) logical, optional, intent(in) :: start_at_zero @@ -139,7 +149,9 @@ subroutine initialise_xios_context( this, & ! Run XIOS setup routines call init_xios_calendar(model_clock, calendar, zero_start, this%context_clock_step) - call init_xios_dimensions(config, chi, panel_id, alt_coords, alt_panel_ids) + call init_xios_dimensions( chi, panel_id, geometry, topology, & + coord_system, scaled_radius, & + alt_coords, alt_panel_ids ) if (this%filelist%get_length() > 0) call setup_xios_files(this%filelist) if (associated(before_close)) call before_close(model_clock) diff --git a/components/lfric-xios/source/lfric_xios_setup_mod.x90 b/components/lfric-xios/source/lfric_xios_setup_mod.x90 index ee1a5881d..a8e3795ea 100644 --- a/components/lfric-xios/source/lfric_xios_setup_mod.x90 +++ b/components/lfric-xios/source/lfric_xios_setup_mod.x90 @@ -10,7 +10,6 @@ module lfric_xios_setup_mod use calendar_mod, only: calendar_type use clock_mod, only: clock_type - use config_mod, only: config_type use constants_mod, only: i_def, i_halo_index, i_timestep, & r_def, l_def, str_def, & radians_to_degrees @@ -158,15 +157,22 @@ contains !> @param[in] chi Coordinate field !> @param[in] panel_id Field with IDs of mesh panels !> - subroutine init_xios_dimensions(config, chi, panel_id, alt_coords, alt_panel_ids) + subroutine init_xios_dimensions( chi, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + alt_coords, alt_panel_ids ) implicit none - type(config_type), intent(in) :: config - ! Arguments - type(field_type), intent(in) :: chi(:) - type(field_type), intent(in) :: panel_id + type(field_type), intent(in) :: chi(:) + type(field_type), intent(in) :: panel_id + + integer(i_def),intent(in) :: geometry + integer(i_def),intent(in) :: topology + integer(i_def),intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + type(field_type), optional, intent(in) :: alt_coords(:,:) type(field_type), optional, intent(in) :: alt_panel_ids(:) @@ -174,14 +180,16 @@ contains type(mesh_type), pointer :: mesh => null() ! Initialise XIOS prime mesh - call init_xios_mesh(config, chi, panel_id, prime_mesh=.true.) + call init_xios_mesh( chi, panel_id, geometry, topology, & + coord_system, scaled_radius, & + prime_mesh=.true. ) ! Initialise additional meshes if (present(alt_coords) .and. present(alt_panel_ids)) then do i = 1, size(alt_panel_ids) - call init_xios_mesh( config, alt_coords(i,:), & - alt_panel_ids(i), & - prime_mesh=.false. ) + call init_xios_mesh( alt_coords(i,:), alt_panel_ids(i), & + geometry, topology, coord_system, & + scaled_radius, prime_mesh=.false. ) end do end if @@ -205,15 +213,22 @@ contains !> @param[in] prime_mesh Logical flag denoting if the mesh is the primary !! I/O mesh !> - subroutine init_xios_mesh(config, chi, panel_id, prime_mesh) + subroutine init_xios_mesh( chi, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + prime_mesh ) implicit none - type(config_type), intent(in) :: config - ! Arguments type(field_type), intent(in) :: chi(:) type(field_type), intent(in) :: panel_id + + integer(i_def),intent(in) :: geometry + integer(i_def),intent(in) :: topology + integer(i_def),intent(in) :: coord_system + real(r_def), intent(in) :: scaled_radius + logical, optional, intent(in) :: prime_mesh ! Local variables @@ -271,16 +286,6 @@ contains logical :: mesh_is_prime_mesh - integer(i_def) :: geometry - integer(i_def) :: topology - integer(i_def) :: coord_system - real(r_def) :: scaled_radius - - geometry = config%base_mesh%geometry() - topology = config%base_mesh%topology() - coord_system = config%finite_element%coord_system() - scaled_radius = config%planet%scaled_radius() - ! Set optional prime_mesh_flag if (present(prime_mesh)) then mesh_is_prime_mesh = prime_mesh From e1396eb95b79bb207b55c2b3e6e3dea7e215a940 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Fri, 3 Apr 2026 16:41:42 +0100 Subject: [PATCH 23/44] Passing geometry and toplogy as lfric2lfric may not be using base mesh --- .../io_demo/source/driver/io_demo_driver_mod.f90 | 7 +++++-- .../source/driver/lbc_demo_driver_mod.f90 | 3 ++- .../driver/simple_diffusion_driver_mod.f90 | 7 +++++-- components/driver/source/driver_io_mod.F90 | 16 ++++++++++++---- 4 files changed, 24 insertions(+), 9 deletions(-) diff --git a/applications/io_demo/source/driver/io_demo_driver_mod.f90 b/applications/io_demo/source/driver/io_demo_driver_mod.f90 index d072aebb2..5c257d8de 100644 --- a/applications/io_demo/source/driver/io_demo_driver_mod.f90 +++ b/applications/io_demo/source/driver/io_demo_driver_mod.f90 @@ -85,6 +85,7 @@ subroutine initialise(program_name, modeldb) integer(i_def) :: stencil_depth(1) integer(i_def) :: geometry + integer(i_def) :: topology integer(i_def) :: method integer(i_def) :: number_of_layers integer(i_def) :: tile_size_x @@ -112,6 +113,7 @@ subroutine initialise(program_name, modeldb) !======================================================================= prime_mesh_name = modeldb%config%base_mesh%prime_mesh_name() geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() method = modeldb%config%extrusion%method() domain_height = modeldb%config%extrusion%domain_height() number_of_layers = modeldb%config%extrusion%number_of_layers() @@ -222,10 +224,11 @@ subroutine initialise(program_name, modeldb) if (associated(files_init_ptr)) then call init_io( program_name, prime_mesh_name, modeldb, & chi_inventory, panel_id_inventory, & - populate_filelist=files_init_ptr ) + geometry, topology, populate_filelist=files_init_ptr ) else call init_io( program_name, prime_mesh_name, modeldb, & - chi_inventory, panel_id_inventory ) + chi_inventory, panel_id_inventory, & + geometry, topology ) end if diff --git a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 index 28ea706c3..61c8b476d 100644 --- a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 +++ b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 @@ -250,7 +250,8 @@ subroutine initialise( program_name, modeldb) call log_event(log_scratch_space, log_level_info) call init_io( context_name, output_mesh_name, modeldb, & - chi_inventory, panel_id_inventory ) + chi_inventory, panel_id_inventory, & + geometry, topology ) end if !======================================================================= diff --git a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 index 8853926ef..d5b8e3340 100644 --- a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 +++ b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 @@ -82,6 +82,7 @@ subroutine initialise( program_name, modeldb) integer(i_def) :: stencil_depth(1) integer(i_def) :: geometry + integer(i_def) :: topology integer(i_def) :: method integer(i_def) :: number_of_layers integer(i_def) :: tile_size_x @@ -103,6 +104,7 @@ subroutine initialise( program_name, modeldb) !======================================================================= prime_mesh_name = modeldb%config%base_mesh%prime_mesh_name() geometry = modeldb%config%base_mesh%geometry() + topology = modeldb%config%base_mesh%topology() method = modeldb%config%extrusion%method() domain_height = modeldb%config%extrusion%domain_height() number_of_layers = modeldb%config%extrusion%number_of_layers() @@ -196,8 +198,9 @@ subroutine initialise( program_name, modeldb) ! 3.0 Setup I/O system. !======================================================================= ! Initialise I/O context - call init_io( program_name, prime_mesh_name, & - modeldb, chi_inventory, panel_id_inventory ) + call init_io( program_name, prime_mesh_name, modeldb, & + chi_inventory, panel_id_inventory, & + geometry, topology ) !======================================================================= diff --git a/components/driver/source/driver_io_mod.F90 b/components/driver/source/driver_io_mod.F90 index a4f69a324..fba59c0ae 100644 --- a/components/driver/source/driver_io_mod.F90 +++ b/components/driver/source/driver_io_mod.F90 @@ -68,10 +68,12 @@ subroutine init_io( context_name, & modeldb, & chi_inventory, & panel_id_inventory, & + geometry, topology, & populate_filelist, & alt_mesh_names, & before_close ) + implicit none character(*), intent(in) :: context_name @@ -79,6 +81,10 @@ subroutine init_io( context_name, & class(modeldb_type), intent(inout) :: modeldb type(inventory_by_mesh_type), intent(in) :: chi_inventory type(inventory_by_mesh_type), intent(in) :: panel_id_inventory + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + procedure(filelist_populator), & pointer, optional, intent(in) :: populate_filelist character(len=str_def), optional, intent(in) :: alt_mesh_names(:) @@ -105,6 +111,7 @@ subroutine init_io( context_name, & chi_inventory, & panel_id_inventory, & before_close_ptr, & + geometry, topology, & populate_filelist, & alt_mesh_names ) #else @@ -165,6 +172,7 @@ subroutine init_xios_io_context( context_name, & chi_inventory, & panel_id_inventory, & before_close, & + geometry, topology, & populate_filelist, & alt_mesh_names ) @@ -176,6 +184,10 @@ subroutine init_xios_io_context( context_name, & type(inventory_by_mesh_type), intent(in) :: chi_inventory type(inventory_by_mesh_type), intent(in) :: panel_id_inventory procedure(callback_clock_arg), pointer, intent(in) :: before_close + + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology + procedure(filelist_populator), & pointer, optional, intent(in) :: populate_filelist character(len=str_def), optional, intent(in) :: alt_mesh_names(:) @@ -197,8 +209,6 @@ subroutine init_xios_io_context( context_name, & integer(i_def) :: num_meshes, i, j - integer(i_def) :: geometry - integer(i_def) :: topology integer(i_def) :: coord_system real(r_def) :: scaled_radius @@ -212,8 +222,6 @@ subroutine init_xios_io_context( context_name, & !============================================================== - geometry = modeldb%config%base_mesh%geometry() - topology = modeldb%config%base_mesh%topology() coord_system = modeldb%config%finite_element%coord_system() scaled_radius = modeldb%config%planet%scaled_radius() From c3cbd141c5f822e8e4a0bd825f2575e3343dd475 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 22 Apr 2026 10:00:12 +0100 Subject: [PATCH 24/44] Some tidy up, doxygen comments --- .../driver/source/driver_coordinates_mod.F90 | 49 +- components/driver/source/driver_fem_mod.f90 | 6 +- components/driver/source/driver_io_mod.F90 | 36 +- components/driver/source/driver_log_mod.f90 | 6 +- components/driver/source/driver_mesh_mod.f90 | 2 + .../driver/source/mesh/create_mesh_mod.f90 | 104 +- .../driver/source/mesh/multigrid_mod.f90 | 18 +- .../source/lfric_xios_context_mod.f90 | 24 +- .../source/lfric_xios_setup_mod.x90 | 11 +- .../algorithm/sci_geometric_constants_mod.x90 | 251 +-- .../sci_geometric_constants_mod.x90.orig | 1531 +++++++++++++++++ .../algorithm/sci_mapping_constants_mod.x90 | 140 +- .../kernel/geometry/sci_chi_transform_mod.F90 | 75 +- .../sci_compute_latlon_kernel_mod.F90 | 29 +- .../sci_nodal_xyz_coordinates_kernel_mod.F90 | 27 +- ...sci_compute_map_u_operators_kernel_mod.F90 | 37 +- .../sci_compute_sample_u_ops_kernel_mod.F90 | 36 +- .../sci_convert_phys_to_hdiv_kernel_mod.F90 | 12 +- ...i_project_ws_to_w1_operator_kernel_mod.F90 | 8 +- .../sci_w3_to_w2_displacement_kernel_mod.F90 | 22 +- .../fem/gp_vector_rhs_kernel_mod_test.pf | 16 +- .../kernel/geometry/chi_transform_mod_test.pf | 11 +- .../compute_latlon_kernel_mod_test.pf | 6 +- 23 files changed, 1927 insertions(+), 530 deletions(-) create mode 100644 components/science/source/algorithm/sci_geometric_constants_mod.x90.orig diff --git a/components/driver/source/driver_coordinates_mod.F90 b/components/driver/source/driver_coordinates_mod.F90 index bbab70901..04983b088 100644 --- a/components/driver/source/driver_coordinates_mod.F90 +++ b/components/driver/source/driver_coordinates_mod.F90 @@ -7,7 +7,6 @@ !> @brief Module to assign the values of the coordinates of the mesh to a field. module driver_coordinates_mod -! use config_mod, only: config_type use constants_mod, only: r_def, i_def, l_def, & radians_to_degrees, & i_halo_index, eps, pi @@ -52,10 +51,13 @@ module driver_coordinates_mod !! from the mesh generator and then 'assign_coordinate' on a column by !! column basis. !> - !> @param[in] config Configuration object !> @param[in,out] chi Model coordinate array of size 3 of fields !> @param[in] panel_id Field giving the ID of mesh panels !> @param[in] mesh Mesh on which this field is attached + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-element coordinate syatem enumeration value + !> @param[in] scaled_radius Scaled planet radius subroutine assign_coordinate_field(chi, panel_id, mesh, & geometry, topology, & coord_system, scaled_radius ) @@ -71,8 +73,6 @@ subroutine assign_coordinate_field(chi, panel_id, mesh, & implicit none -! type(config_type), intent(in) :: config - type( field_type ), intent( inout ) :: chi(3) type( field_type ), intent( inout ) :: panel_id type( mesh_type ), intent( in ), pointer :: mesh @@ -95,7 +95,7 @@ subroutine assign_coordinate_field(chi, panel_id, mesh, & real(kind=r_def) :: domain_min_y real(kind=r_def), allocatable :: column_coords(:,:,:) - real(kind=r_def), allocatable :: dz(:) ! dz(nlayers) array + real(kind=r_def), allocatable :: dz(:) real(kind=r_def), allocatable :: vertex_coords(:,:) integer(i_def) :: cell @@ -115,11 +115,6 @@ subroutine assign_coordinate_field(chi, panel_id, mesh, & real(kind=r_def) :: inverse_rot_matrix(3,3) real(kind=r_def) :: stretch_factor -!!$ geometry = config%base_mesh%geometry() -!!$ topology = config%base_mesh%topology() -!!$ coord_system = config%finite_element%coord_system() -!!$ scaled_radius = config%planet%scaled_radius() - nullify( map, map_pid, dof_coords, reference_element ) ! Break encapsulation and get the proxy. @@ -319,15 +314,15 @@ end subroutine assign_coordinate_field !! be the panel IDs which are calculated from the coordinates. !! For planar geometry the ID is just 1 everywhere. !> - !> @param[in] nlayers Number of layers for the panel_id field - !> @param[in] ndf_pid Number of DoFs per cell for the panel_id field - !> @param[in] undf_pid Universal number of DoFs for the panel_id field - !> @param[in] map_pid DoF map for the panel_id field - !> @param[out] panel_id Field (to be calculated) with the ID of cubed sphere panels - !> @param[in] geometry - !> @param[in] topology - !> @param[in] global_dof_id Array of global id's - !> @param[in] panel_ncells Number of cells per cubed sphere panel + !> @param[in] nlayers Number of layers for the panel_id field + !> @param[in] ndf_pid Number of DoFs per cell for the panel_id field + !> @param[in] undf_pid Universal number of DoFs for the panel_id field + !> @param[in] map_pid DoF map for the panel_id field + !> @param[out] panel_id Field (to be calculated) with the ID of cubed sphere panels + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] global_dof_id Array of global id's + !> @param[in] panel_ncells Number of cells per cubed sphere panel subroutine calc_panel_id( nlayers, & ndf_pid, & undf_pid, & @@ -342,16 +337,14 @@ subroutine calc_panel_id( nlayers, & integer(kind=i_def), intent(in) :: nlayers, ndf_pid, undf_pid integer(kind=i_def), intent(in) :: map_pid(ndf_pid) real(kind=r_def), intent(out) :: panel_id(undf_pid) + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology integer(kind=i_def), intent(in) :: global_dof_id(undf_pid) integer(kind=i_def), intent(in) :: panel_ncells ! Internal variables integer(kind=i_def) :: vert, k - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - - if ( geometry == geometry_spherical .and. & topology == topology_fully_periodic ) then @@ -383,9 +376,9 @@ end subroutine calc_panel_id !> @param[in] domain_x Domain extent in x direction for planar mesh !> @param[in] domain_y Domain extent in y direction for planar mesh !> @param[in] panel_id Field giving IDs of mesh panels - !> @param[in] geometry - !> @param[in] topology - !> @param[in] scaled_radius + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] scaled_radius Scaled planet radius !> @param[in] ndf_pid Number of DoFs per cell for panel_id space !> @param[in] undf_pid Number of universal DoFs for panel_id space !> @param[in] map_pid DoF map for panel_id space @@ -511,7 +504,7 @@ end subroutine assign_coordinate_xyz !! Cartesian coordinates from physical ones !> @param[in] stretch_factor Stretch factor for Schmidt transform !> @param[in] panel_id Field giving IDs of mesh panels - !> @param[in] scaled_radius + !> @param[in] scaled_radius Scaled planet radius !> @param[in] ndf_pid Number of DoFs per cell for panel_id space !> @param[in] undf_pid Number of universal DoFs for panel_id space !> @param[in] map_pid DoF map for panel_id space @@ -630,7 +623,7 @@ end subroutine assign_coordinate_alphabetaz !> @param[in] inverse_rot_matrix Rotation matrix to apply to obtain native !! Cartesian coordinates from physical ones !> @param[in] panel_id Field giving IDs of mesh panels - !> @param[in] scaled_radius + !> @param[in] scaled_radius Scaled planet radius !> @param[in] ndf_pid Number of DoFs per cell for panel_id space !> @param[in] undf_pid Number of universal DoFs for panel_id space !> @param[in] map_pid DoF map for panel_id space diff --git a/components/driver/source/driver_fem_mod.f90 b/components/driver/source/driver_fem_mod.f90 index 7532356a9..bce83645b 100644 --- a/components/driver/source/driver_fem_mod.f90 +++ b/components/driver/source/driver_fem_mod.f90 @@ -146,9 +146,9 @@ subroutine init_fem(config, chi_inventory, panel_id_inventory) end do ! Set coordinate fields -------------------------------------------------- - call assign_coordinate_field(chi, panel_id, mesh, & - geometry, topology, & - coord_system, scaled_radius) + call assign_coordinate_field( chi, panel_id, mesh, & + geometry, topology, & + coord_system, scaled_radius ) ! Add fields to inventory call chi_inventory%copy_field_array(chi, mesh) diff --git a/components/driver/source/driver_io_mod.F90 b/components/driver/source/driver_io_mod.F90 index fba59c0ae..9fd4252aa 100644 --- a/components/driver/source/driver_io_mod.F90 +++ b/components/driver/source/driver_io_mod.F90 @@ -56,6 +56,8 @@ end subroutine filelist_populator !> @param[inout] modeldb Model state !> @param[in] chi_inventory Contains the model's coordinate fields !> @param[in] panel_id_inventory Contains the model's panel ID fields + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value !> @param[in] populate_filelist Optional procedure for creating a list of !! file descriptions used by the model I/O @@ -76,14 +78,13 @@ subroutine init_io( context_name, & implicit none - character(*), intent(in) :: context_name - character(*), intent(in) :: mesh_name - class(modeldb_type), intent(inout) :: modeldb - type(inventory_by_mesh_type), intent(in) :: chi_inventory - type(inventory_by_mesh_type), intent(in) :: panel_id_inventory - - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology + character(*), intent(in) :: context_name + character(*), intent(in) :: mesh_name + class(modeldb_type), intent(inout) :: modeldb + type(inventory_by_mesh_type), intent(in) :: chi_inventory + type(inventory_by_mesh_type), intent(in) :: panel_id_inventory + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology procedure(filelist_populator), & pointer, optional, intent(in) :: populate_filelist @@ -162,6 +163,8 @@ end subroutine init_empty_io_context !> @param[in] chi_inventory Contains the model's coordinate fields !> @param[in] panel_id_inventory Contains the model's panel ID fields !> @param[in] before_close Routine to be called before context closes + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value !> @param[in] populate_filelist Optional procedure for creating a list of !! file descriptions used by the model I/O !> @param[in] alt_mesh_names Optional array of names for other meshes @@ -178,15 +181,14 @@ subroutine init_xios_io_context( context_name, & implicit none - character(*), intent(in) :: context_name - character(*), intent(in) :: mesh_name - class(modeldb_type), intent(inout) :: modeldb - type(inventory_by_mesh_type), intent(in) :: chi_inventory - type(inventory_by_mesh_type), intent(in) :: panel_id_inventory - procedure(callback_clock_arg), pointer, intent(in) :: before_close - - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology + character(*), intent(in) :: context_name + character(*), intent(in) :: mesh_name + class(modeldb_type), intent(inout) :: modeldb + type(inventory_by_mesh_type), intent(in) :: chi_inventory + type(inventory_by_mesh_type), intent(in) :: panel_id_inventory + procedure(callback_clock_arg), intent(in), pointer :: before_close + integer(i_def), intent(in) :: geometry + integer(i_def), intent(in) :: topology procedure(filelist_populator), & pointer, optional, intent(in) :: populate_filelist diff --git a/components/driver/source/driver_log_mod.f90 b/components/driver/source/driver_log_mod.f90 index 2b0919a5f..4c8187b1c 100644 --- a/components/driver/source/driver_log_mod.f90 +++ b/components/driver/source/driver_log_mod.f90 @@ -2,8 +2,7 @@ module driver_log_mod use constants_mod, only: i_def, l_def use convert_to_upper_mod, only: convert_to_upper -!use driver_modeldb_mod, only: modeldb_type -use config_mod, only: config_type +use config_mod, only: config_type use lfric_mpi_mod, only: lfric_comm_type use log_mod, only: log_event, & log_set_level, & @@ -34,6 +33,7 @@ module driver_log_mod !> @brief Initialises the logging system from a namelist. !> +!> @param[in] config Application configuration object. !> @param[in] communicator MPI communicator to use for logging. !> @param[in] program_name Identifies the running program. !> @@ -49,8 +49,6 @@ subroutine init_logger(config, communicator, program_name) integer(i_def) :: run_log_level logical(l_def) :: log_to_rank_zero_only -! communicator = modeldb%mpi%get_comm() - run_log_level = config%logging%run_log_level() log_to_rank_zero_only = config%logging%log_to_rank_zero_only() diff --git a/components/driver/source/driver_mesh_mod.f90 b/components/driver/source/driver_mesh_mod.f90 index 9f526b8d7..23c6c890c 100644 --- a/components/driver/source/driver_mesh_mod.f90 +++ b/components/driver/source/driver_mesh_mod.f90 @@ -79,6 +79,8 @@ module driver_mesh_mod !> @param[in] total_ranks Total number of MPI ranks in this job. !> @param[in] mesh_names Mesh names to load from the mesh input file(s). !> @param[in] extrusion Extrusion object to be applied to meshes. +!> @param[in] inner_halo_tiles Apply tiling to inner halos. +!> @param[in] tile_size Tile sizes to apply to inner halos if applicable. !> @param[in] stencil_depths_in Required stencil depth for each mesh for !! the application. If this array is of size 1 then !! the single value is applied to all meshes. diff --git a/components/driver/source/mesh/create_mesh_mod.f90 b/components/driver/source/mesh/create_mesh_mod.f90 index 3bcef4152..5c4eec6ec 100644 --- a/components/driver/source/mesh/create_mesh_mod.f90 +++ b/components/driver/source/mesh/create_mesh_mod.f90 @@ -17,10 +17,7 @@ module create_mesh_mod use extrusion_mod, only: extrusion_type, & uniform_extrusion_type, & geometric_extrusion_type, & - quadratic_extrusion_type!, & -! PRIME_EXTRUSION, & -! SHIFTED, & -! DOUBLE_LEVEL + quadratic_extrusion_type use local_mesh_mod, only: local_mesh_type use mesh_mod, only: mesh_type use sci_query_mod, only: check_lbc @@ -94,7 +91,7 @@ end function create_extrusion !! !> @param[in] local_mesh_names Names of the local_mesh_types to extrude. !> @param[in] extrusion Extrusion to employ. -!> @param[in] local_halo_tiles +!> @param[in] inner_halo_tiles !> @param[in] tile_size !> @param[in] alt_name Optional, Alternative names for the !! extruded meshes, defaults to local_mesh_names @@ -105,7 +102,6 @@ subroutine create_mesh_multiple( local_mesh_names, extrusion, & implicit none -! type(config_type), intent(in) :: config character(str_def), intent(in) :: local_mesh_names(:) class(extrusion_type), intent(in) :: extrusion logical(l_def), intent(in) :: inner_halo_tiles @@ -146,10 +142,11 @@ end subroutine create_mesh_multiple !! mesh collection. Multiple meshes may be generated in the model !! based on the same global mesh but with differing extrusions. !! -!> @param[in] config Model configuration object !> @param[in] local_mesh_name Name of local_mesh_type object in !! application local_mesh_collection. !> @param[in] extrusion Extrusion to employ for this mesh_type object +!> @param[in] inner_halo_tiles +!> @param[in] tile_size !> @param[in] alt_name Optional, Alternative name for the !! extruded mesh, defaults to local_mesh_name !! if absent. @@ -159,34 +156,19 @@ subroutine create_mesh_single( local_mesh_name, extrusion, & implicit none -! type(config_type), intent(in) :: config character(str_def), intent(in) :: local_mesh_name class(extrusion_type), intent(in) :: extrusion - logical(l_def), intent(in) :: inner_halo_tiles integer(i_def), intent(in) :: tile_size(2) character(str_def), intent(in), optional :: alt_name -! character(str_def), allocatable :: chain_mesh_tags(:) - -!!$ logical(l_def) :: l_multigrid -!!$ integer(i_def) :: max_tiled_multigrid_level -!!$ integer(i_def) :: tile_size_x, tile_size_y -!!$ logical(l_def) :: inner_halo_tiles -!!$ logical(l_def) :: coarsen_multigrid_tiles - type(local_mesh_type), pointer :: local_mesh_ptr type(mesh_type) :: mesh integer(kind=i_def) :: mesh_id character(len=str_def) :: name -! integer(kind=i_def) :: tile_size(2) -! integer(kind=i_def) :: multigrid_level -! integer(kind=i_def) :: max_multigrid_level -! logical(kind=l_def) :: set_tile_size - nullify (local_mesh_ptr) if ( .not. present(alt_name) ) then @@ -196,7 +178,7 @@ subroutine create_mesh_single( local_mesh_name, extrusion, & end if - ! 1.0 Check if mesh_type already exists. + ! Check if mesh_type already exists. !=============================================== if ( mesh_collection%check_for(name) ) then write(log_scratch_space,'(A)') & @@ -207,7 +189,7 @@ subroutine create_mesh_single( local_mesh_name, extrusion, & end if - ! 2.0 Extrude the local_mesh_object. + ! Extrude the local_mesh_object. !=============================================== local_mesh_ptr => local_mesh_collection%get_local_mesh(local_mesh_name) @@ -223,78 +205,6 @@ subroutine create_mesh_single( local_mesh_name, extrusion, & end if end if -! Remove to outside init_mesh (only required it application uses multigrid) -!!$ ! 3.0 Set up tiling -!!$ !=============================================== -!!$ ! Note: There should be no reference to multigrid in this code. -!!$ ! MultiGrif is a gungho science implementation. -!!$ ! -!!$ l_multigrid = .false. -!!$ if (config%namelist_exists('multigrid')) then -!!$ chain_mesh_tags = config%multigrid%chain_mesh_tags() -!!$ if (size(chain_mesh_tags) > 1) then -!!$ l_multigrid = .true. -!!$ end if -!!$ end if -!!$ -!!$ max_tiled_multigrid_level = config%partitioning%max_tiled_multigrid_level() -!!$ tile_size_x = config%partitioning%tile_size_x() -!!$ tile_size_y = config%partitioning%tile_size_y() -!!$ inner_halo_tiles = config%partitioning%inner_halo_tiles() -!!$ coarsen_multigrid_tiles = config%partitioning%coarsen_multigrid_tiles() -!!$ -!!$ ! Set coarsest multigrid level that will be tiled; -!!$ ! restrict to the finest grid by default -!!$ max_multigrid_level = 1 -!!$ if ( max_tiled_multigrid_level /= imdi ) then -!!$ max_multigrid_level = max_tiled_multigrid_level -!!$ end if -!!$ -!!$ ! The tiling module uses 1x1 tiles (equivalent to colouring) by -!!$ ! default; allow user-specified tile sizes in case of 3D meshes -!!$ ! (PRIME_EXTRUSION, SHIFTED, and DOUBLE_LEVEL extrusions) and up to -!!$ ! the specified multigrid level (count levels until mesh name -!!$ ! includes the chain mesh tag). This relies on mesh name conventions -!!$ ! and a tag order from finest (level 1) to coarsest mesh (level n). -!!$ set_tile_size = .false. -!!$ if ( extrusion%get_id() == PRIME_EXTRUSION .or. & -!!$ extrusion%get_id() == SHIFTED .or. & -!!$ extrusion%get_id() == DOUBLE_LEVEL ) then -!!$ -!!$ if (l_multigrid .and. (size(chain_mesh_tags) > 1)) then -!!$ ! Multigrid setup - use tiling if multigrid level is allowed, and -!!$ ! if mesh name includes the mesh tag at that level -!!$ do multigrid_level=1, size(chain_mesh_tags) -!!$ if ( index( trim(name), trim(chain_mesh_tags(multigrid_level)) ) > 0 & -!!$ .and. multigrid_level <= max_multigrid_level ) then -!!$ set_tile_size = .true. -!!$ exit -!!$ end if -!!$ end do -!!$ else -!!$ set_tile_size = .true. -!!$ end if -!!$ end if -!!$ -!!$ ! Set user-specified tile size if tiling is allowed and adapt it to coarser -!!$ ! multigrid levels if requested and applicable -!!$ tile_size = 1 -!!$ if ( set_tile_size ) then -!!$ if ( tile_size_x /= imdi ) tile_size(1) = tile_size_x -!!$ if ( tile_size_y /= imdi ) tile_size(2) = tile_size_y -!!$ -!!$ if (l_multigrid) then -!!$ if (size(chain_mesh_tags) > 1 .and. coarsen_multigrid_tiles) then -!!$ do multigrid_level = 1, size(chain_mesh_tags) -!!$ if ( index( trim(name), & -!!$ trim(chain_mesh_tags(multigrid_level)) ) > 0 ) exit -!!$ tile_size = max( tile_size / 2, 1 ) -!!$ end do -!!$ end if -!!$ end if -!!$ -!!$ end if - mesh = mesh_type( local_mesh_ptr, extrusion, mesh_name=name, & tile_size=tile_size, & inner_halo_tiles=inner_halo_tiles ) @@ -303,7 +213,7 @@ subroutine create_mesh_single( local_mesh_name, extrusion, & call mesh%clear() - ! 4.0 Report on mesh_type creation. + ! Report on mesh_type creation. !=============================================== write(log_scratch_space,'(A,I0,A)') & ' ... "'//trim(name)//'"(id:', mesh_id,') '// & diff --git a/components/driver/source/mesh/multigrid_mod.f90 b/components/driver/source/mesh/multigrid_mod.f90 index d0ba3f626..3c5cf2dc6 100644 --- a/components/driver/source/mesh/multigrid_mod.f90 +++ b/components/driver/source/mesh/multigrid_mod.f90 @@ -20,17 +20,17 @@ module multigrid_mod contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> @brief +!> @brief Routine returns tile sizes for supplied mesh names/extrusion where +!> applicable to the multigrid configuration. !> -!> @param[in] config -!> @param[in] local_mesh_name -!> @param[in] extrusion +!> @param[in] config Application configuration object +!> @param[in] local_mesh_names Meshes to set multigrid tile sizes +!> @param[in] extrusion Extrusion object being applied to meshes. !> -!> @return tile_size -!> -!!$subroutine get_multigrid_tile_size( config, local_mesh_names, extrusion, & -!!$ tile_size ) - +!> @return tile_size Updated tile sizes for multigrid, if applicable. +!> Missing data indicator is returned for where the local +!> mesh tile size is not to be updated for multigrid. +! function get_multigrid_tile_size( config, local_mesh_names, extrusion) & result ( tile_size ) diff --git a/components/lfric-xios/source/lfric_xios_context_mod.f90 b/components/lfric-xios/source/lfric_xios_context_mod.f90 index e4b5429c5..935ec50be 100644 --- a/components/lfric-xios/source/lfric_xios_context_mod.f90 +++ b/components/lfric-xios/source/lfric_xios_context_mod.f90 @@ -81,18 +81,18 @@ end subroutine initialise_lfric_xios_context !> @brief Set up an XIOS context. !> - !> @param [in] communicator MPI communicator used by context. - !> @param [in] chi Array of coordinate fields - !> @param [in] panel_id Panel ID field - !> @param [in] model_clock The model clock. - !> @param [in] calendar The model calendar. - !> @param [in] before_close Routine to be called before context closes - !> @param [in] geometry - !> @param [in] topology - !> @param [in] coord_system - !> @param [in] scaled_radius - !> @param [in] alt_coords Array of coordinate fields for alternative meshes - !> @param [in] alt_panel_ids Panel ID fields for alternative meshes + !> @param [in] communicator MPI communicator used by context. + !> @param [in] chi Array of coordinate fields + !> @param [in] panel_id Panel ID field + !> @param [in] model_clock The model clock. + !> @param [in] calendar The model calendar. + !> @param [in] before_close Routine to be called before context closes + !> @param [in] geometry Mesh geometry enumeration value. + !> @param [in] topology Mesh topology enumeration value. + !> @param [in] coord_system Finite-element coord-system enumeration value + !> @param [in] scaled_radius Planet scaled radius + !> @param [in] alt_coords Array of coordinate fields for alternative meshes + !> @param [in] alt_panel_ids Panel ID fields for alternative meshes subroutine initialise_xios_context( this, & communicator, & chi, panel_id, & diff --git a/components/lfric-xios/source/lfric_xios_setup_mod.x90 b/components/lfric-xios/source/lfric_xios_setup_mod.x90 index a8e3795ea..83ac4e602 100644 --- a/components/lfric-xios/source/lfric_xios_setup_mod.x90 +++ b/components/lfric-xios/source/lfric_xios_setup_mod.x90 @@ -153,10 +153,12 @@ contains !! of XIOS dimensionality (domains, axes, etc) and initialised the !! corresponding XIOS objects. !> - !> @param[in] config Configuration object !> @param[in] chi Coordinate field !> @param[in] panel_id Field with IDs of mesh panels - !> + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius subroutine init_xios_dimensions( chi, panel_id, & geometry, topology, & coord_system, scaled_radius, & @@ -207,9 +209,12 @@ contains !! of XIOS dimensionality (domains, axes, etc) and initialised the !! corresponding XIOS objects. !> - !> @param[in] config Configuration object !> @param[in] chi Coordinate field !> @param[in] panel_id Field with IDs of mesh panels + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @param[in] prime_mesh Logical flag denoting if the mesh is the primary !! I/O mesh !> diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90 b/components/science/source/algorithm/sci_geometric_constants_mod.x90 index dc24c8086..bf265a0be 100644 --- a/components/science/source/algorithm/sci_geometric_constants_mod.x90 +++ b/components/science/source/algorithm/sci_geometric_constants_mod.x90 @@ -101,20 +101,15 @@ module sci_geometric_constants_mod public :: final_geometric_constants public :: get_panel_id public :: get_coordinates + public :: get_extended_coordinates public :: get_dA_at_w2 + public :: get_detj_at_w3_fe public :: get_detj_at_w3_fv + public :: get_detj_at_w2_fe public :: get_detj_at_w2_fv + public :: get_dz_w3 public :: get_delta_at_wtheta public :: get_dx_at_w2 - public :: get_face_selector_ew - public :: get_face_selector_ns - public :: get_chi_inventory - public :: get_panel_id_inventory - - public :: get_extended_coordinates - public :: get_detj_at_w3_fe - public :: get_detj_at_w2_fe - public :: get_dz_w3 public :: get_dz_at_wtheta public :: get_dA_msl_proj public :: get_height_fe @@ -123,6 +118,10 @@ module sci_geometric_constants_mod public :: get_latitude_fv public :: get_longitude_fe public :: get_longitude_fv + public :: get_face_selector_ew + public :: get_face_selector_ns + public :: get_chi_inventory + public :: get_panel_id_inventory ! Private routines for creating constants private :: compute_latlon @@ -137,12 +136,21 @@ contains !> @brief Private routine for computing longitude and latitude fields !> @param[in,out] long_inventory Inventory containing longitude fields !> @param[in,out] lat_inventory Inventory containing latitude fields - !> @param[in] mesh Mesh used to determine local mesh for - !! computing the fields for - !> @param[in] fs_id Identifier for function space to compute - !! longitude and latitude fields for - !> @param[in] use_fe Flag to indicate whether to use finite - !! element or finite volume cells + !> + !> @param[in] mesh Mesh used to determine local mesh for + !! computing the fields for + !> @param[in] fs_id Identifier for function space to compute + !! longitude and latitude fields for + !> @param[in] use_fe Flag to indicate whether to use finite + !! element or finite volume cells + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] element_order_h Function space order in horizontal + !> @param[in] element_order_v Function space order in vertical + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] f_lat Latitiude of f-plane + !> @param[in] f_lon Longitude of f-plane + !> @param[in] scaled_radius Planet scaled radius subroutine compute_latlon( long_inventory, lat_inventory, & mesh, fs_id, use_fe, & geometry, topology, & @@ -163,8 +171,8 @@ contains integer(i_def), intent(in) :: geometry, topology integer(i_def), intent(in) :: element_order_h, element_order_v integer(i_def), intent(in) :: coord_system - real(r_def), intent(in) :: f_lat, f_lon - real(r_def), intent(in) :: scaled_radius + real(r_def), intent(in) :: f_lat, f_lon + real(r_def), intent(in) :: scaled_radius ! Internal variables type(mesh_type), pointer :: twod_mesh @@ -208,7 +216,6 @@ contains end subroutine compute_latlon - !> @brief Private routine for computing face selectors fields !> @param[in,out] ew_inventory Inventory containing East-West selectors !> @param[in,out] ns_inventory Inventory containing North-South selectors @@ -313,10 +320,9 @@ contains end function get_coordinates - !> @brief Returns a pointer to the extended coordinate field array - !> @param[in] coord_system Finite-Element coordinate system enumeration !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] coord_system Finite-Element coord-system enumeration value !> @return The coordinate field array function get_extended_coordinates(mesh_id, coord_system) result(extended_chi) @@ -335,7 +341,7 @@ contains type(field_type), pointer :: panel_id type(function_space_type), pointer :: wchi_fs - integer(tik) :: id + integer(tik) :: id ! Initialise inventory if this is the first time getting this constant if (.not. extended_chi_inventory%is_initialised()) then @@ -376,7 +382,6 @@ contains end function get_extended_coordinates - ! ========================================================================== ! ! GETTERS FOR BASIC GEOMETRIC ENTITIES ! ========================================================================== ! @@ -427,17 +432,15 @@ contains end function get_dA_at_w2 - !> @brief Returns the (finite element) Det(J) values at W3 dof locations - - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @param[in] element_order_h - !> @param[in] element_order_v - !> @param[in] nqp_h_exact - !> @param[in] nqp_v_exact + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] element_order_h Function space order in horizontal + !> @param[in] element_order_v Function space order in vertical + !> @param[in] nqp_h_exact Number of quadrature points in horizontal + !> @param[in] nqp_v_exact Number of quadrature points in vertical !> @return The Det(J) field - function get_detj_at_w3_fe( mesh_id, & - element_order_h, element_order_v, & + + function get_detj_at_w3_fe( mesh_id, element_order_h, element_order_v, & nqp_h_exact, nqp_v_exact) & result( detj_at_w3 ) @@ -520,7 +523,6 @@ contains end function get_detj_at_w3_fe - !> @brief Returns the (finite volume) Det(J) values at W3 dof locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field @@ -593,9 +595,10 @@ contains end function get_detj_at_w3_fv - !> @brief Returns the (finite element) Det(J) values at W2 dof locations - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] element_order_h Function space order in horizontal + !> @param[in] element_order_v Function space order in vertical !> @return The Det(J) field function get_detj_at_w2_fe( mesh_id, element_order_h, element_order_v ) & result( detj_at_w2 ) @@ -661,7 +664,6 @@ contains end function get_detj_at_w2_fe - !> @brief Returns the (finite volume) Det(J) values at W2 dof locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The Det(J) field @@ -717,9 +719,11 @@ contains end function get_detj_at_w2_fv - !> @brief Returns a pointer to the vertical grid spacing, located at W3 DoFs - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The physical height difference of layers, at W3 function get_dz_w3( mesh_id, & geometry, coord_system, scaled_radius ) & @@ -772,7 +776,6 @@ contains end function get_dz_w3 - !> @brief Returns the delta_at_wtheta values at Wtheta DoF locations !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The delta_at_wtheta field @@ -861,9 +864,11 @@ contains end function get_dx_at_w2 - !> @brief Returns the 1/dz values at lowest-order Wtheta DoF locations - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The dz_at_wtheta field function get_dz_at_wtheta( mesh_id, & geometry, coord_system, scaled_radius ) & @@ -873,7 +878,6 @@ contains implicit none - integer(i_def), intent(in) :: mesh_id integer(i_def), intent(in) :: geometry integer(i_def), intent(in) :: coord_system @@ -902,11 +906,9 @@ contains ! Create constant if it doesn't already exist if (.not. constant_exists) then ! NB: this assumes heights are in the lowest-order space - height_w3 => get_height_fv( W3, mesh_id, & - geometry, coord_system, & + height_w3 => get_height_fv( W3, mesh_id, geometry, coord_system, & scaled_radius ) - height_wth => get_height_fv( Wtheta, mesh_id, & - geometry, coord_system, & + height_wth => get_height_fv( Wtheta, mesh_id,geometry, coord_system, & scaled_radius ) if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) @@ -926,23 +928,24 @@ contains end function get_dz_at_wtheta - !> @brief Returns the surface area of a cell projected to mean sea level !> i.e. ignoring the orographic effect on the area - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] planet_radius Planet radius (m) + !> @param[in] domain_height Top of atmosphere height above mean surface (m) !> @return The dA_msl_proj field - function get_dA_msl_proj( mesh_id, & - geometry, planet_radius, domain_height ) & + function get_dA_msl_proj( mesh_id, geometry, planet_radius, domain_height ) & result( dA_msl_proj ) use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type implicit none - integer(i_def), intent(in) :: mesh_id - integer(i_def), intent(in) :: geometry - real(r_def), intent(in) :: planet_radius - real(r_def), intent(in) :: domain_height + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: geometry + real(r_def), intent(in) :: planet_radius + real(r_def), intent(in) :: domain_height integer(kind=i_def) :: local_mesh_id type(mesh_type), pointer :: mesh @@ -987,19 +990,24 @@ contains end function get_dA_msl_proj - ! ========================================================================== ! ! PHYSICAL COORDINATES OF DOFs ! ========================================================================== ! !> @brief Returns a pointer to the longitude of finite element DoFs - !> @param[in] space_id The space for which to get the longitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] space_id The space for which to get the longitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] element_order_h Function space order in horizontal + !> @param[in] element_order_v Function space order in vertical + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] f_lat Latitiude of f-plane + !> @param[in] f_lon Longitude of f-plane + !> @param[in] scaled_radius Planet scaled radius !> @return The longitude field - function get_longitude_fe( space_id, mesh_id, & - geometry, topology, & + function get_longitude_fe( space_id, mesh_id, geometry, topology, & element_order_h, element_order_v, & - coord_system, f_lat, f_lon, & - scaled_radius ) & + coord_system, f_lat, f_lon,scaled_radius ) & result( long_ptr ) implicit none @@ -1026,8 +1034,7 @@ contains ! If running at lowest order, use finite volume if (element_order_h == 0 .and. element_order_v == 0) then - long_ptr => get_longitude_fv( space_id, mesh_id, & - geometry, topology, & + long_ptr => get_longitude_fv( space_id, mesh_id, geometry, topology, & element_order_h, element_order_v, & coord_system, f_lat, f_lon, & scaled_radius ) @@ -1067,11 +1074,9 @@ contains if (.not. constant_exists) then call compute_latlon( long_inventory, lat_inventory, & - mesh, space_id, use_fe, & - geometry, topology, & - element_order_h, element_order_v, & - coord_system, f_lat, f_lon, & - scaled_radius ) + mesh, space_id, use_fe, geometry, topology, & + element_order_h, element_order_v, coord_system, & + f_lat, f_lon, scaled_radius ) end if call long_inventory%get_field(local_mesh, long_ptr) @@ -1079,14 +1084,20 @@ contains end function get_longitude_fe !> @brief Returns a pointer to the longitude of finite volume DoFs - !> @param[in] space_id The space for which to get the longitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] space_id The space for which to get the longitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] element_order_h Function space order in horizontal + !> @param[in] element_order_v Function space order in vertical + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] f_lat Latitiude of f-plane + !> @param[in] f_lon Longitude of f-plane + !> @param[in] scaled_radius Planet scaled radius !> @return The longitude field - function get_longitude_fv( space_id, mesh_id, & - geometry, topology, & + function get_longitude_fv( space_id, mesh_id, geometry, topology, & element_order_h, element_order_v, & - coord_system, f_lat, f_lon, & - scaled_radius ) & + coord_system, f_lat, f_lon, scaled_radius ) & result( long_ptr ) implicit none @@ -1144,11 +1155,9 @@ contains if (.not. constant_exists) then call compute_latlon( long_inventory, lat_inventory, & - mesh, space_id, use_fe, & - geometry, topology, & + mesh, space_id, use_fe, geometry, topology, & element_order_h, element_order_v, & - coord_system, f_lat, f_lon, & - scaled_radius ) + coord_system, f_lat, f_lon, scaled_radius ) end if call long_inventory%get_field(local_mesh, long_ptr) @@ -1157,14 +1166,20 @@ contains !> @brief Returns a pointer to the latitude of finite element DoFs - !> @param[in] space_id The space for which to get the latitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] space_id The space for which to get the latitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] element_order_h Function space order in horizontal + !> @param[in] element_order_v Function space order in vertical + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] f_lat Latitiude of f-plane + !> @param[in] f_lon Longitude of f-plane + !> @param[in] scaled_radius Planet scaled radius !> @return The latitude field - function get_latitude_fe( space_id, mesh_id, & - geometry, topology, & + function get_latitude_fe( space_id, mesh_id, geometry, topology, & element_order_h, element_order_v, & - coord_system, f_lat, f_lon, & - scaled_radius ) & + coord_system, f_lat, f_lon, scaled_radius ) & result( lat_ptr ) @@ -1192,11 +1207,9 @@ contains ! If running at lowest order, use finite volume if (element_order_h == 0 .and. element_order_v == 0) then - lat_ptr => get_latitude_fv( space_id, mesh_id, & - geometry, topology, & + lat_ptr => get_latitude_fv( space_id, mesh_id, geometry, topology, & element_order_h, element_order_v, & - coord_system, f_lat, f_lon, & - scaled_radius ) + coord_system, f_lat, f_lon, scaled_radius ) return end if @@ -1233,11 +1246,9 @@ contains if (.not. constant_exists) then call compute_latlon( long_inventory, lat_inventory, & - mesh, space_id, use_fe, & - geometry, topology, & + mesh, space_id, use_fe, geometry, topology, & element_order_h, element_order_v, & - coord_system, f_lat, f_lon, & - scaled_radius ) + coord_system, f_lat, f_lon, scaled_radius ) end if call lat_inventory%get_field(local_mesh, lat_ptr) @@ -1245,16 +1256,21 @@ contains end function get_latitude_fe - !> @brief Returns a pointer to the latitude of finite volume DoFs - !> @param[in] space_id The space for which to get the latitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] space_id The space for which to get the latitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] element_order_h Function space order in horizontal + !> @param[in] element_order_v Function space order in vertical + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] f_lat Latitiude of f-plane + !> @param[in] f_lon Longitude of f-plane + !> @param[in] scaled_radius Planet scaled radius !> @return The latitude field - function get_latitude_fv( space_id, mesh_id, & - geometry, topology, & + function get_latitude_fv( space_id, mesh_id, geometry, topology, & element_order_h, element_order_v, & - coord_system, f_lat, f_lon, & - scaled_radius ) & + coord_system, f_lat, f_lon, scaled_radius ) & result( lat_ptr ) implicit none @@ -1312,24 +1328,26 @@ contains if (.not. constant_exists) then call compute_latlon( long_inventory, lat_inventory, & - mesh, space_id, use_fe, & - geometry, topology, & + mesh, space_id, use_fe, geometry, topology, & element_order_h, element_order_v, & - coord_system, f_lat, f_lon, & - scaled_radius ) + coord_system, f_lat, f_lon, scaled_radius ) end if call lat_inventory%get_field(local_mesh, lat_ptr) end function get_latitude_fv - !> @brief Returns a pointer to a finite element height field - !> @param[in] space_id The space of the desired height field - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] space_id The space of the desired height field + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] element_order_h Function space order in horizontal + !> @param[in] element_order_v Function space order in vertical + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return A height field - function get_height_fe( space_id, mesh_id, & - geometry, element_order_h, element_order_v, & + function get_height_fe( space_id, mesh_id, geometry, & + element_order_h, element_order_v, & coord_system, scaled_radius ) & result( height ) @@ -1364,9 +1382,8 @@ contains ! If running at lowest order, use finite volume if (element_order_h == 0 .and. element_order_v == 0) then - height => get_height_fv( space_id, mesh_id, & - geometry, coord_system, & - scaled_radius ) + height => get_height_fv( space_id, mesh_id, geometry, & + coord_system, scaled_radius ) return end if @@ -1451,14 +1468,15 @@ contains end function get_height_fe - !> @brief Returns a pointer to a finite volume height field - !> @param[in] space_id The space of the desired height field - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] space_id The space of the desired height field + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return A height field - function get_height_fv( space_id, mesh_id, & - geometry, coord_system, & - scaled_radius ) & + function get_height_fv( space_id, mesh_id, geometry, & + coord_system, scaled_radius ) & result( height ) @@ -1565,7 +1583,6 @@ contains end function get_height_fv - ! ========================================================================== ! ! FACE SELECTORS ! ========================================================================== ! diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90.orig b/components/science/source/algorithm/sci_geometric_constants_mod.x90.orig new file mode 100644 index 000000000..e33f44e9a --- /dev/null +++ b/components/science/source/algorithm/sci_geometric_constants_mod.x90.orig @@ -0,0 +1,1531 @@ +!----------------------------------------------------------------------------- +! (C) Crown copyright 2021 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 Pre-computes and stores various geometric objects. +!> +!> @details This module controls the set up of various objects relating to +!> the geometry of the mesh that do not change during a run. These +!> objects are accessed from this module through appropriate 'get' +!> functions. +!------------------------------------------------------------------------------- + +module sci_geometric_constants_mod + + ! Infrastructure + use constants_mod, only: i_def, r_def, l_def, str_def + use extrusion_mod, only: TWOD, PRIME_EXTRUSION + use field_mod, only: field_type + use fs_continuity_mod, only: W0, W1, W2, W2H, W3, Wtheta + use function_space_collection_mod, only: function_space_collection + use function_space_mod, only: function_space_type + use integer_field_mod, only: integer_field_type + use inventory_by_mesh_mod, only: inventory_by_mesh_type + use inventory_by_local_mesh_mod, only: inventory_by_local_mesh_type + use local_mesh_mod, only: local_mesh_type + use log_mod, only: log_event, LOG_LEVEL_ERROR + use mesh_collection_mod, only: mesh_collection + use mesh_mod, only: mesh_type + use timing_mod, only: start_timing, stop_timing, & + tik, LPROF + + ! Configuration + use finite_element_config_mod, only: element_order_h, & + element_order_v + + implicit none + + private + + ! Variables private to this module that can only be accessed by public + ! functions returning pointers to them + + ! ========================================================================== ! + ! Inventories for use in the rest of the model + ! ========================================================================== ! + ! Finite element representations of coordinates + type(inventory_by_mesh_type), target :: chi_inventory + type(inventory_by_mesh_type), target :: panel_id_inventory + type(inventory_by_mesh_type) :: extended_chi_inventory + + ! Basic geometric entities + type(inventory_by_mesh_type) :: dA_at_w2_inventory + type(inventory_by_mesh_type) :: dz_w3_inventory + type(inventory_by_mesh_type) :: detj_at_w3_inventory_fe + type(inventory_by_mesh_type) :: detj_at_w3_inventory_fv + type(inventory_by_mesh_type) :: detj_at_w2_inventory_fe + type(inventory_by_mesh_type) :: detj_at_w2_inventory_fv + type(inventory_by_mesh_type) :: delta_at_wtheta_inventory + type(inventory_by_mesh_type) :: dx_at_w2_inventory + type(inventory_by_mesh_type) :: dz_at_wtheta_inventory + type(inventory_by_local_mesh_type) :: dA_msl_proj_inventory + + ! 2D Longitude/latitude fields + type(inventory_by_local_mesh_type), target :: lat_w3_inventory_fe + type(inventory_by_local_mesh_type), target :: lat_w3_inventory_fv + type(inventory_by_local_mesh_type), target :: lat_w2_inventory_fe + type(inventory_by_local_mesh_type), target :: lat_w2_inventory_fv + type(inventory_by_local_mesh_type), target :: lat_w2h_inventory_fe + type(inventory_by_local_mesh_type), target :: lat_w2h_inventory_fv + type(inventory_by_local_mesh_type), target :: long_w3_inventory_fe + type(inventory_by_local_mesh_type), target :: long_w3_inventory_fv + type(inventory_by_local_mesh_type), target :: long_w2_inventory_fe + type(inventory_by_local_mesh_type), target :: long_w2_inventory_fv + type(inventory_by_local_mesh_type), target :: long_w2h_inventory_fe + type(inventory_by_local_mesh_type), target :: long_w2h_inventory_fv + + ! Heights of DoFs + type(inventory_by_mesh_type), target :: height_w0_inventory_fe + type(inventory_by_mesh_type), target :: height_w0_inventory_fv + type(inventory_by_mesh_type), target :: height_w1_inventory_fe + type(inventory_by_mesh_type), target :: height_w1_inventory_fv + type(inventory_by_mesh_type), target :: height_w2_inventory_fe + type(inventory_by_mesh_type), target :: height_w2_inventory_fv + type(inventory_by_mesh_type), target :: height_w2h_inventory_fe + type(inventory_by_mesh_type), target :: height_w2h_inventory_fv + type(inventory_by_mesh_type), target :: height_w3_inventory_fe + type(inventory_by_mesh_type), target :: height_w3_inventory_fv + type(inventory_by_mesh_type), target :: height_wth_inventory_fe + type(inventory_by_mesh_type), target :: height_wth_inventory_fv + + ! Face selectors, used to avoid doubly-iterating over horizontal faces + type(inventory_by_local_mesh_type) :: face_selector_ew_inventory + type(inventory_by_local_mesh_type) :: face_selector_ns_inventory + + ! ========================================================================== ! + ! Public functions for accessing the module contents + ! ========================================================================== ! + + public :: final_geometric_constants + public :: get_panel_id + public :: get_coordinates + public :: get_extended_coordinates + public :: get_dA_at_w2 + public :: get_detj_at_w3_fe + public :: get_detj_at_w3_fv + public :: get_detj_at_w2_fe + public :: get_detj_at_w2_fv + public :: get_dz_w3 + public :: get_delta_at_wtheta + public :: get_dx_at_w2 + public :: get_dz_at_wtheta + public :: get_dA_msl_proj + public :: get_height_fe + public :: get_height_fv + public :: get_latitude_fe + public :: get_latitude_fv + public :: get_longitude_fe + public :: get_longitude_fv + public :: get_face_selector_ew + public :: get_face_selector_ns + public :: get_chi_inventory + public :: get_panel_id_inventory + + ! Private routines for creating constants + private :: compute_latlon + private :: compute_face_selectors + +contains + + ! ========================================================================== ! + ! Private routines for creating some particular constants + ! ========================================================================== ! + + !> @brief Private routine for computing longitude and latitude fields + !> @param[in,out] long_inventory Inventory containing longitude fields + !> @param[in,out] lat_inventory Inventory containing latitude fields + !> @param[in] mesh Mesh used to determine local mesh for + !! computing the fields for + !> @param[in] fs_id Identifier for function space to compute + !! longitude and latitude fields for + !> @param[in] use_fe Flag to indicate whether to use finite + !! element or finite volume cells + subroutine compute_latlon(long_inventory, lat_inventory, mesh, fs_id, use_fe) + + use base_mesh_config_mod, only: f_lat, geometry, & + geometry_spherical + use idealised_config_mod, only: f_lon + use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type + + implicit none + + type(inventory_by_local_mesh_type), intent(inout) :: long_inventory + type(inventory_by_local_mesh_type), intent(inout) :: lat_inventory + type(mesh_type), intent(in) :: mesh + integer(kind=i_def), intent(in) :: fs_id + logical(kind=l_def), intent(in) :: use_fe + + ! Internal variables + type(mesh_type), pointer :: twod_mesh + type(local_mesh_type), pointer :: local_mesh + type(field_type), pointer :: lat + type(field_type), pointer :: long + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(function_space_type), pointer :: twod_fs + integer(kind=i_def) :: k_h, k_v + integer(tik) :: id + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + if (use_fe) then + k_h = element_order_h + k_v = element_order_v + else + k_h = 0 + k_v = 0 + end if + + twod_mesh => mesh_collection%get_mesh(mesh, TWOD) + local_mesh => mesh%get_local_mesh() + twod_fs => function_space_collection%get_fs(twod_mesh, k_h, k_v, fs_id) + call lat_inventory%add_field(lat, twod_fs, local_mesh) + call long_inventory%add_field(long, twod_fs, local_mesh) + + if ( geometry == geometry_spherical ) then + chi => get_coordinates(mesh%get_id()) + panel_id => get_panel_id(mesh%get_id()) + call invoke( compute_latlon_kernel_type(lat, long, chi, panel_id) ) + else + call invoke( setval_c(lat, f_lat), & + setval_c(long, f_lon) ) + end if + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + + end subroutine compute_latlon + + !> @brief Private routine for computing face selectors fields + !> @param[in,out] ew_inventory Inventory containing East-West selectors + !> @param[in,out] ns_inventory Inventory containing North-South selectors + !> @param[in] mesh Mesh used to determine local mesh for + !! computing the fields for + subroutine compute_face_selectors(mesh) + + use reference_element_mod, only: S, W + use sci_set_any_int_dof_kernel_mod, only: set_any_int_dof_kernel_type + use sci_face_selector_kernel_mod, only: face_selector_kernel_type + + implicit none + + type(mesh_type), intent(in) :: mesh + + ! Internal variables + type(mesh_type), pointer :: twod_mesh + type(local_mesh_type), pointer :: local_mesh + type(integer_field_type), pointer :: face_selector_ew + type(integer_field_type), pointer :: face_selector_ns + type(integer_field_type) :: face_counter + type(function_space_type), pointer :: w2h_2d_fs + type(function_space_type), pointer :: w3_2d_fs + integer(tik) :: id + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + twod_mesh => mesh_collection%get_mesh(mesh, TWOD) + local_mesh => mesh%get_local_mesh() + w2h_2d_fs => function_space_collection%get_fs(twod_mesh, 0, 0, W2H) + w3_2d_fs => function_space_collection%get_fs(twod_mesh, 0, 0, W3) + + ! Temporary W2H field, tracking the count for each face + call face_counter%initialise( w2h_2d_fs ) + + call face_selector_ew_inventory%add_field( & + face_selector_ew, w3_2d_fs, local_mesh & + ) + call face_selector_ns_inventory%add_field( & + face_selector_ns, w3_2d_fs, local_mesh & + ) + + call invoke( int_setval_c(face_counter, 0), & + ! Do West and South faces for every cell + int_setval_c(face_selector_ew, 1), & + int_setval_c(face_selector_ns, 1), & + set_any_int_dof_kernel_type(face_counter, W, 1), & + set_any_int_dof_kernel_type(face_counter, S, 1), & + ! Determine where North and East faces are needed + face_selector_kernel_type(face_selector_ew, & + face_selector_ns, & + face_counter ) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + + end subroutine compute_face_selectors + + ! ========================================================================== ! + ! GETTERS FOR FINITE ELEMENT COORDINATE FIELDS + ! ========================================================================== ! + !> @brief Function to return a pointer to the panel_id + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The coordinate field array + function get_panel_id(mesh_id) result(panel_id_ptr) + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(mesh_type), pointer :: prime_extrusion_mesh + type(field_type), pointer :: panel_id_ptr + + mesh => mesh_collection%get_mesh(mesh_id) + if (mesh%get_extrusion_id() == TWOD) then + prime_extrusion_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) + call panel_id_inventory%get_field(prime_extrusion_mesh, panel_id_ptr) + else + call panel_id_inventory%get_field(mesh, panel_id_ptr) + end if + + end function get_panel_id + + !> @brief Returns a pointer to the coordinate field array + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The coordinate field array + function get_coordinates(mesh_id) result(coords_ptr) + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(mesh_type), pointer :: prime_extrusion_mesh + type(field_type), pointer :: coords_ptr(:) + + mesh => mesh_collection%get_mesh(mesh_id) + if (mesh%get_extrusion_id() == TWOD) then + prime_extrusion_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) + call chi_inventory%get_field_array(prime_extrusion_mesh, coords_ptr) + else + call chi_inventory%get_field_array(mesh, coords_ptr) + end if + + end function get_coordinates + + !> @brief Returns a pointer to the extended coordinate field array + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The coordinate field array + function get_extended_coordinates(mesh_id) result(extended_chi) + + use finite_element_config_mod, only: coord_system, coord_system_native + use sci_extend_chi_field_kernel_mod, only: extend_chi_field_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(field_type), pointer :: extended_chi(:) + logical(kind=l_def) :: constant_exists + integer(kind=i_def) :: depth + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(function_space_type), pointer :: wchi_fs + integer(tik) :: id + + ! Initialise inventory if this is the first time getting this constant + if (.not. extended_chi_inventory%is_initialised()) then + call extended_chi_inventory%initialise(name="extended_chi") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = extended_chi_inventory%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + ! If this constant doesn't exist, create it + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + wchi_fs => chi(1)%get_function_space() + depth = mesh%get_halo_depth() + call extended_chi_inventory%add_field_array( & + extended_chi, wchi_fs, 3, mesh, halo_depth=depth & + ) + + if (coord_system /= coord_system_native) then + call log_event( & + "Extended coordinates only implemented for native " // & + "coord_system option", LOG_LEVEL_ERROR & + ) + end if + + call invoke( extend_chi_field_kernel_type(extended_chi, chi, & + panel_id, depth) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + else + ! Otherwise, return existing constant + call extended_chi_inventory%get_field_array(mesh, extended_chi) + end if + + end function get_extended_coordinates + + ! ========================================================================== ! + ! GETTERS FOR BASIC GEOMETRIC ENTITIES + ! ========================================================================== ! + !> @brief Returns the areas of cell faces at W2 DoF locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The dA field + function get_dA_at_w2(mesh_id) result(dA_at_w2) + + use sci_calc_da_at_w2_kernel_mod, only: calc_dA_at_w2_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(field_type), pointer :: dA_at_w2 + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(function_space_type), pointer :: w2_k0_fs + integer(tik) :: id + + ! Initialise inventory if this is the first time getting this constant + if (.not. dA_at_w2_inventory%is_initialised()) then + call dA_at_w2_inventory%initialise(name="dA_at_w2") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = dA_at_w2_inventory%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + ! If this constant doesn't exist, create it + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w2_k0_fs => function_space_collection%get_fs(mesh, 0, 0, W2) + call dA_at_w2_inventory%add_field(dA_at_w2, w2_k0_fs, mesh) + + call invoke( setval_c(dA_at_w2, 0.0_r_def), & + calc_dA_at_w2_kernel_type(dA_at_w2, chi, panel_id) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + else + ! Otherwise, return existing constant + call dA_at_w2_inventory%get_field(mesh, dA_at_w2) + end if + + end function get_dA_at_w2 + + !> @brief Returns the (finite element) Det(J) values at W3 dof locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The Det(J) field + function get_detj_at_w3_fe(mesh_id) result(detj_at_w3) + + ! @TODO #4487: update these imports + ! use sci_calc_detj_at_w3_kernel_mod, only: calc_detj_at_w3_kernel_type + use sci_compute_mass_matrix_kernel_w_scalar_mod, & + only: compute_mass_matrix_kernel_w_scalar_type + use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type + use finite_element_config_mod, only: nqp_h_exact, & + nqp_v_exact + use operator_mod, only: operator_type + use quadrature_xyoz_mod, only: quadrature_xyoz_type + use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: detj_at_w3 + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(function_space_type), pointer :: w3_fs + ! @TODO #4487: arguments for calculating detj in old way + type(operator_type) :: mm_w3 + type(quadrature_xyoz_type) :: qr + logical(kind=l_def) :: extended_mesh + type(quadrature_rule_gaussian_type) :: quadrature_rule + integer(tik) :: id + + ! If running at lowest order, use finite volume + if (element_order_h == 0 .and. element_order_v == 0) then + detj_at_w3 => get_detj_at_w3_fv(mesh_id) + return + end if + + ! Check inventory is initialised + if (.not. detj_at_w3_inventory_fe%is_initialised()) then + ! Initialise all inventories together + call detj_at_w3_inventory_fe%initialise(name='detj_at_w3_fe') + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = detj_at_w3_inventory_fe%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + ! Create the object as it doesn't exist yet + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w3_fs => function_space_collection%get_fs(mesh, element_order_h, & + element_order_v, W3) + call detj_at_w3_inventory_fe%add_field(detj_at_w3, w3_fs, mesh) + + ! @TODO #4487: it is inefficient to calculate this via mass matrices + ! The proper method is preserved in the comment here + ! call invoke( calc_detj_at_w3_kernel_type(detj_at_w3, chi, panel_id) ) + call mm_w3%initialise( w3_fs, w3_fs ) + qr = quadrature_xyoz_type(nqp_h_exact, nqp_h_exact, nqp_v_exact, & + quadrature_rule) + extended_mesh = .false. + call invoke( compute_mass_matrix_kernel_w_scalar_type(mm_w3, & + chi, & + panel_id, & + extended_mesh, & + qr), & + setval_c(detj_at_w3, 0.0_r_def), & + mm_diagonal_kernel_type(detj_at_w3, mm_w3) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Get existing constant + call detj_at_w3_inventory_fe%get_field(mesh, detj_at_w3) + + end function get_detj_at_w3_fe + + !> @brief Returns the (finite volume) Det(J) values at W3 dof locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The Det(J) field + function get_detj_at_w3_fv(mesh_id) result(detj_at_w3) + + ! @TODO #4487: update these imports + ! use sci_calc_detj_at_w3_kernel_mod, & + ! only: calc_detj_at_w3_kernel_type + use sci_compute_mass_matrix_kernel_w_scalar_mod, & + only: compute_mass_matrix_kernel_w_scalar_type + use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type + use operator_mod, only: operator_type + use quadrature_xyoz_mod, only: quadrature_xyoz_type + use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: detj_at_w3 + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(function_space_type), pointer :: w3_fs + ! @TODO #4487: arguments for calculating detj in old way + type(operator_type) :: mm_w3 + type(quadrature_xyoz_type) :: qr + logical(kind=l_def) :: extended_mesh + type(quadrature_rule_gaussian_type) :: quadrature_rule + integer(tik) :: id + + ! Check inventory is initialised + if (.not. detj_at_w3_inventory_fv%is_initialised()) then + ! Initialise all inventories together + call detj_at_w3_inventory_fv%initialise(name='detj_at_w3_fv') + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = detj_at_w3_inventory_fv%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + ! Create the object as it doesn't exist yet + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w3_fs => function_space_collection%get_fs(mesh, 0, 0, W3) + call detj_at_w3_inventory_fv%add_field(detj_at_w3, w3_fs, mesh) + + ! @TODO #4487: it is inefficient to calculate this via mass matrices + ! The proper method is preserved in the comment here + ! call invoke( calc_detj_at_w3_kernel_type(detj_at_w3, chi, panel_id) ) + call mm_w3%initialise( w3_fs, w3_fs ) + qr = quadrature_xyoz_type(3, quadrature_rule) + extended_mesh = .false. + call invoke( compute_mass_matrix_kernel_w_scalar_type(mm_w3, & + chi, & + panel_id, & + extended_mesh, & + qr), & + setval_c(detj_at_w3, 0.0_r_def), & + mm_diagonal_kernel_type(detj_at_w3, mm_w3) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Get existing constant + call detj_at_w3_inventory_fv%get_field(mesh, detj_at_w3) + + end function get_detj_at_w3_fv + + !> @brief Returns the (finite element) Det(J) values at W2 dof locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The Det(J) field + function get_detj_at_w2_fe(mesh_id) result(detj_at_w2) + + use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type + use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: detj_at_w2 + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(field_type) :: multiplicity_w2 + type(function_space_type), pointer :: w2_fs + integer(tik) :: id + + ! If running at lowest order, use finite volume + if (element_order_h == 0 .and. element_order_v == 0) then + detj_at_w2 => get_detj_at_w2_fv(mesh_id) + return + end if + + ! Check inventory is initialised + if (.not. detj_at_w2_inventory_fe%is_initialised()) then + ! Initialise all inventories together + call detj_at_w2_inventory_fe%initialise(name='detj_at_w2_fe') + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = detj_at_w2_inventory_fe%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + ! Create the object as it doesn't exist yet + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w2_fs => function_space_collection%get_fs(mesh, element_order_h, & + element_order_v, W2) + call multiplicity_w2%initialise( w2_fs ) + call detj_at_w2_inventory_fe%add_field(detj_at_w2, w2_fs, mesh) + + ! @TODO #4487: a small optimisation here is to multiply by rmultiplicity, + ! rather than computing and dividing by mulitplicity + call invoke( setval_c(detj_at_w2, 0.0_r_def), & + calc_detj_at_w2_kernel_type(detj_at_w2, chi, panel_id), & + setval_c(multiplicity_w2, 0.0_r_def), & + multiplicity_kernel_type(multiplicity_w2), & + inc_X_divideby_Y(detj_at_w2, multiplicity_w2) ) + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Get existing constant + call detj_at_w2_inventory_fe%get_field(mesh, detj_at_w2) + + end function get_detj_at_w2_fe + + !> @brief Returns the (finite volume) Det(J) values at W2 dof locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The Det(J) field + function get_detj_at_w2_fv(mesh_id) result(detj_at_w2) + + use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type + use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: detj_at_w2 + type(field_type), pointer :: chi(:) + type(field_type), pointer :: panel_id + type(field_type) :: multiplicity_w2 + type(function_space_type), pointer :: w2_fs + integer(tik) :: id + + ! Check inventory is initialised + if (.not. detj_at_w2_inventory_fv%is_initialised()) then + ! Initialise all inventories together + call detj_at_w2_inventory_fv%initialise(name='detj_at_w2_fv') + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = detj_at_w2_inventory_fv%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + chi => get_coordinates(mesh_id) + panel_id => get_panel_id(mesh_id) + + ! Create the object as it doesn't exist yet + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w2_fs => function_space_collection%get_fs(mesh, 0, 0, W2) + call multiplicity_w2%initialise( w2_fs ) + call detj_at_w2_inventory_fv%add_field(detj_at_w2, w2_fs, mesh) + + ! @TODO #4487: a small optimisation here is to multiply by rmultiplicity, + ! rather than computing and dividing by mulitplicity + call invoke( setval_c(detj_at_w2, 0.0_r_def), & + calc_detj_at_w2_kernel_type(detj_at_w2, chi, panel_id), & + setval_c(multiplicity_w2, 0.0_r_def), & + multiplicity_kernel_type(multiplicity_w2), & + inc_X_divideby_Y(detj_at_w2, multiplicity_w2) ) + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Get existing constant + call detj_at_w2_inventory_fv%get_field(mesh, detj_at_w2) + + end function get_detj_at_w2_fv + + !> @brief Returns a pointer to the vertical grid spacing, located at W3 DoFs + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The physical height difference of layers, at W3 + function get_dz_w3(mesh_id) result(dz_w3) + + use sci_get_dz_w3_kernel_mod, only: get_dz_w3_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(field_type), pointer :: dz_w3 + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: height_w2 + type(function_space_type), pointer :: w3_fs + integer(tik) :: id + + ! Initialise inventory if this is the first time getting this constant + if (.not. dz_w3_inventory%is_initialised()) then + call dz_w3_inventory%initialise(name="dz_w3") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = dz_w3_inventory%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + ! If this constant doesn't exist, create it + ! Get height first to avoid potentially timing twice + height_w2 => get_height_fv(W2, mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + w3_fs => function_space_collection%get_fs(mesh, 0, 0, W3) + call dz_w3_inventory%add_field(dz_w3, w3_fs, mesh) + + call invoke( get_dz_w3_kernel_type(dz_w3, height_w2) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + else + ! Otherwise, return existing constant + call dz_w3_inventory%get_field(mesh, dz_w3) + end if + + end function get_dz_w3 + + !> @brief Returns the delta_at_wtheta values at Wtheta DoF locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The delta_at_wtheta field + function get_delta_at_wtheta(mesh_id) result(delta_at_wtheta) + + use sci_calc_delta_at_wtheta_kernel_mod, & + only: calc_delta_at_wtheta_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: dx_at_w2 + type(field_type), pointer :: delta_at_wtheta + type(function_space_type), pointer :: wt_k0_fs + integer(tik) :: id + + ! Initialise inventory if it hasn't been done so already + if (.not. delta_at_wtheta_inventory%is_initialised()) then + call delta_at_wtheta_inventory%initialise(name="delta_at_wtheta") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = delta_at_wtheta_inventory%paired_object_exists(mesh_id) + + ! Create constant if it doesn't already exist + if (.not. constant_exists) then + wt_k0_fs => function_space_collection%get_fs(mesh, 0, 0, Wtheta) + dx_at_w2 => get_dx_at_w2(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + call delta_at_wtheta_inventory%add_field(delta_at_wtheta, wt_k0_fs, mesh) + + call invoke( calc_delta_at_wtheta_kernel_type(delta_at_wtheta, dx_at_w2) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Return constant + call delta_at_wtheta_inventory%get_field(mesh, delta_at_wtheta) + + end function get_delta_at_wtheta + + !> @brief Returns the dx_at_w2 values at W2 DoF locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The dx_at_w2 field + function get_dx_at_w2(mesh_id) result(dx_at_w2) + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: dx_at_w2 + type(field_type), pointer :: detj_at_w2 + type(field_type), pointer :: dA_at_w2 + type(function_space_type), pointer :: w2_fs + integer(tik) :: id + + ! Initialise inventory if it hasn't been done so already + if (.not. dx_at_w2_inventory%is_initialised()) then + call dx_at_w2_inventory%initialise(name="dx_at_w2") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = dx_at_w2_inventory%paired_object_exists(mesh_id) + + ! Create constant if it doesn't already exist + if (.not. constant_exists) then + w2_fs => function_space_collection%get_fs(mesh, 0, 0, W2) + detj_at_w2 => get_detj_at_w2_fv(mesh_id) + dA_at_w2 => get_dA_at_w2(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + call dx_at_w2_inventory%add_field(dx_at_w2, w2_fs, mesh) + call invoke( X_divideby_Y(dx_at_w2, detj_at_w2, dA_at_w2) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Return constant + call dx_at_w2_inventory%get_field(mesh, dx_at_w2) + + end function get_dx_at_w2 + + + !> @brief Returns the 1/dz values at lowest-order Wtheta DoF locations + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The dz_at_wtheta field + function get_dz_at_wtheta(mesh_id) result(dz_at_wtheta) + + use sci_calc_dz_face_kernel_mod, only: calc_dz_face_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(field_type), pointer :: dz_at_wtheta + type(function_space_type), pointer :: wtheta_k0_fs + type(field_type), pointer :: height_w3 + type(field_type), pointer :: height_wth + logical(kind=l_def) :: constant_exists + integer(tik) :: id + + ! Parameters of the cells + integer(i_def), parameter :: n_centres = 1_i_def + logical(l_def), parameter :: ign_surf = .false. + + ! Initialise inventory if it hasn't been done so already + if (.not. dz_at_wtheta_inventory%is_initialised()) then + call dz_at_wtheta_inventory%initialise(name="dz_at_wtheta") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = dz_at_wtheta_inventory%paired_object_exists(mesh_id) + + ! Create constant if it doesn't already exist + if (.not. constant_exists) then + ! NB: this assumes heights are in the lowest-order space + height_w3 => get_height_fv(W3, mesh_id) + height_wth => get_height_fv(Wtheta, mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + wtheta_k0_fs => function_space_collection%get_fs(mesh, 0, 0, Wtheta) + + call dz_at_wtheta_inventory%add_field(dz_at_wtheta, wtheta_k0_fs, mesh) + + call invoke( calc_dz_face_kernel_type(dz_at_wtheta, height_w3, & + height_wth, n_centres, ign_surf) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Return constant + call dz_at_wtheta_inventory%get_field(mesh, dz_at_wtheta) + + end function get_dz_at_wtheta + + !> @brief Returns the surface area of a cell projected to mean sea level + !> i.e. ignoring the orographic effect on the area + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The dA_msl_proj field + function get_dA_msl_proj(mesh_id) result(dA_msl_proj) + + use base_mesh_config_mod, only: geometry, geometry_spherical + use extrusion_config_mod, only: planet_radius, domain_height + use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + integer(kind=i_def) :: local_mesh_id + type(mesh_type), pointer :: mesh + type(mesh_type), pointer :: prime_mesh + type(mesh_type), pointer :: twod_mesh + type(local_mesh_type), pointer :: local_mesh + logical(kind=l_def) :: constant_exists + type(field_type), pointer :: dA_msl_proj + type(field_type), pointer :: dA_at_w2 + type(function_space_type), pointer :: fs + integer(tik) :: id + + ! Initialise inventory if it hasn't been done so already + if (.not. dA_msl_proj_inventory%is_initialised()) then + call dA_msl_proj_inventory%initialise(name="dA_msl_proj") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + local_mesh_id = local_mesh%get_id() + constant_exists = dA_msl_proj_inventory%paired_object_exists(local_mesh_id) + + ! Create constant if it doesn't already exist + if (.not. constant_exists) then + prime_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) + twod_mesh => mesh_collection%get_mesh(mesh, TWOD) + fs => function_space_collection%get_fs(twod_mesh, 0, 0, W3) + dA_at_w2 => get_dA_at_w2(prime_mesh%get_id()) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + call dA_msl_proj_inventory%add_field(dA_msl_proj, fs, local_mesh) + call invoke( calc_da_msl_proj_kernel_type(dA_at_w2, dA_msl_proj, & + planet_radius, domain_height, & + geometry, geometry_spherical) ) + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + end if + + ! Return constant + call dA_msl_proj_inventory%get_field(local_mesh, dA_msl_proj) + + end function get_dA_msl_proj + + ! ========================================================================== ! + ! PHYSICAL COORDINATES OF DOFs + ! ========================================================================== ! + + !> @brief Returns a pointer to the longitude of finite element DoFs + !> @param[in] space_id The space for which to get the longitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The longitude field + function get_longitude_fe(space_id, mesh_id) result(long_ptr) + + implicit none + + integer(kind=i_def), intent(in) :: space_id + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(local_mesh_type), pointer :: local_mesh + type(inventory_by_local_mesh_type), pointer :: long_inventory + type(inventory_by_local_mesh_type), pointer :: lat_inventory + type(field_type), pointer :: long_ptr + logical(kind=l_def) :: constant_exists + character(len=str_def) :: inventory_name + + ! If running at lowest order, use finite volume + if (element_order_h == 0 .and. element_order_v == 0) then + long_ptr => get_longitude_fv(space_id, mesh_id) + return + end if + + ! NB: Longitude and latitude fields are computed simultaneously + ! Determine inventory based on space + select case (space_id) + case (W2) + long_inventory => long_w2_inventory_fe + lat_inventory => lat_w2_inventory_fe + inventory_name = "_w2_fe" + case (W2H) + long_inventory => long_w2h_inventory_fe + lat_inventory => lat_w2h_inventory_fe + inventory_name = "_w2h_fe" + case (W3) + long_inventory => long_w3_inventory_fe + lat_inventory => lat_w3_inventory_fe + inventory_name = "_w3_fe" + case default + long_ptr => null() + call log_event("Longitude not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. long_inventory%is_initialised()) then + call long_inventory%initialise(name='longitude_'//trim(inventory_name)) + call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) + end if + + ! Create constant + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) then + call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & + use_fe=.true.) + end if + + call long_inventory%get_field(local_mesh, long_ptr) + + end function get_longitude_fe + + !> @brief Returns a pointer to the longitude of finite volume DoFs + !> @param[in] space_id The space for which to get the longitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The longitude field + function get_longitude_fv(space_id, mesh_id) result(long_ptr) + + implicit none + + integer(kind=i_def), intent(in) :: space_id + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(local_mesh_type), pointer :: local_mesh + type(inventory_by_local_mesh_type), pointer :: long_inventory + type(inventory_by_local_mesh_type), pointer :: lat_inventory + type(field_type), pointer :: long_ptr + logical(kind=l_def) :: constant_exists + character(len=str_def) :: inventory_name + + ! NB: Longitude and latitude fields are computed simultaneously + ! Determine inventory based on space + select case (space_id) + case (W2) + long_inventory => long_w2_inventory_fv + lat_inventory => lat_w2_inventory_fv + inventory_name = "_w2_fv" + case (W2H) + long_inventory => long_w2h_inventory_fv + lat_inventory => lat_w2h_inventory_fv + inventory_name = "_w2h_fv" + case (W3) + long_inventory => long_w3_inventory_fv + lat_inventory => lat_w3_inventory_fv + inventory_name = "_w3_fv" + case default + long_ptr => null() + call log_event("Longitude not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. long_inventory%is_initialised()) then + call long_inventory%initialise(name='longitude_'//trim(inventory_name)) + call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) + end if + + ! Create constant + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) then + call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & + use_fe=.false.) + end if + + call long_inventory%get_field(local_mesh, long_ptr) + + end function get_longitude_fv + + !> @brief Returns a pointer to the latitude of finite element DoFs + !> @param[in] space_id The space for which to get the latitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The latitude field + function get_latitude_fe(space_id, mesh_id) result(lat_ptr) + + implicit none + + integer(kind=i_def), intent(in) :: space_id + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(local_mesh_type), pointer :: local_mesh + type(inventory_by_local_mesh_type), pointer :: long_inventory + type(inventory_by_local_mesh_type), pointer :: lat_inventory + type(field_type), pointer :: lat_ptr + logical(kind=l_def) :: constant_exists + character(len=str_def) :: inventory_name + + ! If running at lowest order, use finite volume + if (element_order_h == 0 .and. element_order_v == 0) then + lat_ptr => get_latitude_fv(space_id, mesh_id) + return + end if + + ! NB: Longitude and latitude fields are computed simultaneously + ! Determine inventory based on space + select case (space_id) + case (W2) + long_inventory => long_w2_inventory_fe + lat_inventory => lat_w2_inventory_fe + inventory_name = "_w2_fe" + case (W2H) + long_inventory => long_w2h_inventory_fe + lat_inventory => lat_w2h_inventory_fe + inventory_name = "_w2h_fe" + case (W3) + long_inventory => long_w3_inventory_fe + lat_inventory => lat_w3_inventory_fe + inventory_name = "_w3_fe" + case default + lat_ptr => null() + call log_event("Latitude not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. lat_inventory%is_initialised()) then + call long_inventory%initialise(name='longitude_'//trim(inventory_name)) + call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) + end if + + ! Create constant + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) then + call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & + use_fe=.true.) + end if + + call lat_inventory%get_field(local_mesh, lat_ptr) + + end function get_latitude_fe + + !> @brief Returns a pointer to the latitude of finite volume DoFs + !> @param[in] space_id The space for which to get the latitude of DoFs for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The latitude field + function get_latitude_fv(space_id, mesh_id) result(lat_ptr) + + implicit none + + integer(kind=i_def), intent(in) :: space_id + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(local_mesh_type), pointer :: local_mesh + type(inventory_by_local_mesh_type), pointer :: long_inventory + type(inventory_by_local_mesh_type), pointer :: lat_inventory + type(field_type), pointer :: lat_ptr + logical(kind=l_def) :: constant_exists + character(len=str_def) :: inventory_name + + ! NB: Longitude and latitude fields are computed simultaneously + ! Determine inventory based on space + select case (space_id) + case (W2) + long_inventory => long_w2_inventory_fv + lat_inventory => lat_w2_inventory_fv + inventory_name = "_w2_fv" + case (W2H) + long_inventory => long_w2h_inventory_fv + lat_inventory => lat_w2h_inventory_fv + inventory_name = "_w2h_fv" + case (W3) + long_inventory => long_w3_inventory_fv + lat_inventory => lat_w3_inventory_fv + inventory_name = "_w3_fv" + case default + lat_ptr => null() + call log_event("Latitude not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. lat_inventory%is_initialised()) then + call long_inventory%initialise(name='longitude_'//trim(inventory_name)) + call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) + end if + + ! Create constant + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) then + call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & + use_fe=.false.) + end if + + call lat_inventory%get_field(local_mesh, lat_ptr) + + end function get_latitude_fv + + !> @brief Returns a pointer to a finite element height field + !> @param[in] space The space of the desired height field + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return A height field + function get_height_fe(space_id, mesh_id) result(height) + + use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type + use sci_height_discontinuous_kernel_mod, & + only: height_discontinuous_kernel_type + use base_mesh_config_mod, only: geometry + use finite_element_config_mod, only: coord_system + use planet_config_mod, only: scaled_radius + + implicit none + + integer(kind=i_def), intent(in) :: space_id + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(inventory_by_mesh_type), pointer :: inventory + logical(kind=l_def) :: constant_exists + type(function_space_type), pointer :: space + type(field_type), pointer :: chi(:) + type(field_type), pointer :: height + type(field_type) :: rmultiplicity + type(field_type) :: nodal_multiplicity + type(field_type) :: ones + character(len=str_def) :: inventory_name + integer(tik) :: id + + ! If running at lowest order, use finite volume + if (element_order_h == 0 .and. element_order_v == 0) then + height => get_height_fv(space_id, mesh_id) + return + end if + + ! Determine inventory based on space + select case (space_id) + case (W0) + inventory => height_w0_inventory_fe + inventory_name = "height_w0_fe" + case (W1) + inventory => height_w1_inventory_fe + inventory_name = "height_w1_fe" + case (W2) + inventory => height_w2_inventory_fe + inventory_name = "height_w2_fe" + case (W2H) + inventory => height_w2h_inventory_fe + inventory_name = "height_w2h_fe" + case (W3) + inventory => height_w3_inventory_fe + inventory_name = "height_w3_fe" + case (Wtheta) + inventory => height_wth_inventory_fe + inventory_name = "height_wtheta_fe" + case default + height => null() + call log_event("Height not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. inventory%is_initialised()) then + call inventory%initialise(name=inventory_name) + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = inventory%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + ! If this constant doesn't exist, create it + chi => get_coordinates(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + space => function_space_collection%get_fs( & + mesh, element_order_h, element_order_v, space_id & + ) + call inventory%add_field(height, space, mesh) + + select case (space_id) + ! Horizontally discontinuous spaces + case (W3, Wtheta) + call invoke( & + height_discontinuous_kernel_type( & + height, chi, geometry, coord_system, scaled_radius & + ) & + ) + + ! Horizontally continuous spaces + case default + ! Can't import multiplicity, so must calculate it + call ones%initialise( space ) + call nodal_multiplicity%initialise( space ) + call rmultiplicity%initialise( space ) + + call invoke( & + setval_c(ones, 1.0_r_def), & + setval_c(nodal_multiplicity, 0.0_r_def), & + multiplicity_kernel_type(nodal_multiplicity), & + X_divideby_Y(rmultiplicity, ones, nodal_multiplicity), & + setval_c(height, 0.0_r_def), & + height_continuous_kernel_type( & + height, chi, rmultiplicity, & + geometry, coord_system, scaled_radius & + ) & + ) + end select + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + else + call inventory%get_field(mesh, height) + end if + + end function get_height_fe + + !> @brief Returns a pointer to a finite volume height field + !> @param[in] space The space of the desired height field + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return A height field + function get_height_fv(space_id, mesh_id) result(height) + + use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type + use sci_height_discontinuous_kernel_mod, & + only: height_discontinuous_kernel_type + use base_mesh_config_mod, only: geometry + use finite_element_config_mod, only: coord_system + use planet_config_mod, only: scaled_radius + + implicit none + + integer(kind=i_def), intent(in) :: space_id + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh + type(inventory_by_mesh_type), pointer :: inventory + logical(kind=l_def) :: constant_exists + type(function_space_type), pointer :: space + type(field_type), pointer :: chi(:) + type(field_type), pointer :: height + type(field_type) :: rmultiplicity + type(field_type) :: nodal_multiplicity + type(field_type) :: ones + character(len=str_def) :: inventory_name + integer(tik) :: id + + ! Determine inventory based on space + select case (space_id) + case (W0) + inventory => height_w0_inventory_fv + inventory_name = "height_w0_fv" + case (W1) + inventory => height_w1_inventory_fv + inventory_name = "height_w1_fv" + case (W2) + inventory => height_w2_inventory_fv + inventory_name = "height_w2_fv" + case (W2H) + inventory => height_w2h_inventory_fv + inventory_name = "height_w2h_fv" + case (W3) + inventory => height_w3_inventory_fv + inventory_name = "height_w3_fv" + case (Wtheta) + inventory => height_wth_inventory_fv + inventory_name = "height_wtheta_fv" + case default + height => null() + call log_event("Height not available on requested space", LOG_LEVEL_ERROR) + end select + + ! Initialise inventory if this is the first time getting this constant + if (.not. inventory%is_initialised()) then + call inventory%initialise(name=inventory_name) + end if + + mesh => mesh_collection%get_mesh(mesh_id) + constant_exists = inventory%paired_object_exists(mesh_id) + + if (.not. constant_exists) then + ! If this constant doesn't exist, create it + chi => get_coordinates(mesh_id) + + if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) + + space => function_space_collection%get_fs(mesh, 0, 0, space_id) + call inventory%add_field(height, space, mesh) + + select case (space_id) + ! Horizontally discontinuous spaces + case (W3, Wtheta) + call invoke( & + height_discontinuous_kernel_type( & + height, chi, geometry, coord_system, scaled_radius & + ) & + ) + + ! Horizontally continuous spaces + case default + ! Can't import multiplicity, so must calculate it + call ones%initialise( space ) + call nodal_multiplicity%initialise( space ) + call rmultiplicity%initialise( space ) + + call invoke( & + setval_c(ones, 1.0_r_def), & + setval_c(nodal_multiplicity, 0.0_r_def), & + multiplicity_kernel_type(nodal_multiplicity), & + X_divideby_Y(rmultiplicity, ones, nodal_multiplicity), & + setval_c(height, 0.0_r_def), & + height_continuous_kernel_type( & + height, chi, rmultiplicity, & + geometry, coord_system, scaled_radius & + ) & + ) + end select + + if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) + else + call inventory%get_field(mesh, height) + end if + + end function get_height_fv + + ! ========================================================================== ! + ! FACE SELECTORS + ! ========================================================================== ! + + !> @brief Returns a pointer to the east-west face selector + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The east-west face selector + function get_face_selector_ew(mesh_id) result(selector) + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh => null() + type(local_mesh_type), pointer :: local_mesh => null() + type(integer_field_type), pointer :: selector + logical(kind=l_def) :: constant_exists + + ! Initialise inventory if this is the first time getting this constant + if (.not. face_selector_ew_inventory%is_initialised()) then + call face_selector_ew_inventory%initialise(name="face_selector_ew") + call face_selector_ns_inventory%initialise(name="face_selector_ns") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = & + face_selector_ew_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) call compute_face_selectors(mesh) + + call face_selector_ew_inventory%get_field(local_mesh, selector) + + end function get_face_selector_ew + + !> @brief Returns a pointer to the north-south face selector + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @return The north-south face selector + function get_face_selector_ns(mesh_id) result(selector) + + implicit none + + integer(kind=i_def), intent(in) :: mesh_id + type(mesh_type), pointer :: mesh => null() + type(local_mesh_type), pointer :: local_mesh => null() + type(integer_field_type), pointer :: selector + logical(kind=l_def) :: constant_exists + + ! Initialise inventory if this is the first time getting this constant + if (.not. face_selector_ew_inventory%is_initialised()) then + call face_selector_ew_inventory%initialise(name="face_selector_ew") + call face_selector_ns_inventory%initialise(name="face_selector_ns") + end if + + mesh => mesh_collection%get_mesh(mesh_id) + local_mesh => mesh%get_local_mesh() + constant_exists = & + face_selector_ns_inventory%paired_object_exists(local_mesh%get_id()) + + if (.not. constant_exists) call compute_face_selectors(mesh) + + call face_selector_ns_inventory%get_field(local_mesh, selector) + + end function get_face_selector_ns + + ! ========================================================================== ! + ! GETTERS FOR INVENTORIES + ! ========================================================================== ! + ! These are two special inventories, which are set up in the driver + + !> @brief Returns a pointer to the chi inventory + function get_chi_inventory() result(inventory_ptr) + implicit none + type(inventory_by_mesh_type), pointer :: inventory_ptr + + inventory_ptr => chi_inventory + + end function get_chi_inventory + + !> @brief Returns a pointer to the panel_id inventory + function get_panel_id_inventory() result(inventory_ptr) + implicit none + type(inventory_by_mesh_type), pointer :: inventory_ptr + + inventory_ptr => panel_id_inventory + + end function get_panel_id_inventory + + ! ========================================================================== ! + ! FINALISE + ! ========================================================================== ! + !> @brief Explicitly reclaim memory from module scope variables + subroutine final_geometric_constants() + + implicit none + + call lat_w2_inventory_fe%clear() + call lat_w2_inventory_fv%clear() + call lat_w3_inventory_fe%clear() + call lat_w3_inventory_fv%clear() + call lat_w2h_inventory_fe%clear() + call lat_w2h_inventory_fv%clear() + call long_w2_inventory_fe%clear() + call long_w2_inventory_fv%clear() + call long_w3_inventory_fe%clear() + call long_w3_inventory_fv%clear() + call long_w2h_inventory_fe%clear() + call long_w2h_inventory_fv%clear() + call dA_at_w2_inventory%clear() + call height_wth_inventory_fe%clear() + call height_wth_inventory_fv%clear() + call height_w3_inventory_fe%clear() + call height_w3_inventory_fv%clear() + call height_w2_inventory_fe%clear() + call height_w2_inventory_fv%clear() + call height_w2h_inventory_fe%clear() + call height_w2h_inventory_fv%clear() + call height_w1_inventory_fe%clear() + call height_w1_inventory_fv%clear() + call height_w0_inventory_fe%clear() + call height_w0_inventory_fv%clear() + call dz_w3_inventory%clear() + call panel_id_inventory%clear() + call chi_inventory%clear() + call extended_chi_inventory%clear() + call detj_at_w3_inventory_fe%clear() + call detj_at_w3_inventory_fv%clear() + call detj_at_w2_inventory_fe%clear() + call detj_at_w2_inventory_fv%clear() + call delta_at_wtheta_inventory%clear() + call dx_at_w2_inventory%clear() + call dz_at_wtheta_inventory%clear() + call dA_msl_proj_inventory%clear() + + end subroutine final_geometric_constants + +end module sci_geometric_constants_mod diff --git a/components/science/source/algorithm/sci_mapping_constants_mod.x90 b/components/science/source/algorithm/sci_mapping_constants_mod.x90 index 3f65e4b2f..e9201e6ed 100644 --- a/components/science/source/algorithm/sci_mapping_constants_mod.x90 +++ b/components/science/source/algorithm/sci_mapping_constants_mod.x90 @@ -15,7 +15,6 @@ module sci_mapping_constants_mod ! Infrastructure -! use config_mod, only: config_type use constants_mod, only: i_def, r_def, l_def, str_def use copy_field_alg_mod, only: copy_field use extrusion_mod, only: PRIME_EXTRUSION, & @@ -46,8 +45,9 @@ module sci_mapping_constants_mod ! Configuration use finite_element_config_mod, only: element_order_h, & element_order_v + ! Other algorithms - use sci_geometric_constants_mod, only: get_coordinates, & + use sci_geometric_constants_mod, only: get_coordinates, & get_panel_id ! Kernels @@ -199,10 +199,12 @@ contains !> @brief Create the operators for projecting spherical components in !! (W3, W3, Wtheta) to a vector-valued field in W2 - !> @param[in] config Configuration object - !> @param[in] mesh The mesh to compute the operators for - subroutine create_spherical_components_to_w2_projection( mesh, & - geometry, topology, & + !> @param[in] mesh The mesh to compute the operators for + !> @param[in] geometry + !> @param[in] topology + !> @param[in] coord-system + !> @param[in] scaled_radius + subroutine create_spherical_components_to_w2_projection( mesh, geometry, topology, & coord_system, scaled_radius ) use sci_compute_map_u_operators_kernel_mod, & @@ -210,9 +212,8 @@ contains implicit none -! type(config_type), intent(in) :: config - type(mesh_type), pointer, intent(in) :: mesh + integer(i_def), intent(in) :: geometry integer(i_def), intent(in) :: topology integer(i_def), intent(in) :: coord_system @@ -229,13 +230,6 @@ contains type(operator_type), pointer :: u_lat_map type(operator_type), pointer :: u_up_map - - -!!$ geometry = config%base_mesh%geometry() -!!$ topology = config%base_mesh%topology() -!!$ coord_system = config%finite_element%coord_system() -!!$ scaled_radius = config%planet%scaled_radius() - if (.not. u_lon_map_inventory%is_initialised()) then call u_lon_map_inventory%initialise(name='u_lon_map') end if @@ -274,10 +268,8 @@ contains !> @brief Create the operators for sampling spherical components in !! (W3, W3, Wtheta) to a vector-valued field in W2 - !> @param[in] config Configuration object !> @param[in] mesh The mesh to compute the operators for - subroutine create_spherical_components_to_w2_sample( mesh, & - geometry, topology, & + subroutine create_spherical_components_to_w2_sample( mesh, geometry, topology, & coord_system, scaled_radius ) use sci_compute_sample_u_ops_kernel_mod, & @@ -285,8 +277,6 @@ contains implicit none -! type(config_type), intent(in) :: config - type(mesh_type), pointer, intent(in) :: mesh integer(i_def), intent(in) :: geometry @@ -305,11 +295,6 @@ contains type(operator_type), pointer :: u_up_sample integer(tik) :: id -!!$ geometry = config%base_mesh%geometry() -!!$ topology = config%base_mesh%topology() -!!$ coord_system = config%finite_element%coord_system() -!!$ scaled_radius = config%planet%scaled_radius() - if (.not. u_lon_sample_inventory%is_initialised()) then call u_lon_sample_inventory%initialise(name='u_lon_sample') end if @@ -887,8 +872,9 @@ contains !> @brief Returns a pointer to the u_lon mapping operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The mapping operator for u_lon to W2 - function get_u_lon_map(mesh_id, geometry, topology, & - coord_system, scaled_radius ) result(u_lon_map_op) + function get_u_lon_map( mesh_id, geometry, topology, & + coord_system, scaled_radius ) & + result( u_lon_map_op ) implicit none @@ -923,8 +909,9 @@ contains !> @brief Returns a pointer to the u_lat mapping operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The mapping operator for u_lat to W2 - function get_u_lat_map(mesh_id, geometry, topology, & - coord_system, scaled_radius) result(u_lat_map_op) + function get_u_lat_map( mesh_id, geometry, topology, & + coord_system, scaled_radius ) & + result( u_lat_map_op ) implicit none @@ -947,8 +934,7 @@ contains constant_exists = u_lat_map_inventory%paired_object_exists(mesh_id) if (.not. constant_exists) then - call create_spherical_components_to_w2_projection(mesh, & - geometry, topology, & + call create_spherical_components_to_w2_projection(mesh, geometry, topology, & coord_system, scaled_radius) end if @@ -960,8 +946,9 @@ contains !> @brief Returns a pointer to the u_up mapping operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The mapping operator for u_up to W2 - function get_u_up_map(mesh_id, geometry, topology, & - coord_system, scaled_radius) result(u_up_map_op) + function get_u_up_map( mesh_id, geometry, topology, & + coord_system, scaled_radius ) & + result( u_up_map_op ) implicit none @@ -984,9 +971,8 @@ contains constant_exists = u_up_map_inventory%paired_object_exists(mesh_id) if (.not. constant_exists) then - call create_spherical_components_to_w2_projection( mesh, & - geometry, topology, & - coord_system, scaled_radius ) + call create_spherical_components_to_w2_projection(mesh, geometry, topology, & + coord_system, scaled_radius) end if ! Return constant @@ -997,10 +983,9 @@ contains !> @brief Returns a pointer to the u_lon sampling operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The sampling operator for u_lon to W2 - function get_u_lon_sample(mesh_id, & - geometry, topology, & - coord_system, scaled_radius) & - result(u_lon_sample_op) + function get_u_lon_sample( mesh_id, geometry, topology, & + coord_system, scaled_radius ) & + result( u_lon_sample_op ) implicit none @@ -1023,8 +1008,7 @@ contains constant_exists = u_lon_sample_inventory%paired_object_exists(mesh_id) if (.not. constant_exists) then - call create_spherical_components_to_w2_sample(mesh, & - geometry, topology, & + call create_spherical_components_to_w2_sample(mesh, geometry, topology, & coord_system, scaled_radius) end if @@ -1036,9 +1020,9 @@ contains !> @brief Returns a pointer to the u_lat sampling operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The sampling operator for u_lat to W2 - function get_u_lat_sample(mesh_id, & - geometry, topology, & - coord_system, scaled_radius) result(u_lat_sample_op) + function get_u_lat_sample( mesh_id, geometry, topology, & + coord_system, scaled_radius ) & + result( u_lat_sample_op ) implicit none @@ -1061,8 +1045,7 @@ contains constant_exists = u_lat_sample_inventory%paired_object_exists(mesh_id) if (.not. constant_exists) then - call create_spherical_components_to_w2_sample(mesh, & - geometry, topology, & + call create_spherical_components_to_w2_sample(mesh, geometry, topology, & coord_system, scaled_radius) end if @@ -1074,9 +1057,9 @@ contains !> @brief Returns a pointer to the u_up sampling operator !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The sampling operator for u_up to W2 - function get_u_up_sample(mesh_id, & - geometry, topology, & - coord_system, scaled_radius) result(u_up_sample_op) + function get_u_up_sample( mesh_id, geometry, topology, & + coord_system, scaled_radius) & + result( u_up_sample_op ) implicit none @@ -1099,8 +1082,7 @@ contains constant_exists = u_up_sample_inventory%paired_object_exists(mesh_id) if (.not. constant_exists) then - call create_spherical_components_to_w2_sample( mesh, & - geometry, topology, & + call create_spherical_components_to_w2_sample( mesh, geometry, topology, & coord_system, scaled_radius ) end if @@ -1110,10 +1092,11 @@ contains end function get_u_up_sample !> @brief Returns a pointer to the operator projection from lon dot to W1 - !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The projection operator - function get_project_lon_dot_to_w1( mesh_id, geometry, topology, coord_system, scaled_radius ) result( proj_op ) + function get_project_lon_dot_to_w1( mesh_id, geometry, topology, & + coord_system, scaled_radius ) & + result( proj_op ) implicit none @@ -1177,15 +1160,14 @@ contains end function get_project_lon_dot_to_w1 !> @brief Returns a pointer to the operator projection from lat dot to W1 - !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The projection operator - function get_project_lat_dot_to_w1( mesh_id, geometry, topology, coord_system, scaled_radius ) result( proj_op ) + function get_project_lat_dot_to_w1( mesh_id, geometry, topology, & + coord_system, scaled_radius ) & + result( proj_op ) implicit none -! type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id integer(i_def), intent(in) :: geometry integer(i_def), intent(in) :: topology @@ -1203,16 +1185,6 @@ contains integer(kind=i_def), parameter :: ydirection = 2_i_def integer(tik) :: id -!!$ integer(i_def) :: geometry -!!$ integer(i_def) :: topology -!!$ integer(i_def) :: coord_system -!!$ real(r_def) :: scaled_radius -!!$ -!!$ geometry = config%base_mesh%geometry() -!!$ topology = config%base_mesh%topology() -!!$ coord_system = config%finite_element%coord_system() -!!$ scaled_radius = config%planet%scaled_radius() - ! Check inventory is initialised if (.not. project_lat_dot_to_w1_inventory%is_initialised()) then call project_lat_dot_to_w1_inventory%initialise( & @@ -1256,17 +1228,14 @@ contains end function get_project_lat_dot_to_w1 !> @brief Returns a pointer to the operator projection from r dot to W1 - !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The projection operator - function get_project_r_dot_to_w1( mesh_id, & - geometry, topology, & - coord_system, scaled_radius ) result(proj_op) + function get_project_r_dot_to_w1( mesh_id, geometry, topology, & + coord_system, scaled_radius ) & + result( proj_op ) implicit none -! type(config_type), intent(in) :: config - integer(i_def), intent(in) :: mesh_id integer(i_def), intent(in) :: geometry integer(i_def), intent(in) :: topology @@ -1283,12 +1252,6 @@ contains type(quadrature_xyoz_type), pointer :: qr integer(kind=i_def), parameter :: zdirection = 3_i_def integer(tik) :: id -!!$ -!!$ -!!$ geometry = config%base_mesh%geometry() -!!$ topology = config%base_mesh%topology() -!!$ coord_system = config%finite_element%coord_system() -!!$ scaled_radius = config%planet%scaled_radius() ! Check inventory is initialised if (.not. project_r_dot_to_w1_inventory%is_initialised()) then @@ -1331,22 +1294,16 @@ contains end function get_project_r_dot_to_w1 !> @brief Returns the displacement when averaging from W3 to W2 - !> @param[in] config Configuration object !> @param[in] mesh_id The ID of the mesh to get the object for !> @return The displacement field used for correcting mappings from W3 to W2 - function get_w3_to_w2_displacement(mesh_id,& - geometry,& - topology,& - coord_system,& - scaled_radius) result(w3_to_w2_displacement) + function get_w3_to_w2_displacement( mesh_id, geometry, topology, & + coord_system, scaled_radius ) & + result( w3_to_w2_displacement ) use sci_w3_to_w2_displacement_kernel_mod, & only: w3_to_w2_displacement_kernel_type implicit none -! type(config_type), intent(in) :: config - - integer(i_def), intent(in) :: mesh_id integer(i_def), intent(in) :: geometry integer(i_def), intent(in) :: topology @@ -1363,11 +1320,6 @@ contains type(function_space_type), pointer :: w2h_k0_fs type(function_space_type), pointer :: w3_k0_fs integer(tik) :: id -!!$ -!!$ geometry = config%base_mesh%geometry() -!!$ topology = config%base_mesh%topology() -!!$ coord_system = config%finite_element%coord_system() -!!$ scaled_radius = config%planet%scaled_radius() ! Initialise inventory if this is the first time getting this constant if (.not. w3_to_w2_displacement_inventory%is_initialised()) then diff --git a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 index 0d9f4a84b..a85980009 100644 --- a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 +++ b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 @@ -31,8 +31,8 @@ module sci_chi_transform_mod use matrix_invert_mod, only : matrix_invert_3x3 ! Configuration modules -use base_mesh_config_mod, only: geometry_spherical, & - geometry_planar, & +use base_mesh_config_mod, only: geometry_spherical, & + geometry_planar, & topology_fully_periodic use finite_element_config_mod, only: coord_system_xyz, & coord_system_native @@ -89,10 +89,10 @@ module sci_chi_transform_mod !! argument, and ideally should only be used for !! unit-testing. !------------------------------------------------------------------------------ -subroutine init_chi_transforms( geometry, & - topology, & - mesh_collection, & - north_pole_arg, equator_lat_arg ) +subroutine init_chi_transforms( geometry, topology, & + mesh_collection, & + north_pole_arg, & + equator_lat_arg ) use local_mesh_mod, only: local_mesh_type use mesh_collection_mod, only: mesh_collection_type @@ -118,6 +118,7 @@ subroutine init_chi_transforms( geometry, & ! -------------------------------------------------------------------------- ! ! Extract stretching and rotation information from mesh ! -------------------------------------------------------------------------- ! + ! Begin by assuming no stretching and no rotation to_stretch = .false. to_rotate = .false. @@ -250,14 +251,12 @@ end subroutine final_chi_transforms !! @param[in] topology !! @param[in] coord_system !! @param[in] scaled_radius -!! @param[in] panel_id The mesh panel ID !! @param[out] x The first coordinate field out (global Cartesian X) !! @param[out] y The second coordinate field out (global Cartesian Y) !! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- -subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, & - coord_system, scaled_radius, & +subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, coord_system, scaled_radius, & x, y, z ) implicit none @@ -354,15 +353,15 @@ subroutine chir2xyz( chi_1, chi_2, chi_3, panel_id, & implicit none - integer(kind=i_def), intent(in) :: panel_id - real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 - real(kind=r_def), intent(out) :: x, y, z + integer(kind=i_def), intent(in) :: panel_id + real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + integer(kind=i_def), intent(in) :: coord_system - real(kind=r_def) :: xyz(3) + real(kind=r_def), intent(out) :: x, y, z - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system + real(kind=r_def) :: xyz(3) if (coord_system == coord_system_xyz .or. geometry == geometry_planar) then ! chi already uses (geocentric) Cartesian coordinates @@ -437,23 +436,22 @@ end subroutine chir2xyz !! @param[out] latitude The second coordinate field out (latitude) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, & - coord_system, scaled_radius, & +subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, coord_system, scaled_radius, & lon, lat, radius ) implicit none - integer(kind=i_def), intent(in) :: panel_id - real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 - real(kind=r_def), intent(out) :: lon, lat, radius + integer(kind=i_def), intent(in) :: panel_id + real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + integer(kind=i_def), intent(in) :: coord_system + real(kind=r_def), intent(in) :: scaled_radius - real(kind=r_def) :: xyz(3) + real(kind=r_def), intent(out) :: lon, lat, radius - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system - real(r_def), intent(in) :: scaled_radius + real(kind=r_def) :: xyz(3) if (geometry == geometry_planar .or. coord_system == coord_system_xyz) then ! chi uses (geocentric) Cartesian coordinates @@ -521,23 +519,22 @@ end subroutine chi2llr !! @param[out] beta The second coordinate field out (beta) !! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- -subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & - geometry, topology, & - coord_system, scaled_radius, & +subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & + geometry, topology, coord_system, scaled_radius, & alpha, beta, radius ) implicit none - integer(kind=i_def), intent(in) :: panel_id - real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 - real(kind=r_def), intent(out) :: alpha, beta, radius + integer(kind=i_def), intent(in) :: panel_id + real(kind=r_def), intent(in) :: chi_1, chi_2, chi_3 + integer(kind=i_def), intent(in) :: geometry + integer(kind=i_def), intent(in) :: topology + integer(kind=i_def), intent(in) :: coord_system + real(kind=r_def), intent(in) :: scaled_radius - real(kind=r_def) :: xyz(3) + real(kind=r_def), intent(out) :: alpha, beta, radius - integer(i_def), intent(in) :: geometry - integer(i_def), intent(in) :: topology - integer(i_def), intent(in) :: coord_system - real(r_def), intent(in) :: scaled_radius + real(kind=r_def) :: xyz(3) if (topology /= topology_fully_periodic .or. geometry /= geometry_spherical) then diff --git a/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 b/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 index 993c0aec4..584647b53 100644 --- a/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 @@ -32,10 +32,10 @@ module sci_compute_latlon_kernel_mod type, public, extends(kernel_type) :: compute_latlon_kernel_type private type(arg_type) :: meta_args(8) = (/ & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), & - 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, GH_REAL, GH_WRITE, ANY_SPACE_1), &! latitude + arg_type(GH_FIELD, GH_REAL, GH_WRITE, ANY_SPACE_1), &! longitude + arg_type(GH_FIELD*3, GH_REAL, GH_READ, ANY_SPACE_9), &! chi_1, chi_2, chi_3 + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), &! panel_id arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system @@ -82,17 +82,16 @@ module sci_compute_latlon_kernel_mod !> @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 -subroutine compute_latlon_code(nlayers, & - latitude, longitude, & - chi_1, chi_2, chi_3, & - panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - ndf_x, undf_x, map_x, & - ndf_chi, undf_chi, map_chi, & - basis_chi, & - ndf_pid, undf_pid, map_pid & - ) +subroutine compute_latlon_code( nlayers, & + latitude, longitude, & + chi_1, chi_2, chi_3, & + panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + ndf_x, undf_x, map_x, & + ndf_chi, undf_chi, map_chi, & + basis_chi, & + ndf_pid, undf_pid, map_pid ) implicit none diff --git a/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 b/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 index 965ecacff..1d5a1b5f9 100644 --- a/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/sci_nodal_xyz_coordinates_kernel_mod.F90 @@ -30,9 +30,9 @@ module sci_nodal_xyz_coordinates_kernel_mod type, public, extends(kernel_type) :: nodal_xyz_coordinates_kernel_type private type(arg_type) :: meta_args(7) = (/ & - arg_type(GH_FIELD*3, GH_REAL, GH_WRITE, ANY_SPACE_1), & - 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_WRITE, ANY_SPACE_1), &! nodal_x, nodal_y, nodal_z + arg_type(GH_FIELD*3, GH_REAL, GH_READ, ANY_SPACE_9), &! chi_1, chi_2, chi_3 + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), &! panel_id arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system @@ -78,17 +78,16 @@ module sci_nodal_xyz_coordinates_kernel_mod !> @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 panel_id field -subroutine nodal_xyz_coordinates_code(nlayers, & - nodal_x, nodal_y, nodal_z, & - chi1, chi2, chi3, & - panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - ndf_x, undf_x, map_x, & - ndf_chi, undf_chi, map_chi, & - basis_chi, & - ndf_pid, undf_pid, map_pid & - ) +subroutine nodal_xyz_coordinates_code( nlayers, & + nodal_x, nodal_y, nodal_z, & + chi1, chi2, chi3, & + panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + ndf_x, undf_x, map_x, & + ndf_chi, undf_chi, map_chi, & + basis_chi, & + ndf_pid, undf_pid, map_pid ) implicit none diff --git a/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 index 48d850335..a1fcfdfd6 100644 --- a/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_compute_map_u_operators_kernel_mod.F90 @@ -44,11 +44,11 @@ module sci_compute_map_u_operators_kernel_mod type, public, extends(kernel_type) :: compute_map_u_operators_kernel_type private type(arg_type) :: meta_args(9) = (/ & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, W3), & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, W3), & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, WTHETA), & - 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_OPERATOR, GH_REAL, GH_WRITE, W2, W3), &! u_lon_op + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, W3), &! u_lat_op + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2, WTHETA), &! u_up_op + arg_type(GH_FIELD*3, GH_REAL, GH_READ, ANY_SPACE_9), &! chi_sph_1, chi_sph_2, chi_sph_3 + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), &! panel_id arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system @@ -111,20 +111,19 @@ module sci_compute_map_u_operators_kernel_mod !! @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 compute_map_u_operators_code(cell, nlayers, ncell_3d_1, & - u_lon_op, ncell_3d_2, u_lat_op, & - ncell_3d_3, u_up_op, & - chi_sph_1, chi_sph_2, chi_sph_3, panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - ndf_w2, basis_w2, & - ndf_w3, basis_w3, & - ndf_wt, basis_wt, & - ndf_chi_sph, undf_chi_sph, map_chi_sph, & - chi_sph_basis, chi_sph_diff_basis, & - ndf_pid, undf_pid, map_pid, & - nqp_h, nqp_v, wqp_h, wqp_v & - ) +subroutine compute_map_u_operators_code( cell, nlayers, ncell_3d_1, & + u_lon_op, ncell_3d_2, u_lat_op, & + ncell_3d_3, u_up_op, & + chi_sph_1, chi_sph_2, chi_sph_3, panel_id, & + geometry, topology, & + coord_system, scaled_radius, & + ndf_w2, basis_w2, & + ndf_w3, basis_w3, & + ndf_wt, basis_wt, & + ndf_chi_sph, undf_chi_sph, map_chi_sph, & + chi_sph_basis, chi_sph_diff_basis, & + ndf_pid, undf_pid, map_pid, & + nqp_h, nqp_v, wqp_h, wqp_v ) use sci_chi_transform_mod, only : chi2llr use sci_coordinate_jacobian_mod, only : coordinate_jacobian diff --git a/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 index 52c665ca2..4c9992d82 100644 --- a/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_compute_sample_u_ops_kernel_mod.F90 @@ -48,11 +48,11 @@ module sci_compute_sample_u_ops_kernel_mod type, public, extends(kernel_type) :: compute_sample_u_ops_kernel_type private type(arg_type) :: meta_args(9) = (/ & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, W3), & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, W3), & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, WTHETA), & - arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & - arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, W3), &! u_lon_op + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, W3), &! u_lat_op + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W2broken, WTHETA), &! u_rad_op + arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), &! chi_1, chi_2, chi_3 + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), &! panel_id arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system @@ -109,20 +109,18 @@ module sci_compute_sample_u_ops_kernel_mod !> @param[in] map_pid DoF map for the column's base cell for panel ID field !> @param[in] nfaces Number of cell faces !> @param[in] face_normals The normal vectors to each face -subroutine compute_sample_u_ops_code( col, nlayers, & - ncell_3d_1, u_lon_op, & - ncell_3d_2, u_lat_op, & - ncell_3d_3, u_rad_op, & - chi1, chi2, chi3, & - panel_id, & - geometry, topology, & - coord_system, scaled_radius, & - ndf_w2b, ndf_w3, ndf_wt, & - ndf_chi, undf_chi, map_chi, & - chi_basis, chi_diff_basis, & - ndf_pid, undf_pid, map_pid, & - nfaces, face_normals & - ) +subroutine compute_sample_u_ops_code( col, nlayers, & + ncell_3d_1, u_lon_op, & + ncell_3d_2, u_lat_op, & + ncell_3d_3, u_rad_op, & + chi1, chi2, chi3, & + panel_id, geometry, topology, & + coord_system, scaled_radius, & + ndf_w2b, ndf_w3, ndf_wt, & + ndf_chi, undf_chi, map_chi, & + chi_basis, chi_diff_basis, & + ndf_pid, undf_pid, map_pid, & + nfaces, face_normals ) implicit none diff --git a/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 index 287012515..bd2b30bfe 100644 --- a/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_convert_phys_to_hdiv_kernel_mod.F90 @@ -37,12 +37,12 @@ module sci_convert_phys_to_hdiv_kernel_mod type, public, extends(kernel_type) :: convert_phys_to_hdiv_kernel_type private type(arg_type) :: meta_args(10) = (/ & - arg_type(GH_FIELD, GH_REAL, GH_WRITE, W2), & - arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & - arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & - arg_type(GH_FIELD, GH_REAL, GH_READ, W2), & - 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, GH_REAL, GH_WRITE, W2), &! u_hdiv + arg_type(GH_FIELD, GH_REAL, GH_READ, W2), &! u_lon + arg_type(GH_FIELD, GH_REAL, GH_READ, W2), &! u_lat + arg_type(GH_FIELD, GH_REAL, GH_READ, W2), &! u_up + arg_type(GH_FIELD*3, GH_REAL, GH_READ, ANY_SPACE_9), &! chi_1, chi_2, chi_3 + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), &! panel_id arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system diff --git a/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 index ad8221c4f..36ad67b83 100644 --- a/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_project_ws_to_w1_operator_kernel_mod.F90 @@ -38,10 +38,10 @@ module sci_project_ws_to_w1_operator_kernel_mod type, public, extends(kernel_type) :: project_ws_to_w1_operator_kernel_type private type(arg_type) :: meta_args(8) = (/ & - arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W1, ANY_DISCONTINUOUS_SPACE_1), & - arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & - arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), & + arg_type(GH_OPERATOR, GH_REAL, GH_WRITE, W1, ANY_DISCONTINUOUS_SPACE_1), &! projection_operator + arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), &! chi_1, chi_2, chi_3 + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), &! panel_id + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! direction arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system diff --git a/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 b/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 index 6bb82c7e2..7d6390122 100644 --- a/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 +++ b/components/science/source/kernel/inter_function_space/sci_w3_to_w2_displacement_kernel_mod.F90 @@ -34,18 +34,18 @@ module sci_w3_to_w2_displacement_kernel_mod !> The type declaration for the kernel. Contains the metadata needed by the PSy layer type, public, extends(kernel_type) :: w3_to_w2_displacement_kernel_type private - type(arg_type) :: meta_args(8) = (/ & - arg_type(GH_FIELD, GH_REAL, GH_INC, W2H), & - arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), & - arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), & - arg_type(GH_FIELD, GH_REAL, GH_READ, W3), & - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology - arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system - arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius + type(arg_type) :: meta_args(8) = (/ & + arg_type(GH_FIELD, GH_REAL, GH_INC, W2H), &! displacement + arg_type(GH_FIELD*3, GH_REAL, GH_READ, Wchi), &! chi_1, chi_2, chi_3 + arg_type(GH_FIELD, GH_REAL, GH_READ, ANY_DISCONTINUOUS_SPACE_3), &! panel_id + arg_type(GH_FIELD, GH_REAL, GH_READ, W3), &! dummy_w3 + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! geometry + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! topology + arg_type(GH_SCALAR, GH_INTEGER, GH_READ), &! coord_system + arg_type(GH_SCALAR, GH_REAL, GH_READ) &! scaled_radius /) - type(func_type) :: meta_funcs(1) = (/ & - func_type(Wchi, GH_BASIS) & + type(func_type) :: meta_funcs(1) = (/ & + func_type(Wchi, GH_BASIS) & /) integer :: operates_on = CELL_COLUMN integer :: gh_shape = GH_EVALUATOR diff --git a/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf b/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf index aa7b748f6..257ae2285 100644 --- a/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/fem/gp_vector_rhs_kernel_mod_test.pf @@ -38,13 +38,13 @@ contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine setUp( this ) - use base_mesh_config_mod, only: geometry_planar, & - topology_fully_periodic - use sci_chi_transform_mod, only: init_chi_transforms - use finite_element_config_mod, only: cellshape_quadrilateral, & - coord_system_xyz - use feign_config_mod, only: feign_finite_element_config, & - feign_base_mesh_config + use base_mesh_config_mod, only : geometry_planar, & + topology_fully_periodic + use sci_chi_transform_mod, only : init_chi_transforms + use finite_element_config_mod, only : cellshape_quadrilateral, & + coord_system_xyz + use feign_config_mod, only : feign_finite_element_config, & + feign_base_mesh_config implicit none @@ -88,7 +88,7 @@ contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine tearDown( this ) - use config_loader_mod, only: final_configuration + use config_loader_mod, only: final_configuration use sci_chi_transform_mod, only: final_chi_transforms implicit none diff --git a/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf b/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf index 83d5aa391..6ce2dcf94 100644 --- a/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/chi_transform_mod_test.pf @@ -262,21 +262,18 @@ contains if ( this%source_coord_system == LLH_rot ) then north_pole(1) = PI/2.0_r_def north_pole(2) = 0.0_r_def - call init_chi_transforms(this%geometry, & - this%topology, & + call init_chi_transforms(this%geometry, this%topology, & north_pole_arg=north_pole) else if ( this%source_coord_system == ABH_stretch_rot ) then north_pole(1) = -PI/2.0_r_def north_pole(2) = 0.0_r_def equatorial_latitude = PI/6.0_r_def - call init_chi_transforms(this%geometry, & - this%topology, & + call init_chi_transforms(this%geometry, this%topology, & north_pole_arg=north_pole, & equator_lat_arg=equatorial_latitude) else ! Non-rotated or stretched case - call init_chi_transforms(this%geometry, & - this%topology) + call init_chi_transforms(this%geometry, this%topology) end if @@ -286,7 +283,7 @@ contains subroutine tearDown( this ) use sci_chi_transform_mod, only: final_chi_transforms - use config_loader_mod, only: final_configuration + use config_loader_mod, only: final_configuration implicit none diff --git a/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf b/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf index 0610fed4e..4b7899cbf 100644 --- a/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf +++ b/components/science/unit-test/kernel/geometry/compute_latlon_kernel_mod_test.pf @@ -107,10 +107,8 @@ contains latitude, longitude, & chi_1, chi_2, chi_3, & panel_id, & - geometry, & - topology, & - coord_system, & - scaled_radius, & + geometry, topology, & + coord_system, scaled_radius, & ndf_w3, undf_w3, map_w3(:,1), & ndf_chi, undf_chi, map_chi(:,1), & basis_chi(:,:,1,:), & From 515f8920c861d010806ae277c989065acbdc3972 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 22 Apr 2026 10:02:37 +0100 Subject: [PATCH 25/44] Remove this accidental commit --- .../sci_geometric_constants_mod.x90.orig | 1531 ----------------- 1 file changed, 1531 deletions(-) delete mode 100644 components/science/source/algorithm/sci_geometric_constants_mod.x90.orig diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90.orig b/components/science/source/algorithm/sci_geometric_constants_mod.x90.orig deleted file mode 100644 index e33f44e9a..000000000 --- a/components/science/source/algorithm/sci_geometric_constants_mod.x90.orig +++ /dev/null @@ -1,1531 +0,0 @@ -!----------------------------------------------------------------------------- -! (C) Crown copyright 2021 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 Pre-computes and stores various geometric objects. -!> -!> @details This module controls the set up of various objects relating to -!> the geometry of the mesh that do not change during a run. These -!> objects are accessed from this module through appropriate 'get' -!> functions. -!------------------------------------------------------------------------------- - -module sci_geometric_constants_mod - - ! Infrastructure - use constants_mod, only: i_def, r_def, l_def, str_def - use extrusion_mod, only: TWOD, PRIME_EXTRUSION - use field_mod, only: field_type - use fs_continuity_mod, only: W0, W1, W2, W2H, W3, Wtheta - use function_space_collection_mod, only: function_space_collection - use function_space_mod, only: function_space_type - use integer_field_mod, only: integer_field_type - use inventory_by_mesh_mod, only: inventory_by_mesh_type - use inventory_by_local_mesh_mod, only: inventory_by_local_mesh_type - use local_mesh_mod, only: local_mesh_type - use log_mod, only: log_event, LOG_LEVEL_ERROR - use mesh_collection_mod, only: mesh_collection - use mesh_mod, only: mesh_type - use timing_mod, only: start_timing, stop_timing, & - tik, LPROF - - ! Configuration - use finite_element_config_mod, only: element_order_h, & - element_order_v - - implicit none - - private - - ! Variables private to this module that can only be accessed by public - ! functions returning pointers to them - - ! ========================================================================== ! - ! Inventories for use in the rest of the model - ! ========================================================================== ! - ! Finite element representations of coordinates - type(inventory_by_mesh_type), target :: chi_inventory - type(inventory_by_mesh_type), target :: panel_id_inventory - type(inventory_by_mesh_type) :: extended_chi_inventory - - ! Basic geometric entities - type(inventory_by_mesh_type) :: dA_at_w2_inventory - type(inventory_by_mesh_type) :: dz_w3_inventory - type(inventory_by_mesh_type) :: detj_at_w3_inventory_fe - type(inventory_by_mesh_type) :: detj_at_w3_inventory_fv - type(inventory_by_mesh_type) :: detj_at_w2_inventory_fe - type(inventory_by_mesh_type) :: detj_at_w2_inventory_fv - type(inventory_by_mesh_type) :: delta_at_wtheta_inventory - type(inventory_by_mesh_type) :: dx_at_w2_inventory - type(inventory_by_mesh_type) :: dz_at_wtheta_inventory - type(inventory_by_local_mesh_type) :: dA_msl_proj_inventory - - ! 2D Longitude/latitude fields - type(inventory_by_local_mesh_type), target :: lat_w3_inventory_fe - type(inventory_by_local_mesh_type), target :: lat_w3_inventory_fv - type(inventory_by_local_mesh_type), target :: lat_w2_inventory_fe - type(inventory_by_local_mesh_type), target :: lat_w2_inventory_fv - type(inventory_by_local_mesh_type), target :: lat_w2h_inventory_fe - type(inventory_by_local_mesh_type), target :: lat_w2h_inventory_fv - type(inventory_by_local_mesh_type), target :: long_w3_inventory_fe - type(inventory_by_local_mesh_type), target :: long_w3_inventory_fv - type(inventory_by_local_mesh_type), target :: long_w2_inventory_fe - type(inventory_by_local_mesh_type), target :: long_w2_inventory_fv - type(inventory_by_local_mesh_type), target :: long_w2h_inventory_fe - type(inventory_by_local_mesh_type), target :: long_w2h_inventory_fv - - ! Heights of DoFs - type(inventory_by_mesh_type), target :: height_w0_inventory_fe - type(inventory_by_mesh_type), target :: height_w0_inventory_fv - type(inventory_by_mesh_type), target :: height_w1_inventory_fe - type(inventory_by_mesh_type), target :: height_w1_inventory_fv - type(inventory_by_mesh_type), target :: height_w2_inventory_fe - type(inventory_by_mesh_type), target :: height_w2_inventory_fv - type(inventory_by_mesh_type), target :: height_w2h_inventory_fe - type(inventory_by_mesh_type), target :: height_w2h_inventory_fv - type(inventory_by_mesh_type), target :: height_w3_inventory_fe - type(inventory_by_mesh_type), target :: height_w3_inventory_fv - type(inventory_by_mesh_type), target :: height_wth_inventory_fe - type(inventory_by_mesh_type), target :: height_wth_inventory_fv - - ! Face selectors, used to avoid doubly-iterating over horizontal faces - type(inventory_by_local_mesh_type) :: face_selector_ew_inventory - type(inventory_by_local_mesh_type) :: face_selector_ns_inventory - - ! ========================================================================== ! - ! Public functions for accessing the module contents - ! ========================================================================== ! - - public :: final_geometric_constants - public :: get_panel_id - public :: get_coordinates - public :: get_extended_coordinates - public :: get_dA_at_w2 - public :: get_detj_at_w3_fe - public :: get_detj_at_w3_fv - public :: get_detj_at_w2_fe - public :: get_detj_at_w2_fv - public :: get_dz_w3 - public :: get_delta_at_wtheta - public :: get_dx_at_w2 - public :: get_dz_at_wtheta - public :: get_dA_msl_proj - public :: get_height_fe - public :: get_height_fv - public :: get_latitude_fe - public :: get_latitude_fv - public :: get_longitude_fe - public :: get_longitude_fv - public :: get_face_selector_ew - public :: get_face_selector_ns - public :: get_chi_inventory - public :: get_panel_id_inventory - - ! Private routines for creating constants - private :: compute_latlon - private :: compute_face_selectors - -contains - - ! ========================================================================== ! - ! Private routines for creating some particular constants - ! ========================================================================== ! - - !> @brief Private routine for computing longitude and latitude fields - !> @param[in,out] long_inventory Inventory containing longitude fields - !> @param[in,out] lat_inventory Inventory containing latitude fields - !> @param[in] mesh Mesh used to determine local mesh for - !! computing the fields for - !> @param[in] fs_id Identifier for function space to compute - !! longitude and latitude fields for - !> @param[in] use_fe Flag to indicate whether to use finite - !! element or finite volume cells - subroutine compute_latlon(long_inventory, lat_inventory, mesh, fs_id, use_fe) - - use base_mesh_config_mod, only: f_lat, geometry, & - geometry_spherical - use idealised_config_mod, only: f_lon - use sci_compute_latlon_kernel_mod, only: compute_latlon_kernel_type - - implicit none - - type(inventory_by_local_mesh_type), intent(inout) :: long_inventory - type(inventory_by_local_mesh_type), intent(inout) :: lat_inventory - type(mesh_type), intent(in) :: mesh - integer(kind=i_def), intent(in) :: fs_id - logical(kind=l_def), intent(in) :: use_fe - - ! Internal variables - type(mesh_type), pointer :: twod_mesh - type(local_mesh_type), pointer :: local_mesh - type(field_type), pointer :: lat - type(field_type), pointer :: long - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(function_space_type), pointer :: twod_fs - integer(kind=i_def) :: k_h, k_v - integer(tik) :: id - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - if (use_fe) then - k_h = element_order_h - k_v = element_order_v - else - k_h = 0 - k_v = 0 - end if - - twod_mesh => mesh_collection%get_mesh(mesh, TWOD) - local_mesh => mesh%get_local_mesh() - twod_fs => function_space_collection%get_fs(twod_mesh, k_h, k_v, fs_id) - call lat_inventory%add_field(lat, twod_fs, local_mesh) - call long_inventory%add_field(long, twod_fs, local_mesh) - - if ( geometry == geometry_spherical ) then - chi => get_coordinates(mesh%get_id()) - panel_id => get_panel_id(mesh%get_id()) - call invoke( compute_latlon_kernel_type(lat, long, chi, panel_id) ) - else - call invoke( setval_c(lat, f_lat), & - setval_c(long, f_lon) ) - end if - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - - end subroutine compute_latlon - - !> @brief Private routine for computing face selectors fields - !> @param[in,out] ew_inventory Inventory containing East-West selectors - !> @param[in,out] ns_inventory Inventory containing North-South selectors - !> @param[in] mesh Mesh used to determine local mesh for - !! computing the fields for - subroutine compute_face_selectors(mesh) - - use reference_element_mod, only: S, W - use sci_set_any_int_dof_kernel_mod, only: set_any_int_dof_kernel_type - use sci_face_selector_kernel_mod, only: face_selector_kernel_type - - implicit none - - type(mesh_type), intent(in) :: mesh - - ! Internal variables - type(mesh_type), pointer :: twod_mesh - type(local_mesh_type), pointer :: local_mesh - type(integer_field_type), pointer :: face_selector_ew - type(integer_field_type), pointer :: face_selector_ns - type(integer_field_type) :: face_counter - type(function_space_type), pointer :: w2h_2d_fs - type(function_space_type), pointer :: w3_2d_fs - integer(tik) :: id - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - twod_mesh => mesh_collection%get_mesh(mesh, TWOD) - local_mesh => mesh%get_local_mesh() - w2h_2d_fs => function_space_collection%get_fs(twod_mesh, 0, 0, W2H) - w3_2d_fs => function_space_collection%get_fs(twod_mesh, 0, 0, W3) - - ! Temporary W2H field, tracking the count for each face - call face_counter%initialise( w2h_2d_fs ) - - call face_selector_ew_inventory%add_field( & - face_selector_ew, w3_2d_fs, local_mesh & - ) - call face_selector_ns_inventory%add_field( & - face_selector_ns, w3_2d_fs, local_mesh & - ) - - call invoke( int_setval_c(face_counter, 0), & - ! Do West and South faces for every cell - int_setval_c(face_selector_ew, 1), & - int_setval_c(face_selector_ns, 1), & - set_any_int_dof_kernel_type(face_counter, W, 1), & - set_any_int_dof_kernel_type(face_counter, S, 1), & - ! Determine where North and East faces are needed - face_selector_kernel_type(face_selector_ew, & - face_selector_ns, & - face_counter ) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - - end subroutine compute_face_selectors - - ! ========================================================================== ! - ! GETTERS FOR FINITE ELEMENT COORDINATE FIELDS - ! ========================================================================== ! - !> @brief Function to return a pointer to the panel_id - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The coordinate field array - function get_panel_id(mesh_id) result(panel_id_ptr) - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(mesh_type), pointer :: prime_extrusion_mesh - type(field_type), pointer :: panel_id_ptr - - mesh => mesh_collection%get_mesh(mesh_id) - if (mesh%get_extrusion_id() == TWOD) then - prime_extrusion_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) - call panel_id_inventory%get_field(prime_extrusion_mesh, panel_id_ptr) - else - call panel_id_inventory%get_field(mesh, panel_id_ptr) - end if - - end function get_panel_id - - !> @brief Returns a pointer to the coordinate field array - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The coordinate field array - function get_coordinates(mesh_id) result(coords_ptr) - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(mesh_type), pointer :: prime_extrusion_mesh - type(field_type), pointer :: coords_ptr(:) - - mesh => mesh_collection%get_mesh(mesh_id) - if (mesh%get_extrusion_id() == TWOD) then - prime_extrusion_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) - call chi_inventory%get_field_array(prime_extrusion_mesh, coords_ptr) - else - call chi_inventory%get_field_array(mesh, coords_ptr) - end if - - end function get_coordinates - - !> @brief Returns a pointer to the extended coordinate field array - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The coordinate field array - function get_extended_coordinates(mesh_id) result(extended_chi) - - use finite_element_config_mod, only: coord_system, coord_system_native - use sci_extend_chi_field_kernel_mod, only: extend_chi_field_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(field_type), pointer :: extended_chi(:) - logical(kind=l_def) :: constant_exists - integer(kind=i_def) :: depth - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(function_space_type), pointer :: wchi_fs - integer(tik) :: id - - ! Initialise inventory if this is the first time getting this constant - if (.not. extended_chi_inventory%is_initialised()) then - call extended_chi_inventory%initialise(name="extended_chi") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = extended_chi_inventory%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - ! If this constant doesn't exist, create it - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - wchi_fs => chi(1)%get_function_space() - depth = mesh%get_halo_depth() - call extended_chi_inventory%add_field_array( & - extended_chi, wchi_fs, 3, mesh, halo_depth=depth & - ) - - if (coord_system /= coord_system_native) then - call log_event( & - "Extended coordinates only implemented for native " // & - "coord_system option", LOG_LEVEL_ERROR & - ) - end if - - call invoke( extend_chi_field_kernel_type(extended_chi, chi, & - panel_id, depth) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - else - ! Otherwise, return existing constant - call extended_chi_inventory%get_field_array(mesh, extended_chi) - end if - - end function get_extended_coordinates - - ! ========================================================================== ! - ! GETTERS FOR BASIC GEOMETRIC ENTITIES - ! ========================================================================== ! - !> @brief Returns the areas of cell faces at W2 DoF locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The dA field - function get_dA_at_w2(mesh_id) result(dA_at_w2) - - use sci_calc_da_at_w2_kernel_mod, only: calc_dA_at_w2_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(field_type), pointer :: dA_at_w2 - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(function_space_type), pointer :: w2_k0_fs - integer(tik) :: id - - ! Initialise inventory if this is the first time getting this constant - if (.not. dA_at_w2_inventory%is_initialised()) then - call dA_at_w2_inventory%initialise(name="dA_at_w2") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = dA_at_w2_inventory%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - ! If this constant doesn't exist, create it - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w2_k0_fs => function_space_collection%get_fs(mesh, 0, 0, W2) - call dA_at_w2_inventory%add_field(dA_at_w2, w2_k0_fs, mesh) - - call invoke( setval_c(dA_at_w2, 0.0_r_def), & - calc_dA_at_w2_kernel_type(dA_at_w2, chi, panel_id) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - else - ! Otherwise, return existing constant - call dA_at_w2_inventory%get_field(mesh, dA_at_w2) - end if - - end function get_dA_at_w2 - - !> @brief Returns the (finite element) Det(J) values at W3 dof locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The Det(J) field - function get_detj_at_w3_fe(mesh_id) result(detj_at_w3) - - ! @TODO #4487: update these imports - ! use sci_calc_detj_at_w3_kernel_mod, only: calc_detj_at_w3_kernel_type - use sci_compute_mass_matrix_kernel_w_scalar_mod, & - only: compute_mass_matrix_kernel_w_scalar_type - use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type - use finite_element_config_mod, only: nqp_h_exact, & - nqp_v_exact - use operator_mod, only: operator_type - use quadrature_xyoz_mod, only: quadrature_xyoz_type - use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: detj_at_w3 - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(function_space_type), pointer :: w3_fs - ! @TODO #4487: arguments for calculating detj in old way - type(operator_type) :: mm_w3 - type(quadrature_xyoz_type) :: qr - logical(kind=l_def) :: extended_mesh - type(quadrature_rule_gaussian_type) :: quadrature_rule - integer(tik) :: id - - ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - detj_at_w3 => get_detj_at_w3_fv(mesh_id) - return - end if - - ! Check inventory is initialised - if (.not. detj_at_w3_inventory_fe%is_initialised()) then - ! Initialise all inventories together - call detj_at_w3_inventory_fe%initialise(name='detj_at_w3_fe') - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = detj_at_w3_inventory_fe%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - ! Create the object as it doesn't exist yet - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w3_fs => function_space_collection%get_fs(mesh, element_order_h, & - element_order_v, W3) - call detj_at_w3_inventory_fe%add_field(detj_at_w3, w3_fs, mesh) - - ! @TODO #4487: it is inefficient to calculate this via mass matrices - ! The proper method is preserved in the comment here - ! call invoke( calc_detj_at_w3_kernel_type(detj_at_w3, chi, panel_id) ) - call mm_w3%initialise( w3_fs, w3_fs ) - qr = quadrature_xyoz_type(nqp_h_exact, nqp_h_exact, nqp_v_exact, & - quadrature_rule) - extended_mesh = .false. - call invoke( compute_mass_matrix_kernel_w_scalar_type(mm_w3, & - chi, & - panel_id, & - extended_mesh, & - qr), & - setval_c(detj_at_w3, 0.0_r_def), & - mm_diagonal_kernel_type(detj_at_w3, mm_w3) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Get existing constant - call detj_at_w3_inventory_fe%get_field(mesh, detj_at_w3) - - end function get_detj_at_w3_fe - - !> @brief Returns the (finite volume) Det(J) values at W3 dof locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The Det(J) field - function get_detj_at_w3_fv(mesh_id) result(detj_at_w3) - - ! @TODO #4487: update these imports - ! use sci_calc_detj_at_w3_kernel_mod, & - ! only: calc_detj_at_w3_kernel_type - use sci_compute_mass_matrix_kernel_w_scalar_mod, & - only: compute_mass_matrix_kernel_w_scalar_type - use sci_mm_diagonal_kernel_mod, only: mm_diagonal_kernel_type - use operator_mod, only: operator_type - use quadrature_xyoz_mod, only: quadrature_xyoz_type - use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: detj_at_w3 - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(function_space_type), pointer :: w3_fs - ! @TODO #4487: arguments for calculating detj in old way - type(operator_type) :: mm_w3 - type(quadrature_xyoz_type) :: qr - logical(kind=l_def) :: extended_mesh - type(quadrature_rule_gaussian_type) :: quadrature_rule - integer(tik) :: id - - ! Check inventory is initialised - if (.not. detj_at_w3_inventory_fv%is_initialised()) then - ! Initialise all inventories together - call detj_at_w3_inventory_fv%initialise(name='detj_at_w3_fv') - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = detj_at_w3_inventory_fv%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - ! Create the object as it doesn't exist yet - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w3_fs => function_space_collection%get_fs(mesh, 0, 0, W3) - call detj_at_w3_inventory_fv%add_field(detj_at_w3, w3_fs, mesh) - - ! @TODO #4487: it is inefficient to calculate this via mass matrices - ! The proper method is preserved in the comment here - ! call invoke( calc_detj_at_w3_kernel_type(detj_at_w3, chi, panel_id) ) - call mm_w3%initialise( w3_fs, w3_fs ) - qr = quadrature_xyoz_type(3, quadrature_rule) - extended_mesh = .false. - call invoke( compute_mass_matrix_kernel_w_scalar_type(mm_w3, & - chi, & - panel_id, & - extended_mesh, & - qr), & - setval_c(detj_at_w3, 0.0_r_def), & - mm_diagonal_kernel_type(detj_at_w3, mm_w3) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Get existing constant - call detj_at_w3_inventory_fv%get_field(mesh, detj_at_w3) - - end function get_detj_at_w3_fv - - !> @brief Returns the (finite element) Det(J) values at W2 dof locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The Det(J) field - function get_detj_at_w2_fe(mesh_id) result(detj_at_w2) - - use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type - use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: detj_at_w2 - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(field_type) :: multiplicity_w2 - type(function_space_type), pointer :: w2_fs - integer(tik) :: id - - ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - detj_at_w2 => get_detj_at_w2_fv(mesh_id) - return - end if - - ! Check inventory is initialised - if (.not. detj_at_w2_inventory_fe%is_initialised()) then - ! Initialise all inventories together - call detj_at_w2_inventory_fe%initialise(name='detj_at_w2_fe') - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = detj_at_w2_inventory_fe%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - ! Create the object as it doesn't exist yet - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w2_fs => function_space_collection%get_fs(mesh, element_order_h, & - element_order_v, W2) - call multiplicity_w2%initialise( w2_fs ) - call detj_at_w2_inventory_fe%add_field(detj_at_w2, w2_fs, mesh) - - ! @TODO #4487: a small optimisation here is to multiply by rmultiplicity, - ! rather than computing and dividing by mulitplicity - call invoke( setval_c(detj_at_w2, 0.0_r_def), & - calc_detj_at_w2_kernel_type(detj_at_w2, chi, panel_id), & - setval_c(multiplicity_w2, 0.0_r_def), & - multiplicity_kernel_type(multiplicity_w2), & - inc_X_divideby_Y(detj_at_w2, multiplicity_w2) ) - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Get existing constant - call detj_at_w2_inventory_fe%get_field(mesh, detj_at_w2) - - end function get_detj_at_w2_fe - - !> @brief Returns the (finite volume) Det(J) values at W2 dof locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The Det(J) field - function get_detj_at_w2_fv(mesh_id) result(detj_at_w2) - - use sci_calc_detj_at_w2_kernel_mod, only: calc_detj_at_w2_kernel_type - use sci_multiplicity_kernel_mod, only: multiplicity_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: detj_at_w2 - type(field_type), pointer :: chi(:) - type(field_type), pointer :: panel_id - type(field_type) :: multiplicity_w2 - type(function_space_type), pointer :: w2_fs - integer(tik) :: id - - ! Check inventory is initialised - if (.not. detj_at_w2_inventory_fv%is_initialised()) then - ! Initialise all inventories together - call detj_at_w2_inventory_fv%initialise(name='detj_at_w2_fv') - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = detj_at_w2_inventory_fv%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - chi => get_coordinates(mesh_id) - panel_id => get_panel_id(mesh_id) - - ! Create the object as it doesn't exist yet - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w2_fs => function_space_collection%get_fs(mesh, 0, 0, W2) - call multiplicity_w2%initialise( w2_fs ) - call detj_at_w2_inventory_fv%add_field(detj_at_w2, w2_fs, mesh) - - ! @TODO #4487: a small optimisation here is to multiply by rmultiplicity, - ! rather than computing and dividing by mulitplicity - call invoke( setval_c(detj_at_w2, 0.0_r_def), & - calc_detj_at_w2_kernel_type(detj_at_w2, chi, panel_id), & - setval_c(multiplicity_w2, 0.0_r_def), & - multiplicity_kernel_type(multiplicity_w2), & - inc_X_divideby_Y(detj_at_w2, multiplicity_w2) ) - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Get existing constant - call detj_at_w2_inventory_fv%get_field(mesh, detj_at_w2) - - end function get_detj_at_w2_fv - - !> @brief Returns a pointer to the vertical grid spacing, located at W3 DoFs - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The physical height difference of layers, at W3 - function get_dz_w3(mesh_id) result(dz_w3) - - use sci_get_dz_w3_kernel_mod, only: get_dz_w3_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(field_type), pointer :: dz_w3 - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: height_w2 - type(function_space_type), pointer :: w3_fs - integer(tik) :: id - - ! Initialise inventory if this is the first time getting this constant - if (.not. dz_w3_inventory%is_initialised()) then - call dz_w3_inventory%initialise(name="dz_w3") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = dz_w3_inventory%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - ! If this constant doesn't exist, create it - ! Get height first to avoid potentially timing twice - height_w2 => get_height_fv(W2, mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - w3_fs => function_space_collection%get_fs(mesh, 0, 0, W3) - call dz_w3_inventory%add_field(dz_w3, w3_fs, mesh) - - call invoke( get_dz_w3_kernel_type(dz_w3, height_w2) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - else - ! Otherwise, return existing constant - call dz_w3_inventory%get_field(mesh, dz_w3) - end if - - end function get_dz_w3 - - !> @brief Returns the delta_at_wtheta values at Wtheta DoF locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The delta_at_wtheta field - function get_delta_at_wtheta(mesh_id) result(delta_at_wtheta) - - use sci_calc_delta_at_wtheta_kernel_mod, & - only: calc_delta_at_wtheta_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: dx_at_w2 - type(field_type), pointer :: delta_at_wtheta - type(function_space_type), pointer :: wt_k0_fs - integer(tik) :: id - - ! Initialise inventory if it hasn't been done so already - if (.not. delta_at_wtheta_inventory%is_initialised()) then - call delta_at_wtheta_inventory%initialise(name="delta_at_wtheta") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = delta_at_wtheta_inventory%paired_object_exists(mesh_id) - - ! Create constant if it doesn't already exist - if (.not. constant_exists) then - wt_k0_fs => function_space_collection%get_fs(mesh, 0, 0, Wtheta) - dx_at_w2 => get_dx_at_w2(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - call delta_at_wtheta_inventory%add_field(delta_at_wtheta, wt_k0_fs, mesh) - - call invoke( calc_delta_at_wtheta_kernel_type(delta_at_wtheta, dx_at_w2) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Return constant - call delta_at_wtheta_inventory%get_field(mesh, delta_at_wtheta) - - end function get_delta_at_wtheta - - !> @brief Returns the dx_at_w2 values at W2 DoF locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The dx_at_w2 field - function get_dx_at_w2(mesh_id) result(dx_at_w2) - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: dx_at_w2 - type(field_type), pointer :: detj_at_w2 - type(field_type), pointer :: dA_at_w2 - type(function_space_type), pointer :: w2_fs - integer(tik) :: id - - ! Initialise inventory if it hasn't been done so already - if (.not. dx_at_w2_inventory%is_initialised()) then - call dx_at_w2_inventory%initialise(name="dx_at_w2") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = dx_at_w2_inventory%paired_object_exists(mesh_id) - - ! Create constant if it doesn't already exist - if (.not. constant_exists) then - w2_fs => function_space_collection%get_fs(mesh, 0, 0, W2) - detj_at_w2 => get_detj_at_w2_fv(mesh_id) - dA_at_w2 => get_dA_at_w2(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - call dx_at_w2_inventory%add_field(dx_at_w2, w2_fs, mesh) - call invoke( X_divideby_Y(dx_at_w2, detj_at_w2, dA_at_w2) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Return constant - call dx_at_w2_inventory%get_field(mesh, dx_at_w2) - - end function get_dx_at_w2 - - - !> @brief Returns the 1/dz values at lowest-order Wtheta DoF locations - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The dz_at_wtheta field - function get_dz_at_wtheta(mesh_id) result(dz_at_wtheta) - - use sci_calc_dz_face_kernel_mod, only: calc_dz_face_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(field_type), pointer :: dz_at_wtheta - type(function_space_type), pointer :: wtheta_k0_fs - type(field_type), pointer :: height_w3 - type(field_type), pointer :: height_wth - logical(kind=l_def) :: constant_exists - integer(tik) :: id - - ! Parameters of the cells - integer(i_def), parameter :: n_centres = 1_i_def - logical(l_def), parameter :: ign_surf = .false. - - ! Initialise inventory if it hasn't been done so already - if (.not. dz_at_wtheta_inventory%is_initialised()) then - call dz_at_wtheta_inventory%initialise(name="dz_at_wtheta") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = dz_at_wtheta_inventory%paired_object_exists(mesh_id) - - ! Create constant if it doesn't already exist - if (.not. constant_exists) then - ! NB: this assumes heights are in the lowest-order space - height_w3 => get_height_fv(W3, mesh_id) - height_wth => get_height_fv(Wtheta, mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - wtheta_k0_fs => function_space_collection%get_fs(mesh, 0, 0, Wtheta) - - call dz_at_wtheta_inventory%add_field(dz_at_wtheta, wtheta_k0_fs, mesh) - - call invoke( calc_dz_face_kernel_type(dz_at_wtheta, height_w3, & - height_wth, n_centres, ign_surf) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Return constant - call dz_at_wtheta_inventory%get_field(mesh, dz_at_wtheta) - - end function get_dz_at_wtheta - - !> @brief Returns the surface area of a cell projected to mean sea level - !> i.e. ignoring the orographic effect on the area - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The dA_msl_proj field - function get_dA_msl_proj(mesh_id) result(dA_msl_proj) - - use base_mesh_config_mod, only: geometry, geometry_spherical - use extrusion_config_mod, only: planet_radius, domain_height - use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - integer(kind=i_def) :: local_mesh_id - type(mesh_type), pointer :: mesh - type(mesh_type), pointer :: prime_mesh - type(mesh_type), pointer :: twod_mesh - type(local_mesh_type), pointer :: local_mesh - logical(kind=l_def) :: constant_exists - type(field_type), pointer :: dA_msl_proj - type(field_type), pointer :: dA_at_w2 - type(function_space_type), pointer :: fs - integer(tik) :: id - - ! Initialise inventory if it hasn't been done so already - if (.not. dA_msl_proj_inventory%is_initialised()) then - call dA_msl_proj_inventory%initialise(name="dA_msl_proj") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - local_mesh_id = local_mesh%get_id() - constant_exists = dA_msl_proj_inventory%paired_object_exists(local_mesh_id) - - ! Create constant if it doesn't already exist - if (.not. constant_exists) then - prime_mesh => mesh_collection%get_mesh(mesh, PRIME_EXTRUSION) - twod_mesh => mesh_collection%get_mesh(mesh, TWOD) - fs => function_space_collection%get_fs(twod_mesh, 0, 0, W3) - dA_at_w2 => get_dA_at_w2(prime_mesh%get_id()) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - call dA_msl_proj_inventory%add_field(dA_msl_proj, fs, local_mesh) - call invoke( calc_da_msl_proj_kernel_type(dA_at_w2, dA_msl_proj, & - planet_radius, domain_height, & - geometry, geometry_spherical) ) - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - end if - - ! Return constant - call dA_msl_proj_inventory%get_field(local_mesh, dA_msl_proj) - - end function get_dA_msl_proj - - ! ========================================================================== ! - ! PHYSICAL COORDINATES OF DOFs - ! ========================================================================== ! - - !> @brief Returns a pointer to the longitude of finite element DoFs - !> @param[in] space_id The space for which to get the longitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The longitude field - function get_longitude_fe(space_id, mesh_id) result(long_ptr) - - implicit none - - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(local_mesh_type), pointer :: local_mesh - type(inventory_by_local_mesh_type), pointer :: long_inventory - type(inventory_by_local_mesh_type), pointer :: lat_inventory - type(field_type), pointer :: long_ptr - logical(kind=l_def) :: constant_exists - character(len=str_def) :: inventory_name - - ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - long_ptr => get_longitude_fv(space_id, mesh_id) - return - end if - - ! NB: Longitude and latitude fields are computed simultaneously - ! Determine inventory based on space - select case (space_id) - case (W2) - long_inventory => long_w2_inventory_fe - lat_inventory => lat_w2_inventory_fe - inventory_name = "_w2_fe" - case (W2H) - long_inventory => long_w2h_inventory_fe - lat_inventory => lat_w2h_inventory_fe - inventory_name = "_w2h_fe" - case (W3) - long_inventory => long_w3_inventory_fe - lat_inventory => lat_w3_inventory_fe - inventory_name = "_w3_fe" - case default - long_ptr => null() - call log_event("Longitude not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. long_inventory%is_initialised()) then - call long_inventory%initialise(name='longitude_'//trim(inventory_name)) - call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) - end if - - ! Create constant - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.true.) - end if - - call long_inventory%get_field(local_mesh, long_ptr) - - end function get_longitude_fe - - !> @brief Returns a pointer to the longitude of finite volume DoFs - !> @param[in] space_id The space for which to get the longitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The longitude field - function get_longitude_fv(space_id, mesh_id) result(long_ptr) - - implicit none - - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(local_mesh_type), pointer :: local_mesh - type(inventory_by_local_mesh_type), pointer :: long_inventory - type(inventory_by_local_mesh_type), pointer :: lat_inventory - type(field_type), pointer :: long_ptr - logical(kind=l_def) :: constant_exists - character(len=str_def) :: inventory_name - - ! NB: Longitude and latitude fields are computed simultaneously - ! Determine inventory based on space - select case (space_id) - case (W2) - long_inventory => long_w2_inventory_fv - lat_inventory => lat_w2_inventory_fv - inventory_name = "_w2_fv" - case (W2H) - long_inventory => long_w2h_inventory_fv - lat_inventory => lat_w2h_inventory_fv - inventory_name = "_w2h_fv" - case (W3) - long_inventory => long_w3_inventory_fv - lat_inventory => lat_w3_inventory_fv - inventory_name = "_w3_fv" - case default - long_ptr => null() - call log_event("Longitude not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. long_inventory%is_initialised()) then - call long_inventory%initialise(name='longitude_'//trim(inventory_name)) - call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) - end if - - ! Create constant - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = long_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.false.) - end if - - call long_inventory%get_field(local_mesh, long_ptr) - - end function get_longitude_fv - - !> @brief Returns a pointer to the latitude of finite element DoFs - !> @param[in] space_id The space for which to get the latitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The latitude field - function get_latitude_fe(space_id, mesh_id) result(lat_ptr) - - implicit none - - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(local_mesh_type), pointer :: local_mesh - type(inventory_by_local_mesh_type), pointer :: long_inventory - type(inventory_by_local_mesh_type), pointer :: lat_inventory - type(field_type), pointer :: lat_ptr - logical(kind=l_def) :: constant_exists - character(len=str_def) :: inventory_name - - ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - lat_ptr => get_latitude_fv(space_id, mesh_id) - return - end if - - ! NB: Longitude and latitude fields are computed simultaneously - ! Determine inventory based on space - select case (space_id) - case (W2) - long_inventory => long_w2_inventory_fe - lat_inventory => lat_w2_inventory_fe - inventory_name = "_w2_fe" - case (W2H) - long_inventory => long_w2h_inventory_fe - lat_inventory => lat_w2h_inventory_fe - inventory_name = "_w2h_fe" - case (W3) - long_inventory => long_w3_inventory_fe - lat_inventory => lat_w3_inventory_fe - inventory_name = "_w3_fe" - case default - lat_ptr => null() - call log_event("Latitude not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. lat_inventory%is_initialised()) then - call long_inventory%initialise(name='longitude_'//trim(inventory_name)) - call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) - end if - - ! Create constant - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.true.) - end if - - call lat_inventory%get_field(local_mesh, lat_ptr) - - end function get_latitude_fe - - !> @brief Returns a pointer to the latitude of finite volume DoFs - !> @param[in] space_id The space for which to get the latitude of DoFs for - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The latitude field - function get_latitude_fv(space_id, mesh_id) result(lat_ptr) - - implicit none - - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(local_mesh_type), pointer :: local_mesh - type(inventory_by_local_mesh_type), pointer :: long_inventory - type(inventory_by_local_mesh_type), pointer :: lat_inventory - type(field_type), pointer :: lat_ptr - logical(kind=l_def) :: constant_exists - character(len=str_def) :: inventory_name - - ! NB: Longitude and latitude fields are computed simultaneously - ! Determine inventory based on space - select case (space_id) - case (W2) - long_inventory => long_w2_inventory_fv - lat_inventory => lat_w2_inventory_fv - inventory_name = "_w2_fv" - case (W2H) - long_inventory => long_w2h_inventory_fv - lat_inventory => lat_w2h_inventory_fv - inventory_name = "_w2h_fv" - case (W3) - long_inventory => long_w3_inventory_fv - lat_inventory => lat_w3_inventory_fv - inventory_name = "_w3_fv" - case default - lat_ptr => null() - call log_event("Latitude not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. lat_inventory%is_initialised()) then - call long_inventory%initialise(name='longitude_'//trim(inventory_name)) - call lat_inventory%initialise(name='latitude_'//trim(inventory_name)) - end if - - ! Create constant - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = lat_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) then - call compute_latlon(long_inventory, lat_inventory, mesh, space_id, & - use_fe=.false.) - end if - - call lat_inventory%get_field(local_mesh, lat_ptr) - - end function get_latitude_fv - - !> @brief Returns a pointer to a finite element height field - !> @param[in] space The space of the desired height field - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return A height field - function get_height_fe(space_id, mesh_id) result(height) - - use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type - use sci_height_discontinuous_kernel_mod, & - only: height_discontinuous_kernel_type - use base_mesh_config_mod, only: geometry - use finite_element_config_mod, only: coord_system - use planet_config_mod, only: scaled_radius - - implicit none - - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(inventory_by_mesh_type), pointer :: inventory - logical(kind=l_def) :: constant_exists - type(function_space_type), pointer :: space - type(field_type), pointer :: chi(:) - type(field_type), pointer :: height - type(field_type) :: rmultiplicity - type(field_type) :: nodal_multiplicity - type(field_type) :: ones - character(len=str_def) :: inventory_name - integer(tik) :: id - - ! If running at lowest order, use finite volume - if (element_order_h == 0 .and. element_order_v == 0) then - height => get_height_fv(space_id, mesh_id) - return - end if - - ! Determine inventory based on space - select case (space_id) - case (W0) - inventory => height_w0_inventory_fe - inventory_name = "height_w0_fe" - case (W1) - inventory => height_w1_inventory_fe - inventory_name = "height_w1_fe" - case (W2) - inventory => height_w2_inventory_fe - inventory_name = "height_w2_fe" - case (W2H) - inventory => height_w2h_inventory_fe - inventory_name = "height_w2h_fe" - case (W3) - inventory => height_w3_inventory_fe - inventory_name = "height_w3_fe" - case (Wtheta) - inventory => height_wth_inventory_fe - inventory_name = "height_wtheta_fe" - case default - height => null() - call log_event("Height not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. inventory%is_initialised()) then - call inventory%initialise(name=inventory_name) - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = inventory%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - ! If this constant doesn't exist, create it - chi => get_coordinates(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - space => function_space_collection%get_fs( & - mesh, element_order_h, element_order_v, space_id & - ) - call inventory%add_field(height, space, mesh) - - select case (space_id) - ! Horizontally discontinuous spaces - case (W3, Wtheta) - call invoke( & - height_discontinuous_kernel_type( & - height, chi, geometry, coord_system, scaled_radius & - ) & - ) - - ! Horizontally continuous spaces - case default - ! Can't import multiplicity, so must calculate it - call ones%initialise( space ) - call nodal_multiplicity%initialise( space ) - call rmultiplicity%initialise( space ) - - call invoke( & - setval_c(ones, 1.0_r_def), & - setval_c(nodal_multiplicity, 0.0_r_def), & - multiplicity_kernel_type(nodal_multiplicity), & - X_divideby_Y(rmultiplicity, ones, nodal_multiplicity), & - setval_c(height, 0.0_r_def), & - height_continuous_kernel_type( & - height, chi, rmultiplicity, & - geometry, coord_system, scaled_radius & - ) & - ) - end select - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - else - call inventory%get_field(mesh, height) - end if - - end function get_height_fe - - !> @brief Returns a pointer to a finite volume height field - !> @param[in] space The space of the desired height field - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return A height field - function get_height_fv(space_id, mesh_id) result(height) - - use sci_height_continuous_kernel_mod, only: height_continuous_kernel_type - use sci_height_discontinuous_kernel_mod, & - only: height_discontinuous_kernel_type - use base_mesh_config_mod, only: geometry - use finite_element_config_mod, only: coord_system - use planet_config_mod, only: scaled_radius - - implicit none - - integer(kind=i_def), intent(in) :: space_id - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh - type(inventory_by_mesh_type), pointer :: inventory - logical(kind=l_def) :: constant_exists - type(function_space_type), pointer :: space - type(field_type), pointer :: chi(:) - type(field_type), pointer :: height - type(field_type) :: rmultiplicity - type(field_type) :: nodal_multiplicity - type(field_type) :: ones - character(len=str_def) :: inventory_name - integer(tik) :: id - - ! Determine inventory based on space - select case (space_id) - case (W0) - inventory => height_w0_inventory_fv - inventory_name = "height_w0_fv" - case (W1) - inventory => height_w1_inventory_fv - inventory_name = "height_w1_fv" - case (W2) - inventory => height_w2_inventory_fv - inventory_name = "height_w2_fv" - case (W2H) - inventory => height_w2h_inventory_fv - inventory_name = "height_w2h_fv" - case (W3) - inventory => height_w3_inventory_fv - inventory_name = "height_w3_fv" - case (Wtheta) - inventory => height_wth_inventory_fv - inventory_name = "height_wtheta_fv" - case default - height => null() - call log_event("Height not available on requested space", LOG_LEVEL_ERROR) - end select - - ! Initialise inventory if this is the first time getting this constant - if (.not. inventory%is_initialised()) then - call inventory%initialise(name=inventory_name) - end if - - mesh => mesh_collection%get_mesh(mesh_id) - constant_exists = inventory%paired_object_exists(mesh_id) - - if (.not. constant_exists) then - ! If this constant doesn't exist, create it - chi => get_coordinates(mesh_id) - - if ( LPROF ) call start_timing( id, 'runtime_constants.geometric' ) - - space => function_space_collection%get_fs(mesh, 0, 0, space_id) - call inventory%add_field(height, space, mesh) - - select case (space_id) - ! Horizontally discontinuous spaces - case (W3, Wtheta) - call invoke( & - height_discontinuous_kernel_type( & - height, chi, geometry, coord_system, scaled_radius & - ) & - ) - - ! Horizontally continuous spaces - case default - ! Can't import multiplicity, so must calculate it - call ones%initialise( space ) - call nodal_multiplicity%initialise( space ) - call rmultiplicity%initialise( space ) - - call invoke( & - setval_c(ones, 1.0_r_def), & - setval_c(nodal_multiplicity, 0.0_r_def), & - multiplicity_kernel_type(nodal_multiplicity), & - X_divideby_Y(rmultiplicity, ones, nodal_multiplicity), & - setval_c(height, 0.0_r_def), & - height_continuous_kernel_type( & - height, chi, rmultiplicity, & - geometry, coord_system, scaled_radius & - ) & - ) - end select - - if ( LPROF ) call stop_timing( id, 'runtime_constants.geometric' ) - else - call inventory%get_field(mesh, height) - end if - - end function get_height_fv - - ! ========================================================================== ! - ! FACE SELECTORS - ! ========================================================================== ! - - !> @brief Returns a pointer to the east-west face selector - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The east-west face selector - function get_face_selector_ew(mesh_id) result(selector) - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh => null() - type(local_mesh_type), pointer :: local_mesh => null() - type(integer_field_type), pointer :: selector - logical(kind=l_def) :: constant_exists - - ! Initialise inventory if this is the first time getting this constant - if (.not. face_selector_ew_inventory%is_initialised()) then - call face_selector_ew_inventory%initialise(name="face_selector_ew") - call face_selector_ns_inventory%initialise(name="face_selector_ns") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = & - face_selector_ew_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) call compute_face_selectors(mesh) - - call face_selector_ew_inventory%get_field(local_mesh, selector) - - end function get_face_selector_ew - - !> @brief Returns a pointer to the north-south face selector - !> @param[in] mesh_id The ID of the mesh to get the object for - !> @return The north-south face selector - function get_face_selector_ns(mesh_id) result(selector) - - implicit none - - integer(kind=i_def), intent(in) :: mesh_id - type(mesh_type), pointer :: mesh => null() - type(local_mesh_type), pointer :: local_mesh => null() - type(integer_field_type), pointer :: selector - logical(kind=l_def) :: constant_exists - - ! Initialise inventory if this is the first time getting this constant - if (.not. face_selector_ew_inventory%is_initialised()) then - call face_selector_ew_inventory%initialise(name="face_selector_ew") - call face_selector_ns_inventory%initialise(name="face_selector_ns") - end if - - mesh => mesh_collection%get_mesh(mesh_id) - local_mesh => mesh%get_local_mesh() - constant_exists = & - face_selector_ns_inventory%paired_object_exists(local_mesh%get_id()) - - if (.not. constant_exists) call compute_face_selectors(mesh) - - call face_selector_ns_inventory%get_field(local_mesh, selector) - - end function get_face_selector_ns - - ! ========================================================================== ! - ! GETTERS FOR INVENTORIES - ! ========================================================================== ! - ! These are two special inventories, which are set up in the driver - - !> @brief Returns a pointer to the chi inventory - function get_chi_inventory() result(inventory_ptr) - implicit none - type(inventory_by_mesh_type), pointer :: inventory_ptr - - inventory_ptr => chi_inventory - - end function get_chi_inventory - - !> @brief Returns a pointer to the panel_id inventory - function get_panel_id_inventory() result(inventory_ptr) - implicit none - type(inventory_by_mesh_type), pointer :: inventory_ptr - - inventory_ptr => panel_id_inventory - - end function get_panel_id_inventory - - ! ========================================================================== ! - ! FINALISE - ! ========================================================================== ! - !> @brief Explicitly reclaim memory from module scope variables - subroutine final_geometric_constants() - - implicit none - - call lat_w2_inventory_fe%clear() - call lat_w2_inventory_fv%clear() - call lat_w3_inventory_fe%clear() - call lat_w3_inventory_fv%clear() - call lat_w2h_inventory_fe%clear() - call lat_w2h_inventory_fv%clear() - call long_w2_inventory_fe%clear() - call long_w2_inventory_fv%clear() - call long_w3_inventory_fe%clear() - call long_w3_inventory_fv%clear() - call long_w2h_inventory_fe%clear() - call long_w2h_inventory_fv%clear() - call dA_at_w2_inventory%clear() - call height_wth_inventory_fe%clear() - call height_wth_inventory_fv%clear() - call height_w3_inventory_fe%clear() - call height_w3_inventory_fv%clear() - call height_w2_inventory_fe%clear() - call height_w2_inventory_fv%clear() - call height_w2h_inventory_fe%clear() - call height_w2h_inventory_fv%clear() - call height_w1_inventory_fe%clear() - call height_w1_inventory_fv%clear() - call height_w0_inventory_fe%clear() - call height_w0_inventory_fv%clear() - call dz_w3_inventory%clear() - call panel_id_inventory%clear() - call chi_inventory%clear() - call extended_chi_inventory%clear() - call detj_at_w3_inventory_fe%clear() - call detj_at_w3_inventory_fv%clear() - call detj_at_w2_inventory_fe%clear() - call detj_at_w2_inventory_fv%clear() - call delta_at_wtheta_inventory%clear() - call dx_at_w2_inventory%clear() - call dz_at_wtheta_inventory%clear() - call dA_msl_proj_inventory%clear() - - end subroutine final_geometric_constants - -end module sci_geometric_constants_mod From d4f8af7e2723e13fdda57478b2f80657c0aefe79 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Thu, 23 Apr 2026 09:26:07 +0100 Subject: [PATCH 26/44] Update doxygen comments --- .../algorithm/sci_geometric_constants_mod.x90 | 27 +++--- .../algorithm/sci_mapping_constants_mod.x90 | 76 ++++++++++++---- .../kernel/geometry/sci_chi_transform_mod.F90 | 90 +++++++++---------- .../sci_compute_latlon_kernel_mod.F90 | 8 +- 4 files changed, 123 insertions(+), 78 deletions(-) diff --git a/components/science/source/algorithm/sci_geometric_constants_mod.x90 b/components/science/source/algorithm/sci_geometric_constants_mod.x90 index bf265a0be..0f17e6036 100644 --- a/components/science/source/algorithm/sci_geometric_constants_mod.x90 +++ b/components/science/source/algorithm/sci_geometric_constants_mod.x90 @@ -725,8 +725,8 @@ contains !> @param[in] coord_system Finite-Element coord-system enumeration value !> @param[in] scaled_radius Planet scaled radius !> @return The physical height difference of layers, at W3 - function get_dz_w3( mesh_id, & - geometry, coord_system, scaled_radius ) & + function get_dz_w3( mesh_id, geometry, & + coord_system, scaled_radius ) & result( dz_w3 ) use sci_get_dz_w3_kernel_mod, only: get_dz_w3_kernel_type @@ -870,8 +870,8 @@ contains !> @param[in] coord_system Finite-Element coord-system enumeration value !> @param[in] scaled_radius Planet scaled radius !> @return The dz_at_wtheta field - function get_dz_at_wtheta( mesh_id, & - geometry, coord_system, scaled_radius ) & + function get_dz_at_wtheta( mesh_id, geometry, & + coord_system, scaled_radius ) & result( dz_at_wtheta ) use sci_calc_dz_face_kernel_mod, only: calc_dz_face_kernel_type @@ -935,7 +935,8 @@ contains !> @param[in] planet_radius Planet radius (m) !> @param[in] domain_height Top of atmosphere height above mean surface (m) !> @return The dA_msl_proj field - function get_dA_msl_proj( mesh_id, geometry, planet_radius, domain_height ) & + function get_dA_msl_proj( mesh_id, geometry, & + planet_radius, domain_height ) & result( dA_msl_proj ) use sci_calc_da_msl_proj_kernel_mod, only: calc_da_msl_proj_kernel_type @@ -1177,8 +1178,8 @@ contains !> @param[in] f_lon Longitude of f-plane !> @param[in] scaled_radius Planet scaled radius !> @return The latitude field - function get_latitude_fe( space_id, mesh_id, geometry, topology, & - element_order_h, element_order_v, & + function get_latitude_fe( space_id, mesh_id, geometry, topology, & + element_order_h, element_order_v, & coord_system, f_lat, f_lon, scaled_radius ) & result( lat_ptr ) @@ -1208,7 +1209,7 @@ contains ! If running at lowest order, use finite volume if (element_order_h == 0 .and. element_order_v == 0) then lat_ptr => get_latitude_fv( space_id, mesh_id, geometry, topology, & - element_order_h, element_order_v, & + element_order_h, element_order_v, & coord_system, f_lat, f_lon, scaled_radius ) return end if @@ -1268,8 +1269,8 @@ contains !> @param[in] f_lon Longitude of f-plane !> @param[in] scaled_radius Planet scaled radius !> @return The latitude field - function get_latitude_fv( space_id, mesh_id, geometry, topology, & - element_order_h, element_order_v, & + function get_latitude_fv( space_id, mesh_id, geometry, topology, & + element_order_h, element_order_v, & coord_system, f_lat, f_lon, scaled_radius ) & result( lat_ptr ) @@ -1346,9 +1347,9 @@ contains !> @param[in] coord_system Finite-Element coord-system enumeration value !> @param[in] scaled_radius Planet scaled radius !> @return A height field - function get_height_fe( space_id, mesh_id, geometry, & + function get_height_fe( space_id, mesh_id, geometry, & element_order_h, element_order_v, & - coord_system, scaled_radius ) & + coord_system, scaled_radius ) & result( height ) @@ -1475,7 +1476,7 @@ contains !> @param[in] coord_system Finite-Element coord-system enumeration value !> @param[in] scaled_radius Planet scaled radius !> @return A height field - function get_height_fv( space_id, mesh_id, geometry, & + function get_height_fv( space_id, mesh_id, geometry, & coord_system, scaled_radius ) & result( height ) diff --git a/components/science/source/algorithm/sci_mapping_constants_mod.x90 b/components/science/source/algorithm/sci_mapping_constants_mod.x90 index e9201e6ed..15816a47a 100644 --- a/components/science/source/algorithm/sci_mapping_constants_mod.x90 +++ b/components/science/source/algorithm/sci_mapping_constants_mod.x90 @@ -200,10 +200,10 @@ contains !> @brief Create the operators for projecting spherical components in !! (W3, W3, Wtheta) to a vector-valued field in W2 !> @param[in] mesh The mesh to compute the operators for - !> @param[in] geometry - !> @param[in] topology - !> @param[in] coord-system - !> @param[in] scaled_radius + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius subroutine create_spherical_components_to_w2_projection( mesh, geometry, topology, & coord_system, scaled_radius ) @@ -268,7 +268,11 @@ contains !> @brief Create the operators for sampling spherical components in !! (W3, W3, Wtheta) to a vector-valued field in W2 - !> @param[in] mesh The mesh to compute the operators for + !> @param[in] mesh The mesh to compute the operators for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius subroutine create_spherical_components_to_w2_sample( mesh, geometry, topology, & coord_system, scaled_radius ) @@ -870,7 +874,11 @@ contains end function get_project_zdot_to_w2 !> @brief Returns a pointer to the u_lon mapping operator - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The mapping operator for u_lon to W2 function get_u_lon_map( mesh_id, geometry, topology, & coord_system, scaled_radius ) & @@ -907,7 +915,11 @@ contains end function get_u_lon_map !> @brief Returns a pointer to the u_lat mapping operator - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The mapping operator for u_lat to W2 function get_u_lat_map( mesh_id, geometry, topology, & coord_system, scaled_radius ) & @@ -944,7 +956,11 @@ contains end function get_u_lat_map !> @brief Returns a pointer to the u_up mapping operator - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The mapping operator for u_up to W2 function get_u_up_map( mesh_id, geometry, topology, & coord_system, scaled_radius ) & @@ -981,7 +997,11 @@ contains end function get_u_up_map !> @brief Returns a pointer to the u_lon sampling operator - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The sampling operator for u_lon to W2 function get_u_lon_sample( mesh_id, geometry, topology, & coord_system, scaled_radius ) & @@ -1018,7 +1038,11 @@ contains end function get_u_lon_sample !> @brief Returns a pointer to the u_lat sampling operator - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The sampling operator for u_lat to W2 function get_u_lat_sample( mesh_id, geometry, topology, & coord_system, scaled_radius ) & @@ -1055,7 +1079,11 @@ contains end function get_u_lat_sample !> @brief Returns a pointer to the u_up sampling operator - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The sampling operator for u_up to W2 function get_u_up_sample( mesh_id, geometry, topology, & coord_system, scaled_radius) & @@ -1063,7 +1091,7 @@ contains implicit none - integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: mesh_id integer(i_def), intent(in) :: geometry integer(i_def), intent(in) :: topology integer(i_def), intent(in) :: coord_system @@ -1092,7 +1120,11 @@ contains end function get_u_up_sample !> @brief Returns a pointer to the operator projection from lon dot to W1 - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The projection operator function get_project_lon_dot_to_w1( mesh_id, geometry, topology, & coord_system, scaled_radius ) & @@ -1160,7 +1192,11 @@ contains end function get_project_lon_dot_to_w1 !> @brief Returns a pointer to the operator projection from lat dot to W1 - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The projection operator function get_project_lat_dot_to_w1( mesh_id, geometry, topology, & coord_system, scaled_radius ) & @@ -1228,7 +1264,11 @@ contains end function get_project_lat_dot_to_w1 !> @brief Returns a pointer to the operator projection from r dot to W1 - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The projection operator function get_project_r_dot_to_w1( mesh_id, geometry, topology, & coord_system, scaled_radius ) & @@ -1294,7 +1334,11 @@ contains end function get_project_r_dot_to_w1 !> @brief Returns the displacement when averaging from W3 to W2 - !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] mesh_id The ID of the mesh to get the object for + !> @param[in] geometry Mesh geometry enumeration value + !> @param[in] topology Mesh topology enumeration value + !> @param[in] coord_system Finite-Element coord-system enumeration value + !> @param[in] scaled_radius Planet scaled radius !> @return The displacement field used for correcting mappings from W3 to W2 function get_w3_to_w2_displacement( mesh_id, geometry, topology, & coord_system, scaled_radius ) & diff --git a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 index a85980009..d939d8c6f 100644 --- a/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 +++ b/components/science/source/kernel/geometry/sci_chi_transform_mod.F90 @@ -74,8 +74,8 @@ module sci_chi_transform_mod !------------------------------------------------------------------------------ !> @brief Initialise the coordinate transform information !! -!> @param[in] geometry -!> @param[in] topology +!> @param[in] geometry Mesh geometry enumeration value +!> @param[in] topology Mesh topology enumeration value !> @param[in] mesh_collection Optional: a collection of meshes, which contain !! metadata used to determine the rotation matrix !! and stretching factors. @@ -243,17 +243,17 @@ end subroutine final_chi_transforms !> will be added to the height to give the radius before the coordinates !> are transformed to (X,Y,Z) coordinates. !! -!! @param[in] chi_1 The first coordinate field in -!! @param[in] chi_2 The second coordinate field in -!! @param[in] chi_3 The third coordinate field in -!! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[in] scaled_radius -!! @param[out] x The first coordinate field out (global Cartesian X) -!! @param[out] y The second coordinate field out (global Cartesian Y) -!! @param[out] z The third coordinate field out (global Cartesian Z) +!! @param[in] chi_1 The first coordinate field in +!! @param[in] chi_2 The second coordinate field in +!! @param[in] chi_3 The third coordinate field in +!! @param[in] panel_id The mesh panel ID +!> @param[in] geometry Mesh geometry enumeration value +!> @param[in] topology Mesh topology enumeration value +!> @param[in] coord_system Finite-Element coord-system enumeration value +!> @param[in] scaled_radius Planet scaled radius +!! @param[out] x The first coordinate field out (global Cartesian X) +!! @param[out] y The second coordinate field out (global Cartesian Y) +!! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- subroutine chi2xyz( chi_1, chi_2, chi_3, panel_id, & geometry, topology, coord_system, scaled_radius, & @@ -336,16 +336,16 @@ end subroutine chi2xyz !> function from chi2xyz above). Therefore this will not add the !> scaled_radius to transform. !! -!! @param[in] chi_1 The first coordinate field in -!! @param[in] chi_2 The second coordinate field in -!! @param[in] chi_3 The third coordinate field in -!! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[out] x The first coordinate field out (global Cartesian X) -!! @param[out] y The second coordinate field out (global Cartesian Y) -!! @param[out] z The third coordinate field out (global Cartesian Z) +!! @param[in] chi_1 The first coordinate field in +!! @param[in] chi_2 The second coordinate field in +!! @param[in] chi_3 The third coordinate field in +!! @param[in] panel_id The mesh panel ID +!> @param[in] geometry Mesh geometry enumeration value +!> @param[in] topology Mesh topology enumeration value +!> @param[in] coord_system Finite-Element coord-system enumeration value +!! @param[out] x The first coordinate field out (global Cartesian X) +!! @param[out] y The second coordinate field out (global Cartesian Y) +!! @param[out] z The third coordinate field out (global Cartesian Z) !------------------------------------------------------------------------------- subroutine chir2xyz( chi_1, chi_2, chi_3, panel_id, & geometry, topology, coord_system, & @@ -424,17 +424,17 @@ end subroutine chir2xyz !> @brief Transforms a coordinate field chi from any system into spherical polar !> (longitude, latitude, radius) coordinates !! -!! @param[in] chi_1 The first coordinate field in -!! @param[in] chi_2 The second coordinate field in -!! @param[in] chi_3 The third coordinate field in -!! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[in] scaled_radius -!! @param[out] longitude The first coordinate field out (longitude) -!! @param[out] latitude The second coordinate field out (latitude) -!! @param[out] radius The third coordinate field out (radius) +!! @param[in] chi_1 The first coordinate field in +!! @param[in] chi_2 The second coordinate field in +!! @param[in] chi_3 The third coordinate field in +!! @param[in] panel_id The mesh panel ID +!> @param[in] geometry Mesh geometry enumeration value +!> @param[in] topology Mesh topology enumeration value +!> @param[in] coord_system Finite-Element coord-system enumeration value +!> @param[in] scaled_radius Planet scaled radius +!! @param[out] longitude The first coordinate field out (longitude) +!! @param[out] latitude The second coordinate field out (latitude) +!! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- subroutine chi2llr( chi_1, chi_2, chi_3, panel_id, & geometry, topology, coord_system, scaled_radius, & @@ -507,17 +507,17 @@ end subroutine chi2llr !> @brief Transforms a coordinate field chi from any system into *native* !! equiangular cubed sphere (alpha,beta,radius) coordinates !! -!! @param[in] chi_1 The first coordinate field in -!! @param[in] chi_2 The second coordinate field in -!! @param[in] chi_3 The third coordinate field in -!! @param[in] panel_id The mesh panel ID -!! @param[in] geometry -!! @param[in] topology -!! @param[in] coord_system -!! @param[in] scaled_radius -!! @param[out] alpha The first coordinate field out (alpha) -!! @param[out] beta The second coordinate field out (beta) -!! @param[out] radius The third coordinate field out (radius) +!! @param[in] chi_1 The first coordinate field in +!! @param[in] chi_2 The second coordinate field in +!! @param[in] chi_3 The third coordinate field in +!! @param[in] panel_id The mesh panel ID +!> @param[in] geometry Mesh geometry enumeration value +!> @param[in] topology Mesh topology enumeration value +!> @param[in] coord_system Finite-Element coord-system enumeration value +!> @param[in] scaled_radius Planet scaled radius +!! @param[out] alpha The first coordinate field out (alpha) +!! @param[out] beta The second coordinate field out (beta) +!! @param[out] radius The third coordinate field out (radius) !------------------------------------------------------------------------------- subroutine chi2abr( chi_1, chi_2, chi_3, panel_id, & geometry, topology, coord_system, scaled_radius, & diff --git a/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 b/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 index 584647b53..35da135a3 100644 --- a/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 +++ b/components/science/source/kernel/geometry/sci_compute_latlon_kernel_mod.F90 @@ -68,10 +68,10 @@ module sci_compute_latlon_kernel_mod !> @param[in] chi_2 Second component of the coordinate field !> @param[in] chi_3 Third component of the coordinate field !> @param[in] panel_id A field giving the ID for mesh panels -!> @param[in] geometry -!> @param[in] topology -!> @param[in] coord_system -!> @param[in] scaled_radius +!> @param[in] geometry Mesh geometry enumeration value +!> @param[in] topology Mesh topology enumeration value +!> @param[in] coord_system Finite-Element coord-system enumeration value +!> @param[in] scaled_radius Planet scaled radius !> @param[in] ndf_x Number of degrees of freedom per cell for height !> @param[in] undf_x Number of unique degrees of freedom for height !> @param[in] map_x Dofmap for the cell at the base of the column for height From 71ebba6aa17808443cf96a72880ff0ec908d4398 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 29 Apr 2026 10:49:09 +0100 Subject: [PATCH 27/44] Add in update macros --- .../source/driver/coupled_driver_mod.f90 | 4 ++-- .../source/driver/io_demo_driver_mod.f90 | 4 ++-- .../source/driver/lbc_demo_driver_mod.f90 | 4 ++-- .../driver/simple_diffusion_driver_mod.f90 | 4 ++-- .../source/driver/skeleton_driver_mod.f90 | 4 ++-- .../lfric-driver/HEAD/rose-meta.conf | 6 +++++ .../driver/rose-meta/lfric-driver/versions.py | 23 +++++++++++++++++++ 7 files changed, 39 insertions(+), 10 deletions(-) diff --git a/applications/coupled/source/driver/coupled_driver_mod.f90 b/applications/coupled/source/driver/coupled_driver_mod.f90 index 5aed2707d..205990e8b 100644 --- a/applications/coupled/source/driver/coupled_driver_mod.f90 +++ b/applications/coupled/source/driver/coupled_driver_mod.f90 @@ -104,8 +104,8 @@ subroutine initialise( program_name, modeldb, calendar ) tile_size_y = 1 inner_halo_tiles = .false. else - tile_size_x = modeldb%config%partitioning%tile_size_x() - tile_size_y = modeldb%config%partitioning%tile_size_y() + tile_size_x = maxval([1,modeldb%config%partitioning%tile_size_x()]) + tile_size_y = maxval([1,modeldb%config%partitioning%tile_size_y()]) inner_halo_tiles = modeldb%config%partitioning%inner_halo_tiles() end if diff --git a/applications/io_demo/source/driver/io_demo_driver_mod.f90 b/applications/io_demo/source/driver/io_demo_driver_mod.f90 index 5c257d8de..81b718ab3 100644 --- a/applications/io_demo/source/driver/io_demo_driver_mod.f90 +++ b/applications/io_demo/source/driver/io_demo_driver_mod.f90 @@ -127,8 +127,8 @@ subroutine initialise(program_name, modeldb) tile_size_y = 1 inner_halo_tiles = .false. else - tile_size_x = modeldb%config%partitioning%tile_size_x() - tile_size_y = modeldb%config%partitioning%tile_size_y() + tile_size_x = maxval([1,modeldb%config%partitioning%tile_size_x()]) + tile_size_y = maxval([1,modeldb%config%partitioning%tile_size_y()]) inner_halo_tiles = modeldb%config%partitioning%inner_halo_tiles() end if diff --git a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 index 61c8b476d..9a1fc448c 100644 --- a/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 +++ b/applications/lbc_demo/source/driver/lbc_demo_driver_mod.f90 @@ -125,8 +125,8 @@ subroutine initialise( program_name, modeldb) tile_size_y = 1 inner_halo_tiles = .false. else - tile_size_x = modeldb%config%partitioning%tile_size_x() - tile_size_y = modeldb%config%partitioning%tile_size_y() + tile_size_x = maxval([1,modeldb%config%partitioning%tile_size_x()]) + tile_size_y = maxval([1,modeldb%config%partitioning%tile_size_y()]) inner_halo_tiles = modeldb%config%partitioning%inner_halo_tiles() end if diff --git a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 index d5b8e3340..b7d295a33 100644 --- a/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 +++ b/applications/simple_diffusion/source/driver/simple_diffusion_driver_mod.f90 @@ -116,8 +116,8 @@ subroutine initialise( program_name, modeldb) tile_size_y = 1 inner_halo_tiles = .false. else - tile_size_x = modeldb%config%partitioning%tile_size_x() - tile_size_y = modeldb%config%partitioning%tile_size_y() + tile_size_x = maxval([1,modeldb%config%partitioning%tile_size_x()]) + tile_size_y = maxval([1,modeldb%config%partitioning%tile_size_y()]) inner_halo_tiles = modeldb%config%partitioning%inner_halo_tiles() end if diff --git a/applications/skeleton/source/driver/skeleton_driver_mod.f90 b/applications/skeleton/source/driver/skeleton_driver_mod.f90 index 5a5357a4e..f2fd62ad9 100644 --- a/applications/skeleton/source/driver/skeleton_driver_mod.f90 +++ b/applications/skeleton/source/driver/skeleton_driver_mod.f90 @@ -115,8 +115,8 @@ subroutine initialise(program_name, modeldb) tile_size_y = 1 inner_halo_tiles = .false. else - tile_size_x = modeldb%config%partitioning%tile_size_x() - tile_size_y = modeldb%config%partitioning%tile_size_y() + tile_size_x = maxval([1,modeldb%config%partitioning%tile_size_x()]) + tile_size_y = maxval([1,modeldb%config%partitioning%tile_size_y()]) inner_halo_tiles = modeldb%config%partitioning%inner_halo_tiles() end if diff --git a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf index 716576fef..c929a4a21 100644 --- a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf @@ -635,7 +635,9 @@ description=Reduce x and y tile sizes by a factor of 2 in each multigrid level help=Enables using larger tiles at higher resolution levels by automatically =reducing tile sizes in coarser levels, which can improve performance. sort-key=Panel-A10 +trigger=namelist:multigrid=max_tiled_multigrid_level: .true. ; type=logical +!kind=default [namelist:multigrid=max_tiled_multigrid_level] compulsory=true @@ -646,6 +648,7 @@ help=Revert to 1x1 tiling (equivalent to colouring) for multigrid levels range=1: sort-key=Panel-A09 type=integer +!kind=default [namelist:multigrid=multigrid_chain_nitems] compulsory=true @@ -704,6 +707,9 @@ help=Tiling inner halos separately from the partition interior guarantees =which can be useful when overlapping communication and computation. !kind=default sort-key=Panel-A08 +trigger=namelist:multigrid=coarsen_multigrid_tiles: .true. ; + =namelist:partitioning=tile_size_x: .true. ; + =namelist:partitioning=tile_size_y: .true. ; type=logical [namelist:partitioning=panel_decomposition] diff --git a/components/driver/rose-meta/lfric-driver/versions.py b/components/driver/rose-meta/lfric-driver/versions.py index 01798ad2b..83746f768 100644 --- a/components/driver/rose-meta/lfric-driver/versions.py +++ b/components/driver/rose-meta/lfric-driver/versions.py @@ -31,3 +31,26 @@ def upgrade(self, config, meta_config=None): # Add settings return config, self.reports """ + + +class vn31_t324(MacroUpgrade): + """Upgrade macro for ticket LFRic Core PR 324 by Ricky Wong.""" + + BEFORE_TAG = "vn3.1" + AFTER_TAG = "vn3.1_t324" + + def upgrade(self, config, meta_config=None): + # Commands From: rose-meta/lfric-driver + self.add_setting( + config, ["namelist:partitioning", "inner_halo_tiles"], ".false." + ) + self.add_setting(config, ["namelist:partitioning", "tile_size_x"], "1") + self.add_setting(config, ["namelist:partitioning", "tile_size_y"], "1") + self.add_setting( + config, ["namelist:multigrid", "coarsen_multigrid_tiles"], ".false." + ) + self.add_setting( + config, ["namelist:multigrid", "max_tiled_multigrid_level"], "1" + ) + + return config, self.reports From 6d2589cfce5430160a3bf6d37ce35faae77ea561 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 29 Apr 2026 11:46:00 +0100 Subject: [PATCH 28/44] Update rose stem to pre-macro state --- rose-stem/app/coupled/rose-app.conf | 5 ----- rose-stem/app/housekeeping/bin/housekeeping.sh | 2 -- rose-stem/app/io_demo/rose-app.conf | 5 ----- rose-stem/app/lbc_demo/rose-app.conf | 3 --- rose-stem/app/simple_diffusion/rose-app.conf | 5 ----- rose-stem/app/skeleton/rose-app.conf | 5 ----- 6 files changed, 25 deletions(-) diff --git a/rose-stem/app/coupled/rose-app.conf b/rose-stem/app/coupled/rose-app.conf index a3f42e9d7..38b1839b6 100644 --- a/rose-stem/app/coupled/rose-app.conf +++ b/rose-stem/app/coupled/rose-app.conf @@ -72,19 +72,14 @@ run_log_level='info' [namelist:multigrid] chain_mesh_tags='' -coarsen_multigrid_tiles=.false. -max_tiled_multigrid_level=1 multigrid_chain_nitems=1 [namelist:partitioning] generate_inner_halos=.true. -inner_halo_tiles=.false. panel_decomposition='auto' !!panel_xproc=0 !!panel_yproc=0 partitioner='cubedsphere' -tile_size_x=1 -tile_size_y=1 [namelist:planet] scaling_factor=125.0 diff --git a/rose-stem/app/housekeeping/bin/housekeeping.sh b/rose-stem/app/housekeeping/bin/housekeeping.sh index d037b7440..92d39e29f 100755 --- a/rose-stem/app/housekeeping/bin/housekeeping.sh +++ b/rose-stem/app/housekeeping/bin/housekeeping.sh @@ -18,10 +18,8 @@ if [ -n ${CYLC_WORKFLOW_WORK_DIR} ]; then fi if [ -n ${CYLC_WORKFLOW_SHARE_DIR} ]; then if [ -L ${CYLC_WORKFLOW_SHARE_DIR} ]; then - rm -rfv "$(readlink -f $CYLC_WORKFLOW_SHARE_DIR)"/source rm -rfv "$(readlink -f $CYLC_WORKFLOW_SHARE_DIR)"/data else - rm -rfv $CYLC_WORKFLOW_SHARE_DIR/source rm -rfv $CYLC_WORKFLOW_SHARE_DIR/data fi fi diff --git a/rose-stem/app/io_demo/rose-app.conf b/rose-stem/app/io_demo/rose-app.conf index abb38ba8b..941e03c95 100644 --- a/rose-stem/app/io_demo/rose-app.conf +++ b/rose-stem/app/io_demo/rose-app.conf @@ -81,19 +81,14 @@ run_log_level='info' [namelist:multigrid] chain_mesh_tags='' -coarsen_multigrid_tiles=.false. -max_tiled_multigrid_level=1 multigrid_chain_nitems=1 [namelist:partitioning] generate_inner_halos=.false. -inner_halo_tiles=.false. panel_decomposition='auto' !!panel_xproc=1 !!panel_yproc=1 partitioner='planar' -tile_size_x=1 -tile_size_y=1 [namelist:planet] scaling_factor=125.0 diff --git a/rose-stem/app/lbc_demo/rose-app.conf b/rose-stem/app/lbc_demo/rose-app.conf index d5af0b010..d979a47c6 100644 --- a/rose-stem/app/lbc_demo/rose-app.conf +++ b/rose-stem/app/lbc_demo/rose-app.conf @@ -79,13 +79,10 @@ run_log_level='info' [!!namelist:partitioning] generate_inner_halos=.false. -inner_halo_tiles=.false. panel_decomposition='auto' !!panel_xproc=1 !!panel_yproc=1 partitioner='planar' -tile_size_x=1 -tile_size_y=1 [namelist:planet] scaling_factor=125.0 diff --git a/rose-stem/app/simple_diffusion/rose-app.conf b/rose-stem/app/simple_diffusion/rose-app.conf index b63fc93f7..f710dfe34 100644 --- a/rose-stem/app/simple_diffusion/rose-app.conf +++ b/rose-stem/app/simple_diffusion/rose-app.conf @@ -73,19 +73,14 @@ run_log_level='info' [namelist:multigrid] chain_mesh_tags='' -coarsen_multigrid_tiles=.false. -max_tiled_multigrid_level=1 multigrid_chain_nitems=1 [namelist:partitioning] generate_inner_halos=.true. -inner_halo_tiles=.false. panel_decomposition='auto' !!panel_xproc=1 !!panel_yproc=1 partitioner='planar' -tile_size_x=1 -tile_size_y=1 [namelist:planet] scaling_factor=125.0 diff --git a/rose-stem/app/skeleton/rose-app.conf b/rose-stem/app/skeleton/rose-app.conf index 132e0a428..7e966d0b7 100644 --- a/rose-stem/app/skeleton/rose-app.conf +++ b/rose-stem/app/skeleton/rose-app.conf @@ -70,19 +70,14 @@ run_log_level='info' [namelist:multigrid] chain_mesh_tags='' -coarsen_multigrid_tiles=.false. -max_tiled_multigrid_level=1 multigrid_chain_nitems=1 [namelist:partitioning] generate_inner_halos=.true. -inner_halo_tiles=.false. panel_decomposition='auto' !!panel_xproc=1 !!panel_yproc=1 partitioner='planar' -tile_size_x=1 -tile_size_y=1 [namelist:planet] scaling_factor=125.0 From e7401803c5de8c11da0aed16def1e52da3a76faf Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 29 Apr 2026 11:51:20 +0100 Subject: [PATCH 29/44] Add some kinds --- components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf index c929a4a21..8da4dae95 100644 --- a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf @@ -634,10 +634,10 @@ compulsory=true description=Reduce x and y tile sizes by a factor of 2 in each multigrid level help=Enables using larger tiles at higher resolution levels by automatically =reducing tile sizes in coarser levels, which can improve performance. +!kind=default sort-key=Panel-A10 trigger=namelist:multigrid=max_tiled_multigrid_level: .true. ; type=logical -!kind=default [namelist:multigrid=max_tiled_multigrid_level] compulsory=true @@ -645,10 +645,10 @@ description=Coarsest multigrid level to be tiled help=Revert to 1x1 tiling (equivalent to colouring) for multigrid levels =above this threshold (level 1 has highest resolution); tiling is =typically more beneficial for higher resolutions. +!kind=default range=1: sort-key=Panel-A09 type=integer -!kind=default [namelist:multigrid=multigrid_chain_nitems] compulsory=true From c68bc2b9ed2131ae6203276a9116c204f1409ca2 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 29 Apr 2026 14:31:47 +0100 Subject: [PATCH 30/44] Change the version on apps so the upgrade macros will work --- rose-stem/app/io_demo/rose-app.conf | 2 +- rose-stem/app/lbc_demo/rose-app.conf | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/rose-stem/app/io_demo/rose-app.conf b/rose-stem/app/io_demo/rose-app.conf index 941e03c95..5f7f0e7ca 100644 --- a/rose-stem/app/io_demo/rose-app.conf +++ b/rose-stem/app/io_demo/rose-app.conf @@ -1,4 +1,4 @@ -meta=lfric-io_demo/HEAD +meta=lfric-io_demo/vn3.1 [command] default=$CORE_ROOT_DIR/bin/tweak_iodef ; \ diff --git a/rose-stem/app/lbc_demo/rose-app.conf b/rose-stem/app/lbc_demo/rose-app.conf index d979a47c6..b81c4d29f 100644 --- a/rose-stem/app/lbc_demo/rose-app.conf +++ b/rose-stem/app/lbc_demo/rose-app.conf @@ -1,4 +1,4 @@ -meta=lfric-lbc_demo/HEAD +meta=lfric-lbc_demo/vn3.1 [command] default=$CORE_ROOT_DIR/bin/tweak_iodef ; \ From 781111bceafe7d62ca23aa6556ea98014a916d37 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 29 Apr 2026 14:58:08 +0100 Subject: [PATCH 31/44] Fix existing issues on trunk cause update macro failures --- .../lbc_demo/rose-meta/lfric-lbc_demo/version22_30.py | 4 ++-- rose-meta/lfric-lbc_demo | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) create mode 120000 rose-meta/lfric-lbc_demo diff --git a/applications/lbc_demo/rose-meta/lfric-lbc_demo/version22_30.py b/applications/lbc_demo/rose-meta/lfric-lbc_demo/version22_30.py index c2098bef6..864b94e95 100644 --- a/applications/lbc_demo/rose-meta/lfric-lbc_demo/version22_30.py +++ b/applications/lbc_demo/rose-meta/lfric-lbc_demo/version22_30.py @@ -39,9 +39,8 @@ class vn22_t4231(MacroUpgrade): def upgrade(self, config, meta_config=None): # Add settings return config, self.reports -""" - +""" class vn22_t34(MacroUpgrade): # Upgrade macro for 34 by jennifer hickson @@ -50,3 +49,4 @@ class vn22_t34(MacroUpgrade): def upgrade(self, config, meta_config=None): return config, self.reports +""" diff --git a/rose-meta/lfric-lbc_demo b/rose-meta/lfric-lbc_demo new file mode 120000 index 000000000..c4b8f3c23 --- /dev/null +++ b/rose-meta/lfric-lbc_demo @@ -0,0 +1 @@ +../applications/lbc_demo/rose-meta/lfric-lbc_demo/ \ No newline at end of file From c5bfc2f4d8c27ca0e4c38d2509178a501ea610e7 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 29 Apr 2026 18:38:38 +0100 Subject: [PATCH 32/44] Update rose meta and macros for driver --- .../rose-meta/lfric-driver/HEAD/rose-meta.conf | 2 +- .../driver/rose-meta/lfric-driver/versions.py | 15 ++++++++++++--- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf index 8da4dae95..9d4050bcc 100644 --- a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf @@ -653,7 +653,7 @@ type=integer [namelist:multigrid=multigrid_chain_nitems] compulsory=true description=Number of items in multigrid function space chain -fail-if=this < 1 ; +fail-if=this < 0 ; help=?????? =?????? !kind=default diff --git a/components/driver/rose-meta/lfric-driver/versions.py b/components/driver/rose-meta/lfric-driver/versions.py index 83746f768..cfaf422ba 100644 --- a/components/driver/rose-meta/lfric-driver/versions.py +++ b/components/driver/rose-meta/lfric-driver/versions.py @@ -1,3 +1,4 @@ +import re import sys from metomi.rose.upgrade import MacroUpgrade # noqa: F401 @@ -20,13 +21,10 @@ def __repr__(self): """ Copy this template and complete to add your macro - class vnXX_txxx(MacroUpgrade): # Upgrade macro for by - BEFORE_TAG = "vnX.X" AFTER_TAG = "vnX.X_txxx" - def upgrade(self, config, meta_config=None): # Add settings return config, self.reports @@ -46,6 +44,17 @@ def upgrade(self, config, meta_config=None): ) self.add_setting(config, ["namelist:partitioning", "tile_size_x"], "1") self.add_setting(config, ["namelist:partitioning", "tile_size_y"], "1") + self.add_setting( + config, + ["namelist:partitioning(destination)", "inner_halo_tiles"], + ".false.", + ) + self.add_setting( + config, ["namelist:partitioning(destination)", "tile_size_x"], "1" + ) + self.add_setting( + config, ["namelist:partitioning(destination)", "tile_size_y"], "1" + ) self.add_setting( config, ["namelist:multigrid", "coarsen_multigrid_tiles"], ".false." ) From d9e59d53770aeba67d35bfd3cdf08efba62c6986 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Wed, 29 Apr 2026 21:47:26 +0100 Subject: [PATCH 33/44] Update versions update so that lfric2lfric partition duplicates aren't thrown everywhere --- .../driver/rose-meta/lfric-driver/versions.py | 74 +++++++++++++------ 1 file changed, 51 insertions(+), 23 deletions(-) diff --git a/components/driver/rose-meta/lfric-driver/versions.py b/components/driver/rose-meta/lfric-driver/versions.py index cfaf422ba..6be897c2d 100644 --- a/components/driver/rose-meta/lfric-driver/versions.py +++ b/components/driver/rose-meta/lfric-driver/versions.py @@ -32,34 +32,62 @@ def upgrade(self, config, meta_config=None): class vn31_t324(MacroUpgrade): - """Upgrade macro for ticket LFRic Core PR 324 by Ricky Wong.""" + """Upgrade macro for LFRic Core PR#324 by Ricky Wong""" BEFORE_TAG = "vn3.1" AFTER_TAG = "vn3.1_t324" def upgrade(self, config, meta_config=None): # Commands From: rose-meta/lfric-driver - self.add_setting( - config, ["namelist:partitioning", "inner_halo_tiles"], ".false." - ) - self.add_setting(config, ["namelist:partitioning", "tile_size_x"], "1") - self.add_setting(config, ["namelist:partitioning", "tile_size_y"], "1") - self.add_setting( - config, - ["namelist:partitioning(destination)", "inner_halo_tiles"], - ".false.", - ) - self.add_setting( - config, ["namelist:partitioning(destination)", "tile_size_x"], "1" - ) - self.add_setting( - config, ["namelist:partitioning(destination)", "tile_size_y"], "1" - ) - self.add_setting( - config, ["namelist:multigrid", "coarsen_multigrid_tiles"], ".false." - ) - self.add_setting( - config, ["namelist:multigrid", "max_tiled_multigrid_level"], "1" - ) + # Only add in new configuration settings if the namelists + # are already present + # + if config.get(["namelist:partitioning"]) is not None: + self.add_setting( + config, ["namelist:partitioning", "inner_halo_tiles"], ".false." + ) + self.add_setting( + config, ["namelist:partitioning", "tile_size_x"], "1" + ) + self.add_setting( + config, ["namelist:partitioning", "tile_size_y"], "1" + ) + if config.get(["namelist:partitioning(destination)"]) is not None: + self.add_setting( + config, + ["namelist:partitioning(destination)", "inner_halo_tiles"], + ".false.", + ) + self.add_setting( + config, + ["namelist:partitioning(destination)", "tile_size_x"], + "1", + ) + self.add_setting( + config, + ["namelist:partitioning(destination)", "tile_size_y"], + "1", + ) + if config.get(["namelist:partitioning(destination)"]) is not None: + self.add_setting( + config, + ["namelist:partitioning(source)", "inner_halo_tiles"], + ".false.", + ) + self.add_setting( + config, ["namelist:partitioning(source)", "tile_size_x"], "1" + ) + self.add_setting( + config, ["namelist:partitioning(source)", "tile_size_y"], "1" + ) + if config.get(["namelist:multigrid)"]) is not None: + self.add_setting( + config, + ["namelist:multigrid", "coarsen_multigrid_tiles"], + ".false.", + ) + self.add_setting( + config, ["namelist:multigrid", "max_tiled_multigrid_level"], "1" + ) return config, self.reports From 946b1ad3b31592e996fb4e201dad3399177d553e Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Thu, 30 Apr 2026 11:57:40 +0100 Subject: [PATCH 34/44] Correct rose metadata settings --- .../lfric-io_demo/vn3.1/rose-meta.conf | 32 +++++++++++++++++-- rose-stem/app/io_demo/rose-app.conf | 2 +- rose-stem/app/lbc_demo/rose-app.conf | 2 +- 3 files changed, 32 insertions(+), 4 deletions(-) diff --git a/applications/io_demo/rose-meta/lfric-io_demo/vn3.1/rose-meta.conf b/applications/io_demo/rose-meta/lfric-io_demo/vn3.1/rose-meta.conf index bd3389f88..2b8c3d9ae 100644 --- a/applications/io_demo/rose-meta/lfric-io_demo/vn3.1/rose-meta.conf +++ b/applications/io_demo/rose-meta/lfric-io_demo/vn3.1/rose-meta.conf @@ -1,6 +1,28 @@ -import=lfric-driver/vn3.1 +import=lfric-driver/HEAD -[namelist:io=multifile_io] +[namelist:io_demo] +compulsory=true +description=Provides options for configuring the runtime behaviour of the IO_Demo app +ns=namelist/io_demo +sort-key=Section-A02 +title=IO_Demo + +[namelist:io_demo=benchmark_sleep_time] +compulsory=true +description=Number of seconds to sleep for each timestep in I/O benchmark mode +!kind=default +type=integer + +[namelist:io_demo=io_benchmark] +compulsory=true +description=Configure application to run as an I/O benchmarking tool +help=Configure application to run as an I/O benchmarking tool +!kind=default +trigger=namelist:io_demo=benchmark_sleep_time: .true. ; + =namelist:io_demo=n_benchmark_fields: .true. ; +type=logical + +[namelist:io_demo=multifile_io] compulsory=true description=Use multifile_io functionality help=This is used to turn the multifile_io functionality in the io_demo app @@ -8,6 +30,12 @@ help=This is used to turn the multifile_io functionality in the io_demo app !kind=default type=logical +[namelist:io_demo=n_benchmark_fields] +compulsory=true +description=Number of fields created in I/O benchmark +!kind=default +type=integer + [namelist:multifile_io] compulsory=false duplicate=true diff --git a/rose-stem/app/io_demo/rose-app.conf b/rose-stem/app/io_demo/rose-app.conf index 941e03c95..5f7f0e7ca 100644 --- a/rose-stem/app/io_demo/rose-app.conf +++ b/rose-stem/app/io_demo/rose-app.conf @@ -1,4 +1,4 @@ -meta=lfric-io_demo/HEAD +meta=lfric-io_demo/vn3.1 [command] default=$CORE_ROOT_DIR/bin/tweak_iodef ; \ diff --git a/rose-stem/app/lbc_demo/rose-app.conf b/rose-stem/app/lbc_demo/rose-app.conf index d979a47c6..b81c4d29f 100644 --- a/rose-stem/app/lbc_demo/rose-app.conf +++ b/rose-stem/app/lbc_demo/rose-app.conf @@ -1,4 +1,4 @@ -meta=lfric-lbc_demo/HEAD +meta=lfric-lbc_demo/vn3.1 [command] default=$CORE_ROOT_DIR/bin/tweak_iodef ; \ From 6e2d278ddcf8a9930251cafbfa008210a217b26b Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Thu, 30 Apr 2026 12:30:44 +0100 Subject: [PATCH 35/44] Set io_demo to point to corresponding version of driver --- .../io_demo/rose-meta/lfric-io_demo/vn3.1/rose-meta.conf | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/applications/io_demo/rose-meta/lfric-io_demo/vn3.1/rose-meta.conf b/applications/io_demo/rose-meta/lfric-io_demo/vn3.1/rose-meta.conf index 2b8c3d9ae..2af56e5b0 100644 --- a/applications/io_demo/rose-meta/lfric-io_demo/vn3.1/rose-meta.conf +++ b/applications/io_demo/rose-meta/lfric-io_demo/vn3.1/rose-meta.conf @@ -1,4 +1,4 @@ -import=lfric-driver/HEAD +import=lfric-driver/vn3.1 [namelist:io_demo] compulsory=true From 41fc339e6ce2ec85a787ebee67daaa35bfb6f96d Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Thu, 30 Apr 2026 13:38:51 +0100 Subject: [PATCH 36/44] update versions file --- .../driver/rose-meta/lfric-driver/versions.py | 31 ++----------------- 1 file changed, 2 insertions(+), 29 deletions(-) diff --git a/components/driver/rose-meta/lfric-driver/versions.py b/components/driver/rose-meta/lfric-driver/versions.py index 6be897c2d..451b2b61f 100644 --- a/components/driver/rose-meta/lfric-driver/versions.py +++ b/components/driver/rose-meta/lfric-driver/versions.py @@ -52,39 +52,12 @@ def upgrade(self, config, meta_config=None): self.add_setting( config, ["namelist:partitioning", "tile_size_y"], "1" ) - if config.get(["namelist:partitioning(destination)"]) is not None: - self.add_setting( - config, - ["namelist:partitioning(destination)", "inner_halo_tiles"], - ".false.", - ) - self.add_setting( - config, - ["namelist:partitioning(destination)", "tile_size_x"], - "1", - ) - self.add_setting( - config, - ["namelist:partitioning(destination)", "tile_size_y"], - "1", - ) - if config.get(["namelist:partitioning(destination)"]) is not None: - self.add_setting( - config, - ["namelist:partitioning(source)", "inner_halo_tiles"], - ".false.", - ) - self.add_setting( - config, ["namelist:partitioning(source)", "tile_size_x"], "1" - ) - self.add_setting( - config, ["namelist:partitioning(source)", "tile_size_y"], "1" - ) + if config.get(["namelist:multigrid)"]) is not None: self.add_setting( config, ["namelist:multigrid", "coarsen_multigrid_tiles"], - ".false.", + ".false." ) self.add_setting( config, ["namelist:multigrid", "max_tiled_multigrid_level"], "1" From 6f9cdc40e214326f31eca255d74d796ad8149fb1 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Fri, 1 May 2026 10:30:19 +0100 Subject: [PATCH 37/44] Update some breakages from mergin on head on main --- .../lfric-driver/HEAD/rose-meta.conf | 2 +- .../lfric_xios_temporal_interp_test.f90 | 22 ++++++++++++++----- 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf index 9d4050bcc..ba81de28b 100644 --- a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf @@ -657,7 +657,7 @@ fail-if=this < 0 ; help=?????? =?????? !kind=default -range=1: +range=0: sort-key=Panel-A02 type=integer diff --git a/components/lfric-xios/integration-test/lfric_xios_temporal_interp_test.f90 b/components/lfric-xios/integration-test/lfric_xios_temporal_interp_test.f90 index 1d0122a23..6a3c5bcac 100644 --- a/components/lfric-xios/integration-test/lfric_xios_temporal_interp_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_temporal_interp_test.f90 @@ -8,7 +8,7 @@ ! program lfric_xios_temporal_interp_test - use constants_mod, only: i_timestep, r_second + use constants_mod, only: i_timestep, r_second, r_def, i_def use event_mod, only: event_action use event_actor_mod, only: event_actor_type use field_mod, only: field_type, field_proxy_type @@ -38,9 +38,19 @@ program lfric_xios_temporal_interp_test type(xios_date) :: date integer(i_timestep) :: file_freq + integer(i_def) :: geometry + integer(i_def) :: topology + integer(i_def) :: coord_system + real(r_def) :: scaled_radius + call test_db%initialise() call lfric_xios_initialise( "test", test_db%comm, .false. ) + geometry = test_db%config%base_mesh%geometry() + topology = test_db%config%base_mesh%topology() + coord_system = test_db%config%finite_element%coord_system() + scales_radius = test_db%config%planet%scaled_radius() + ! =============================== Start test ================================ allocate(io_context) @@ -66,11 +76,11 @@ program lfric_xios_temporal_interp_test fields_in_file=test_db%temporal_fields ) ) before_close => null() - call io_context%initialise_xios_context( test_db%comm, & - test_db%chi, test_db%panel_id, & - test_db%clock, test_db%calendar, & - before_close ) - + call io_context%initialise_xios_context( test_db%comm, & + test_db%chi, test_db%panel_id, & + test_db%clock, test_db%calendar, & + before_close, geometry, topology, & + coord_system, scaled_radius ) context_advance => advance context_actor => io_context From be3a8c3353c4fc8f8ae48ca839a20f330786b069 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Fri, 1 May 2026 11:22:58 +0100 Subject: [PATCH 38/44] Tweaks --- .../driver/rose-meta/lfric-driver/HEAD/rose-meta.conf | 3 +-- components/driver/rose-meta/lfric-driver/versions.py | 2 +- rose-stem/app/lbc_demo/opt/rose-app-mesh_lbc_demo.conf | 6 +++--- 3 files changed, 5 insertions(+), 6 deletions(-) diff --git a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf index ba81de28b..d37eee3a7 100644 --- a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf @@ -707,8 +707,7 @@ help=Tiling inner halos separately from the partition interior guarantees =which can be useful when overlapping communication and computation. !kind=default sort-key=Panel-A08 -trigger=namelist:multigrid=coarsen_multigrid_tiles: .true. ; - =namelist:partitioning=tile_size_x: .true. ; +trigger=namelist:partitioning=tile_size_x: .true. ; =namelist:partitioning=tile_size_y: .true. ; type=logical diff --git a/components/driver/rose-meta/lfric-driver/versions.py b/components/driver/rose-meta/lfric-driver/versions.py index 451b2b61f..448096a04 100644 --- a/components/driver/rose-meta/lfric-driver/versions.py +++ b/components/driver/rose-meta/lfric-driver/versions.py @@ -53,7 +53,7 @@ def upgrade(self, config, meta_config=None): config, ["namelist:partitioning", "tile_size_y"], "1" ) - if config.get(["namelist:multigrid)"]) is not None: + if config.get(["namelist:formulation","l_multigrid"])) is not None: self.add_setting( config, ["namelist:multigrid", "coarsen_multigrid_tiles"], diff --git a/rose-stem/app/lbc_demo/opt/rose-app-mesh_lbc_demo.conf b/rose-stem/app/lbc_demo/opt/rose-app-mesh_lbc_demo.conf index 5225b2288..009f0da92 100644 --- a/rose-stem/app/lbc_demo/opt/rose-app-mesh_lbc_demo.conf +++ b/rose-stem/app/lbc_demo/opt/rose-app-mesh_lbc_demo.conf @@ -5,8 +5,8 @@ source=$MESH_DIR/mesh_lbc_demo.nc [namelist:base_mesh] file_prefix='mesh_lbc_demo' geometry='spherical' -prepartitioned=.true., -prime_mesh_name='primary', -topology='non_periodic', +prepartitioned=.true. +prime_mesh_name='primary' +topology='non_periodic' [!!namelist:partitioning] From e55befbcf0cc9ba54036350c95394e389eabf38d Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Fri, 1 May 2026 11:27:50 +0100 Subject: [PATCH 39/44] typo --- components/driver/rose-meta/lfric-driver/versions.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components/driver/rose-meta/lfric-driver/versions.py b/components/driver/rose-meta/lfric-driver/versions.py index 448096a04..41d6dad21 100644 --- a/components/driver/rose-meta/lfric-driver/versions.py +++ b/components/driver/rose-meta/lfric-driver/versions.py @@ -53,7 +53,7 @@ def upgrade(self, config, meta_config=None): config, ["namelist:partitioning", "tile_size_y"], "1" ) - if config.get(["namelist:formulation","l_multigrid"])) is not None: + if config.get(["namelist:formulation","l_multigrid"]) is not None: self.add_setting( config, ["namelist:multigrid", "coarsen_multigrid_tiles"], From 3c135d4b1e4740de053ccfa5c15e59fd957a314d Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Fri, 1 May 2026 13:23:33 +0100 Subject: [PATCH 40/44] update --- .../driver/rose-meta/lfric-driver/HEAD/rose-meta.conf | 10 ---------- components/driver/rose-meta/lfric-driver/versions.py | 7 +++---- 2 files changed, 3 insertions(+), 14 deletions(-) diff --git a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf index d37eee3a7..4e1fa8b1c 100644 --- a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf @@ -52,7 +52,6 @@ type=integer # PRIMARY GLOBAL MESH #============================================================================== [namelist:base_mesh] -compulsory=true description=Provides information to define the LFRic infrastructure principle mesh. help=Lfric must use at least one mesh (prime) to run. =This panel specifies details of the mesh and its @@ -186,7 +185,6 @@ values='fully_periodic', 'non_periodic' # 2D MESH EXTRUSION #============================================================================== [namelist:extrusion] -compulsory=true description=Settings for the selected vertical mesh extrusion method. help=Settings for the uniform, quadratic, geometric and DCMIP mesh extrusion =profiles to extrude 2D to 3D mesh using non-dimensional vertical coordinate. @@ -305,7 +303,6 @@ values='linear', 'smooth' # FINITE ELEMENT #============================================================================== [namelist:finite_element] -compulsory=true description=Settings to define the choice of finite elements used help=Settings to define which finite elements create the function spaces used =in the model @@ -416,7 +413,6 @@ type=logical # IO #============================================================================== [namelist:io] -compulsory=true description=Sets I/O options for diagnostic output, checkpointing and dumps help=?????? ns=namelist/Job/IO @@ -568,7 +564,6 @@ type=logical # SYSTEM LOGGING #============================================================================== [namelist:logging] -compulsory=true ns=namelist/Job/IO/System [namelist:logging=log_to_rank_zero_only] @@ -607,7 +602,6 @@ values='error','warning','info','debug','trace' # MULTIGRID #============================================================================== [namelist:multigrid] -compulsory=true description=?????? help=?????? =?????? @@ -681,7 +675,6 @@ type=real # GLOBAL MESH PARTITIONING #============================================================================== [namelist:partitioning] -compulsory=true description=Global mesh panel partitioning. help=For parallel computing, the 2D global mesh is divided up into partitions. =Each process rank runs an instance of the model on one partition. The @@ -804,7 +797,6 @@ type=integer # PLANET #============================================================================== [namelist:planet] -compulsory=true description=?????? help=?????? =?????? @@ -832,7 +824,6 @@ type=real # TIME CONTROL #============================================================================== [namelist:time] -compulsory=true description=Time options help=At the moment, this just sets the start and end timestep for the run ns=namelist/Job/Time @@ -886,7 +877,6 @@ type=character # TIMESTEPPING #============================================================================== [namelist:timestepping] -compulsory=true description=?????? help=?????? =?????? diff --git a/components/driver/rose-meta/lfric-driver/versions.py b/components/driver/rose-meta/lfric-driver/versions.py index 41d6dad21..0af34799b 100644 --- a/components/driver/rose-meta/lfric-driver/versions.py +++ b/components/driver/rose-meta/lfric-driver/versions.py @@ -32,7 +32,7 @@ def upgrade(self, config, meta_config=None): class vn31_t324(MacroUpgrade): - """Upgrade macro for LFRic Core PR#324 by Ricky Wong""" + """Upgrade macro for ticket TTTT by Unknown.""" BEFORE_TAG = "vn3.1" AFTER_TAG = "vn3.1_t324" @@ -52,12 +52,11 @@ def upgrade(self, config, meta_config=None): self.add_setting( config, ["namelist:partitioning", "tile_size_y"], "1" ) - - if config.get(["namelist:formulation","l_multigrid"]) is not None: + if config.get(["namelist:multigrid"]) is not None: self.add_setting( config, ["namelist:multigrid", "coarsen_multigrid_tiles"], - ".false." + ".false.", ) self.add_setting( config, ["namelist:multigrid", "max_tiled_multigrid_level"], "1" From ea62f921ee116bb565733e1526b4f07c25569e27 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Fri, 1 May 2026 14:30:40 +0100 Subject: [PATCH 41/44] Update metadata and macro so that unecessary namlists are not injected --- components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf | 1 + components/driver/rose-meta/lfric-driver/vn3.1/rose-meta.conf | 1 - rose-stem/app/coupled/rose-app.conf | 4 ---- rose-stem/app/io_demo/rose-app.conf | 4 ---- rose-stem/app/simple_diffusion/rose-app.conf | 4 ---- rose-stem/app/skeleton/rose-app.conf | 4 ---- 6 files changed, 1 insertion(+), 17 deletions(-) diff --git a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf index 4e1fa8b1c..41f91dc76 100644 --- a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf @@ -603,6 +603,7 @@ values='error','warning','info','debug','trace' #============================================================================== [namelist:multigrid] description=?????? +compulsory=false help=?????? =?????? ns=namelist/Science/Dynamics/multigrid diff --git a/components/driver/rose-meta/lfric-driver/vn3.1/rose-meta.conf b/components/driver/rose-meta/lfric-driver/vn3.1/rose-meta.conf index 980ecd18b..754acdcb8 100644 --- a/components/driver/rose-meta/lfric-driver/vn3.1/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/vn3.1/rose-meta.conf @@ -607,7 +607,6 @@ values='error','warning','info','debug','trace' # MULTIGRID #============================================================================== [namelist:multigrid] -compulsory=true description=?????? help=?????? =?????? diff --git a/rose-stem/app/coupled/rose-app.conf b/rose-stem/app/coupled/rose-app.conf index 38b1839b6..e9531bc67 100644 --- a/rose-stem/app/coupled/rose-app.conf +++ b/rose-stem/app/coupled/rose-app.conf @@ -70,10 +70,6 @@ write_diag=.false. log_to_rank_zero_only=.false. run_log_level='info' -[namelist:multigrid] -chain_mesh_tags='' -multigrid_chain_nitems=1 - [namelist:partitioning] generate_inner_halos=.true. panel_decomposition='auto' diff --git a/rose-stem/app/io_demo/rose-app.conf b/rose-stem/app/io_demo/rose-app.conf index 5f7f0e7ca..2bb6f1221 100644 --- a/rose-stem/app/io_demo/rose-app.conf +++ b/rose-stem/app/io_demo/rose-app.conf @@ -79,10 +79,6 @@ multifile_io=.false. log_to_rank_zero_only=.false. run_log_level='info' -[namelist:multigrid] -chain_mesh_tags='' -multigrid_chain_nitems=1 - [namelist:partitioning] generate_inner_halos=.false. panel_decomposition='auto' diff --git a/rose-stem/app/simple_diffusion/rose-app.conf b/rose-stem/app/simple_diffusion/rose-app.conf index f710dfe34..09600a626 100644 --- a/rose-stem/app/simple_diffusion/rose-app.conf +++ b/rose-stem/app/simple_diffusion/rose-app.conf @@ -71,10 +71,6 @@ write_diag=.false. log_to_rank_zero_only=.false. run_log_level='info' -[namelist:multigrid] -chain_mesh_tags='' -multigrid_chain_nitems=1 - [namelist:partitioning] generate_inner_halos=.true. panel_decomposition='auto' diff --git a/rose-stem/app/skeleton/rose-app.conf b/rose-stem/app/skeleton/rose-app.conf index 7e966d0b7..11307c9d3 100644 --- a/rose-stem/app/skeleton/rose-app.conf +++ b/rose-stem/app/skeleton/rose-app.conf @@ -68,10 +68,6 @@ write_diag=.false. log_to_rank_zero_only=.false. run_log_level='info' -[namelist:multigrid] -chain_mesh_tags='' -multigrid_chain_nitems=1 - [namelist:partitioning] generate_inner_halos=.true. panel_decomposition='auto' From c2753421e72af2eb41fd65a01f2eca8a232eb2a1 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Fri, 1 May 2026 14:37:07 +0100 Subject: [PATCH 42/44] Update versions.py after app macros modified it --- components/driver/rose-meta/lfric-driver/versions.py | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/components/driver/rose-meta/lfric-driver/versions.py b/components/driver/rose-meta/lfric-driver/versions.py index 0af34799b..62eead4b2 100644 --- a/components/driver/rose-meta/lfric-driver/versions.py +++ b/components/driver/rose-meta/lfric-driver/versions.py @@ -32,7 +32,7 @@ def upgrade(self, config, meta_config=None): class vn31_t324(MacroUpgrade): - """Upgrade macro for ticket TTTT by Unknown.""" + """Upgrade macro for LFRic Core PR#324 by Ricky Wong.""" BEFORE_TAG = "vn3.1" AFTER_TAG = "vn3.1_t324" @@ -55,8 +55,7 @@ def upgrade(self, config, meta_config=None): if config.get(["namelist:multigrid"]) is not None: self.add_setting( config, - ["namelist:multigrid", "coarsen_multigrid_tiles"], - ".false.", + ["namelist:multigrid", "coarsen_multigrid_tiles"], ".false." ) self.add_setting( config, ["namelist:multigrid", "max_tiled_multigrid_level"], "1" From b2c37c9749d160eb9f86273582ae3b6aabd2adc7 Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Fri, 1 May 2026 15:11:50 +0100 Subject: [PATCH 43/44] typo --- .../integration-test/lfric_xios_temporal_interp_test.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components/lfric-xios/integration-test/lfric_xios_temporal_interp_test.f90 b/components/lfric-xios/integration-test/lfric_xios_temporal_interp_test.f90 index 6a3c5bcac..ca1ea7b90 100644 --- a/components/lfric-xios/integration-test/lfric_xios_temporal_interp_test.f90 +++ b/components/lfric-xios/integration-test/lfric_xios_temporal_interp_test.f90 @@ -49,7 +49,7 @@ program lfric_xios_temporal_interp_test geometry = test_db%config%base_mesh%geometry() topology = test_db%config%base_mesh%topology() coord_system = test_db%config%finite_element%coord_system() - scales_radius = test_db%config%planet%scaled_radius() + scaled_radius = test_db%config%planet%scaled_radius() ! =============================== Start test ================================ From dce3a6c69a9294cc22b334c375937c5db615bf8d Mon Sep 17 00:00:00 2001 From: Ricky Wong <141156427+mo-rickywong@users.noreply.github.com> Date: Sat, 2 May 2026 14:15:22 +0100 Subject: [PATCH 44/44] Remove explict false --- components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf | 1 - 1 file changed, 1 deletion(-) diff --git a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf index 41f91dc76..4e1fa8b1c 100644 --- a/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf +++ b/components/driver/rose-meta/lfric-driver/HEAD/rose-meta.conf @@ -603,7 +603,6 @@ values='error','warning','info','debug','trace' #============================================================================== [namelist:multigrid] description=?????? -compulsory=false help=?????? =?????? ns=namelist/Science/Dynamics/multigrid