diff --git a/changelog b/changelog index c0f257dd50..ee7b590ca1 100644 --- a/changelog +++ b/changelog @@ -55,6 +55,12 @@ 19) PR #2885. Update integration test dependencies. + 20) PR #2799 for #2779. Implement split finite-element order for + function spaces in the LFRic API and update Adjoint tests to use it. + + 21) PR #2883 for #2875. Fix issues cannonicalising WHEREs with elemental + functions. + release 3.0.0 6th of December 2024 1) PR #2477 for #2463. Add support for Fortran Namelist statements. diff --git a/doc/user_guide/psyclone_kern.rst b/doc/user_guide/psyclone_kern.rst index 98a29abac9..1b39a31b45 100644 --- a/doc/user_guide/psyclone_kern.rst +++ b/doc/user_guide/psyclone_kern.rst @@ -32,7 +32,7 @@ .. POSSIBILITY OF SUCH DAMAGE. .. ----------------------------------------------------------------------------- .. Written by R. W. Ford and A. R. Porter, STFC Daresbury Lab -.. Modified by I. Kavcic and L. Turner, Met Office +.. Modified by I. Kavcic, L. Turner and J. Dendy, Met Office PSyclone Kernel Tools ===================== @@ -558,14 +558,15 @@ gives the following algorithm layer code: use mesh_mod, only : mesh_type use simple_mod, only : simple_type use constants_mod, only : i_def, r_def - integer(kind=i_def), parameter :: element_order = 1_i_def + integer(kind=i_def), parameter :: element_order_h = 1_i_def + integer(kind=i_def), parameter :: element_order_v = 1_i_def type(mesh_type), pointer, intent(in) :: mesh type(field_type), dimension(3), intent(in), optional :: chi type(field_type), intent(in), optional :: panel_id TYPE(function_space_type), POINTER :: vector_space_w1_ptr type(field_type) :: field_1 - vector_space_w1_ptr => function_space_collection % get_fs(mesh, element_order, w1) + vector_space_w1_ptr => function_space_collection % get_fs(mesh, element_order_h, element_order_v, w1) call field_1 % initialise(vector_space=vector_space_w1_ptr, name='field_1') call invoke(setval_c(field_1, 1.0_r_def), simple_type(field_1)) diff --git a/doc/user_guide/transformations.rst b/doc/user_guide/transformations.rst index 635773d51f..c0fff95ace 100644 --- a/doc/user_guide/transformations.rst +++ b/doc/user_guide/transformations.rst @@ -34,6 +34,7 @@ .. Written by: R. W. Ford, A. R. Porter and S. Siso, STFC Daresbury Lab .. A. B. G. Chalk and N. Nobre, STFC Daresbury Lab .. I. Kavcic, Met Office +.. J. Dendy, Met Office .. _transformations: @@ -216,7 +217,7 @@ process, optional parameters for the transformation are also provided this way. A simple example:: kctrans = Dynamo0p3KernelConstTrans() - kctrans.apply(kernel, {"element_order": 0, "quadrature": True}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0, "quadrature": True}) The same ``options`` dictionary will be used when calling ``validate``. @@ -287,19 +288,19 @@ can be found in the API-specific sections). .. autoclass:: psyclone.psyir.transformations.AllArrayAccess2LoopTrans :members: apply :noindex: - + #### .. autoclass:: psyclone.psyir.transformations.ArrayAccess2LoopTrans :members: apply :noindex: - + #### .. autoclass:: psyclone.psyir.transformations.ArrayAssignment2LoopsTrans :members: apply :noindex: - + #### .. autoclass:: psyclone.psyir.transformations.ChunkLoopTrans @@ -802,7 +803,7 @@ PSyclone supports OpenMP Tasking, through the `OMPTaskloopTrans` and transformations can be applied to loops, whilst the `OMPTaskwaitTrans` operator is applied to an OpenMP Parallel Region, and computes the dependencies caused by Taskloops, and adds OpenMP Taskwait statements to satisfy those -dependencies. An example of using OpenMP tasking is available in +dependencies. An example of using OpenMP tasking is available in `PSyclone/examples/nemo/eg1/openmp_taskloop_trans.py`. OpenCL diff --git a/examples/lfric/code/gw_mixed_schur_preconditioner_alg_mod.x90 b/examples/lfric/code/gw_mixed_schur_preconditioner_alg_mod.x90 index 476e8487fe..e0c4b43d9a 100644 --- a/examples/lfric/code/gw_mixed_schur_preconditioner_alg_mod.x90 +++ b/examples/lfric/code/gw_mixed_schur_preconditioner_alg_mod.x90 @@ -38,6 +38,7 @@ ! ----------------------------------------------------------------------------- ! Modified by I. Kavcic, Met Office ! Modified by R. W. Ford, STFC Daresbury Lab +! Modified by J. Dendy, Met Office !>@brief Preconditioner for the gravity-wave system module gw_mixed_schur_preconditioner_alg_mod @@ -125,7 +126,6 @@ contains result(self) use function_space_mod, only: function_space_type - use finite_element_config_mod, only: element_order use quadrature_xyoz_mod, only: quadrature_xyoz_type use quadrature_rule_gaussian_mod, only: quadrature_rule_gaussian_type use matrix_vector_kernel_mod, only: matrix_vector_kernel_type diff --git a/examples/lfric/eg13/kernel_constants.py b/examples/lfric/eg13/kernel_constants.py index 5c31443053..fefbdf0835 100644 --- a/examples/lfric/eg13/kernel_constants.py +++ b/examples/lfric/eg13/kernel_constants.py @@ -32,6 +32,7 @@ # POSSIBILITY OF SUCH DAMAGE. # ----------------------------------------------------------------------------- # Authors: R. W. Ford, N. Nobre and S. Siso, STFC Daresbury Lab +# Modified by: J. Dendy, Met Office '''An example PSyclone transformation script which makes ndofs, nqp* @@ -62,10 +63,11 @@ # associated kernel value constant (rather than passing it in by # argument). NUMBER_OF_LAYERS = 20 -# The element order to use when modifying a kernel to make the +# The element orders to use when modifying a kernel to make the # associated degrees of freedom values constant (rather than passing # them in by argument). -ELEMENT_ORDER = 0 +ELEMENT_ORDER_H = 0 +ELEMENT_ORDER_V = 0 # Whether or not to make the number of quadrature points constant in a # kernel (rather than passing them in by argument). CONSTANT_QUADRATURE = True @@ -86,7 +88,8 @@ def trans(psyir): try: const_trans.apply(kernel, {"number_of_layers": NUMBER_OF_LAYERS, - "element_order": ELEMENT_ORDER, + "element_order_h": ELEMENT_ORDER_H, + "element_order_v": ELEMENT_ORDER_V, "quadrature": CONSTANT_QUADRATURE}) except TransformationError: print(f" Failed to modify kernel '{kernel.name}'") diff --git a/examples/lfric/eg14/main.x90 b/examples/lfric/eg14/main.x90 index 76d1843f4b..78a880ae03 100644 --- a/examples/lfric/eg14/main.x90 +++ b/examples/lfric/eg14/main.x90 @@ -30,6 +30,7 @@ ! ----------------------------------------------------------------------------- ! Author: J. Henrichs, Bureau of Meteorology ! Modifications: A. R. Porter, STFC Daresbury Laboratory +! J. Dendy, Met Office program main @@ -57,7 +58,8 @@ program main procedure (partitioner_interface), pointer :: partitioner_ptr type(field_type) :: field1, field2 integer(kind=i_def) :: lfric_fs = W0 ! W0 - integer(kind=i_def) :: element_order = 1 + integer(kind=i_def) :: element_order_h = 1 + integer(kind=i_def) :: element_order_v = 1 integer(kind=i_def) :: ndata_sz, istp real(kind=r_def) :: chksm @@ -84,9 +86,10 @@ program main mesh = mesh_type(global_mesh_ptr, partition, extrusion_ptr) write (*,*) "Mesh has", mesh%get_nlayers(), "layers." ndata_sz = 1 - vector_space = function_space_type( mesh, & - element_order, & - lfric_fs, & + vector_space = function_space_type( mesh, & + element_order_h, & + element_order_v, & + lfric_fs, & ndata_sz) vector_space_ptr => vector_space call field1%initialise( vector_space = vector_space_ptr, name="field1" ) diff --git a/examples/lfric/eg17/full_example/README.md b/examples/lfric/eg17/full_example/README.md index 5726cfc0df..52170c4022 100644 --- a/examples/lfric/eg17/full_example/README.md +++ b/examples/lfric/eg17/full_example/README.md @@ -9,7 +9,7 @@ The following steps are required for this (using simplified code examples): ```fortran global_mesh = global_mesh_type() ``` - + 2) A 1x1 planar partition for one process is created: ```fortran partitioner_ptr => partitioner_planar @@ -34,9 +34,10 @@ The following steps are required for this (using simplified code examples): 5) Create a function/vector space: ```fortran - vector_space = function_space_type( mesh, & - element_order, & - lfric_fs, & + vector_space = function_space_type( mesh, & + element_order_h, & + element_order_v, & + lfric_fs, & ndata_sz) ``` diff --git a/examples/lfric/eg17/full_example/main.x90 b/examples/lfric/eg17/full_example/main.x90 index 636bc8dce0..d6e8595530 100644 --- a/examples/lfric/eg17/full_example/main.x90 +++ b/examples/lfric/eg17/full_example/main.x90 @@ -30,6 +30,7 @@ ! ----------------------------------------------------------------------------- ! Author: J. Henrichs, Bureau of Meteorology ! Modifications: A. R. Porter, STFC Daresbury Laboratory +! J. Dendy, Met Office program main @@ -57,7 +58,8 @@ program main procedure (partitioner_interface), pointer :: partitioner_ptr type(field_type) :: field1, field2 integer(kind=i_def) :: lfric_fs = W0 ! W0 - integer(kind=i_def) :: element_order = 1 + integer(kind=i_def) :: element_order_h = 1 + integer(kind=i_def) :: element_order_v = 1 integer(kind=i_def) :: ndata_sz ! Use the unit-testing constructor: @@ -81,9 +83,10 @@ program main mesh = mesh_type(global_mesh_ptr, partition, extrusion_ptr) write (*,*) "Mesh has", mesh%get_nlayers(), "layers." ndata_sz = 1 - vector_space = function_space_type( mesh, & - element_order, & - lfric_fs, & + vector_space = function_space_type( mesh, & + element_order_h, & + element_order_v, & + lfric_fs, & ndata_sz) vector_space_ptr => vector_space call field1%initialise( vector_space = vector_space_ptr, name="field1" ) diff --git a/examples/lfric/eg17/full_example_extract/main.X90 b/examples/lfric/eg17/full_example_extract/main.X90 index 34aa2e0e73..b710f052d6 100644 --- a/examples/lfric/eg17/full_example_extract/main.X90 +++ b/examples/lfric/eg17/full_example_extract/main.X90 @@ -30,6 +30,7 @@ ! ----------------------------------------------------------------------------- ! Author: J. Henrichs, Bureau of Meteorology ! Modifications: A. R. Porter, STFC Daresbury Laboratory +! J. Dendy, Met Office program main !> This program is a simple LFRic program that contains two invokes, @@ -70,7 +71,8 @@ program main type(field_type) :: field1, field2 type(field_type) :: chi(3) integer(kind=i_def) :: lfric_fs = W0 ! W0 - integer(kind=i_def) :: element_order = 1 + integer(kind=i_def) :: element_order_h = 1 + integer(kind=i_def) :: element_order_v = 1 integer(kind=i_def) :: ndata_sz real(kind=r_def) :: one logical(kind=l_def) :: some_logical @@ -101,9 +103,10 @@ program main mesh = mesh_type(global_mesh_ptr, partition, extrusion_ptr) write (*,*) "Mesh has", mesh%get_nlayers(), "layers." ndata_sz = 1 - vector_space = function_space_type( mesh, & - element_order, & - lfric_fs, & + vector_space = function_space_type( mesh, & + element_order_h, & + element_order_v, & + lfric_fs, & ndata_sz) vector_space_ptr => vector_space do i=1, 3 diff --git a/examples/lfric/eg17/full_example_netcdf/README.md b/examples/lfric/eg17/full_example_netcdf/README.md index d484d626b8..8a07d3c6bf 100644 --- a/examples/lfric/eg17/full_example_netcdf/README.md +++ b/examples/lfric/eg17/full_example_netcdf/README.md @@ -9,7 +9,7 @@ steps are required for this (using simplified code examples): ```fortran global_mesh = global_mesh_type("mesh_BiP128x16-400x100.nc", "dynamics") ``` - + 2) A 1x1 planar partition for one process is created: ```fortran partitioner_ptr => partitioner_planar @@ -34,9 +34,10 @@ steps are required for this (using simplified code examples): 5) Create a function/vector space: ```fortran - vector_space = function_space_type( mesh, & - element_order, & - lfric_fs, & + vector_space = function_space_type( mesh, & + element_order_h, & + element_order_v, & + lfric_fs, & ndata_sz) ``` @@ -61,7 +62,7 @@ steps are required for this (using simplified code examples): ## Compilation -A simple makefile is provided to compile the example. It needs +A simple makefile is provided to compile the example. It needs a full installation of NetCDF, since it is using ``nf-config`` to query the required compiler and linker flags, and the infrastructure library ``liblfric_netcdf.a`` provided in diff --git a/examples/lfric/eg17/full_example_netcdf/main.x90 b/examples/lfric/eg17/full_example_netcdf/main.x90 index bca4e483de..f6845d515f 100644 --- a/examples/lfric/eg17/full_example_netcdf/main.x90 +++ b/examples/lfric/eg17/full_example_netcdf/main.x90 @@ -30,6 +30,7 @@ ! ----------------------------------------------------------------------------- ! Author: J. Henrichs, Bureau of Meteorology ! Modifications: A. R. Porter, STFC Daresbury Laboratory +! J. Dendy, Met Office program main @@ -58,7 +59,8 @@ program main procedure (partitioner_interface), pointer :: partitioner_ptr type(field_type) :: field1, field2 integer(kind=i_def) :: lfric_fs = W0 ! W0 - integer(kind=i_def) :: element_order = 1 + integer(kind=i_def) :: element_order_h = 1 + integer(kind=i_def) :: element_order_v = 1 integer(kind=i_def) :: ndata_sz ! Use the unit-testing constructor: @@ -82,9 +84,10 @@ program main mesh = mesh_type(global_mesh_ptr, partition, extrusion_ptr) write (*,*) "Mesh has", mesh%get_nlayers(), "layers." ndata_sz = 1 - vector_space = function_space_type( mesh, & - element_order, & - lfric_fs, & + vector_space = function_space_type( mesh, & + element_order_h, & + element_order_v, & + lfric_fs, & ndata_sz) vector_space_ptr => vector_space call field1%initialise( vector_space = vector_space_ptr, name="field1" ) diff --git a/examples/lfric/eg4/solver_mod.x90 b/examples/lfric/eg4/solver_mod.x90 index af68eb0b87..774322b38f 100644 --- a/examples/lfric/eg4/solver_mod.x90 +++ b/examples/lfric/eg4/solver_mod.x90 @@ -38,6 +38,7 @@ ! ----------------------------------------------------------------------------- ! Modified by A. Porter, STFC Daresbury Lab ! Modified by I. Kavcic, Met Office +! J. Dendy, Met Office ! !> @brief Contains methods and algorithms for solving a system A.x = b for known !! input field b and matrix A and returns field x @@ -51,7 +52,7 @@ module solver_mod use constants_mod, only : r_def, str_def, i_def use function_space_collection_mod, only : function_space_collection use field_mod, only : field_type - use finite_element_config_mod, only : element_order + use finite_element_config_mod, only : element_order_h, element_order_v use fs_continuity_mod, only : W3 use function_space_mod, only : function_space_type use log_mod, only : log_event, & @@ -121,8 +122,9 @@ subroutine jacobi_solver_algorithm(lhs, rhs, mm, mesh, n_iter) flag_obj%rflag = 0.0_r_def - rhs_fs => function_space_collection%get_fs( mesh, & - element_order, & + rhs_fs => function_space_collection%get_fs( mesh, & + element_order_h, & + element_order_v, & rhs%which_function_space() ) diagonal = field_type( vector_space = rhs_fs ) diff --git a/examples/lfric/eg5/alg.f90 b/examples/lfric/eg5/alg.f90 index 7fb738cc22..8291fe3024 100644 --- a/examples/lfric/eg5/alg.f90 +++ b/examples/lfric/eg5/alg.f90 @@ -39,6 +39,7 @@ ! POSSIBILITY OF SUCH DAMAGE. !------------------------------------------------------------------------------ ! Modified by I. Kavcic, Met Office +! J. Dendy, Met Office module oned_conservative_flux_alg_mod @@ -48,7 +49,8 @@ module oned_conservative_flux_alg_mod use function_space_collection_mod, only: function_space_collection use quadrature_mod, only: quadrature_type, GAUSSIAN use fs_continuity_mod, only: W0, W3 - use finite_element_config_mod, only: element_order + use finite_element_config_mod, only: element_order_h, & + element_order_v use subgrid_config_mod, only: transport_stencil_length, & rho_stencil_length @@ -81,8 +83,9 @@ subroutine oned_conservative_flux_alg( direction, & type(function_space_type), pointer :: rho_fs => null() - rho_fs => function_space_collection%get_fs( mesh_id, element_order, & - rho_in%which_function_space() ) + rho_fs => function_space_collection%get_fs( mesh_id, element_order_h, & + element_order_v, & + rho_in%which_function_space() ) a0 = field_type( vector_space = rho_fs ) a1 = field_type( vector_space = rho_fs ) diff --git a/examples/lfric/eg9/advective_inc_alg_mod.x90 b/examples/lfric/eg9/advective_inc_alg_mod.x90 index 1da18f87f2..bf86a8345c 100644 --- a/examples/lfric/eg9/advective_inc_alg_mod.x90 +++ b/examples/lfric/eg9/advective_inc_alg_mod.x90 @@ -39,6 +39,7 @@ ! ----------------------------------------------------------------------------- ! Modified by: I. Kavcic, Met Office ! A. R. Porter, STFC Daresbury Laboratory +! J. Dendy, Met Office !>@brief Computes the advective increment of the prognostic equations module advective_inc_alg_mod @@ -47,7 +48,8 @@ module advective_inc_alg_mod use constants_mod, only: r_def, i_def ! Configuration and restart/checkpoint options - use finite_element_config_mod, only: element_order, wtheta_on + use finite_element_config_mod, only: element_order_h, element_order_v, & + wtheta_on use runtime_constants_mod, only: get_coordinates, & get_inverse_lumped_mass_matrix, & theta_space_id @@ -113,7 +115,8 @@ contains case(transport_operators_fem) ! Use project u.grad(theta) into the theta function space - qr = quadrature_xyoz_type(element_order+3, quadrature_rule) + qr = quadrature_xyoz_type(MAX(element_order_h, element_order_v)+3, & + quadrature_rule) ! Quadrature rule on lateral faces only qrf = quadrature_face_type(nqp_exact, .true., .false., & reference_element, quadrature_rule) diff --git a/examples/lfric/scripts/KGOs/lfric_gungho_configuration_4its.nml b/examples/lfric/scripts/KGOs/lfric_gungho_configuration_4its.nml index 21aaa236ca..b70634ff17 100644 --- a/examples/lfric/scripts/KGOs/lfric_gungho_configuration_4its.nml +++ b/examples/lfric/scripts/KGOs/lfric_gungho_configuration_4its.nml @@ -27,7 +27,8 @@ stretching_method='linear', &finite_element cellshape = 'quadrilateral' - element_order = 0 + element_order_h = 0 + element_order_v = 0 rehabilitate = .true. vorticity_in_w1 = .false. coord_order = 1 diff --git a/psyclone.pdf b/psyclone.pdf index a5b96aebda..d402036938 100644 Binary files a/psyclone.pdf and b/psyclone.pdf differ diff --git a/src/psyclone/domain/lfric/algorithm/lfric_alg.py b/src/psyclone/domain/lfric/algorithm/lfric_alg.py index 4d81d1e9e9..148c3e4f9c 100644 --- a/src/psyclone/domain/lfric/algorithm/lfric_alg.py +++ b/src/psyclone/domain/lfric/algorithm/lfric_alg.py @@ -35,6 +35,7 @@ # Modified by: R. W. Ford, STFC Daresbury Laboratory. # L. Turner, Met Office # T. Vockerodt, Met Office +# J. Dendy, Met Office '''This module contains the LFRicAlg class which encapsulates tools for creating standalone LFRic algorithm-layer code. @@ -240,7 +241,7 @@ def _create_function_spaces(self, prog, fspaces): ''' Adds PSyIR to the supplied Routine that declares and intialises the specified function spaces. The order of these spaces is - set by the element_order variable which is provided by the + set by the element_order_ variables which are provided by the LFRic finite_element_config_mod module. :param prog: the routine to which to add declarations and \ @@ -260,8 +261,12 @@ def _create_function_spaces(self, prog, fspaces): # The order of the finite-element scheme. fe_config_mod = table.new_symbol( "finite_element_config_mod", symbol_type=ContainerSymbol) - order = table.new_symbol( - "element_order", tag="element_order", + order_h = table.new_symbol( + "element_order_h", tag="element_order_h", + symbol_type=DataSymbol, datatype=UnresolvedType(), + interface=ImportInterface(fe_config_mod)) + order_v = table.new_symbol( + "element_order_v", tag="element_order_v", symbol_type=DataSymbol, datatype=UnresolvedType(), interface=ImportInterface(fe_config_mod)) @@ -292,7 +297,7 @@ def _create_function_spaces(self, prog, fspaces): cblock = reader.psyir_from_statement( f"{vsym_ptr.name} => function_space_collection%get_fs( mesh, " - f"{order.name}, {space})", table) + f"{order_h.name}, {order_v.name}, {space})", table) prog.addchild(cblock) @@ -395,9 +400,11 @@ def initialise_quadrature(prog, qr_sym, shape): datatype=qr_gaussian_type) if shape == "gh_quadrature_xyoz": - order = table.lookup_with_tag("element_order") + order_h = table.lookup_with_tag("element_order_h") + order_v = table.lookup_with_tag("element_order_v") expr = reader.psyir_from_expression( - f"quadrature_xyoz_type({order.name}+3, {qr_rule_sym.name})", + f"quadrature_xyoz_type(MAX({order_h.name},{order_v.name})+3, " + f"{qr_rule_sym.name})", table) prog.addchild(Assignment.create(Reference(qr_sym), expr)) diff --git a/src/psyclone/psyir/frontend/fparser2.py b/src/psyclone/psyir/frontend/fparser2.py index 7b84dd2027..633860cabc 100644 --- a/src/psyclone/psyir/frontend/fparser2.py +++ b/src/psyclone/psyir/frontend/fparser2.py @@ -4194,6 +4194,22 @@ def _array_syntax_to_indexed(self, parent, loop_vars): # ignore it. continue + # If it has a Call ancestor we need to check if its a + # non-elemental function, in which case we should skip + # changing it. + call_ancestor = array.ancestor(Call) + if call_ancestor: + if call_ancestor.is_elemental is None: + raise NotImplementedError( + f"Found a function call inside a where clause with " + f"unknown elemental status: " + f"{call_ancestor.debug_string()}") + # If it is none-elemental, we leave this array reference as it + # is + if not call_ancestor.is_elemental: + continue + # Otherwise, we continue replacing the range with the loop idx + if first_rank: if rank != first_rank: raise NotImplementedError( @@ -4389,13 +4405,18 @@ def _contains_intrinsic_reduction(pnodes): # regarding UnresolvedInterface and Elemental calls? references = fake_parent.walk(Reference) for ref in references: + call_ancestor = ref.ancestor(Call) + elemental_ancestor = (call_ancestor is None or + call_ancestor.is_elemental) + # TODO 2884: We should be able to handle this imported symbol + # better. If we can, we need to handle a case where is_elemental + # can be None. if isinstance(ref.symbol.interface, ImportInterface): raise NotImplementedError( "PSyclone doesn't yet support reference to imported " "symbols inside WHERE clauses.") - intrinsic_ancestor = ref.ancestor(IntrinsicCall) if (isinstance(ref.symbol, DataSymbol) and - not intrinsic_ancestor): + elemental_ancestor): try: Reference2ArrayRangeTrans().apply(ref) except TransformationError: diff --git a/src/psyclone/tests/domain/lfric/algorithm/lfric_alg_test.py b/src/psyclone/tests/domain/lfric/algorithm/lfric_alg_test.py index c7135b03c9..c300ccd28d 100644 --- a/src/psyclone/tests/domain/lfric/algorithm/lfric_alg_test.py +++ b/src/psyclone/tests/domain/lfric/algorithm/lfric_alg_test.py @@ -35,6 +35,7 @@ # Modified by: R. W. Ford, STFC Daresbury Lab # L. Turner, Met Office # T. Vockerodt, Met Office +# J. Dendy, Met Office ''' pytest tests for the LFRic-specific algorithm-generation functionality. ''' @@ -66,7 +67,7 @@ def setup(): @pytest.fixture(name="prog", scope="function") -def create_prog_fixture(parser): +def create_prog_fixture(): ''' :returns: a PSyIR Routine node representing a program. :rtype: :py:class:`psyclone.psyir.nodes.Routine` @@ -132,9 +133,12 @@ def test_create_function_spaces_no_spaces(prog): are no actual function spaces. ''' LFRicAlg()._create_function_spaces(prog, []) fe_config_mod = prog.symbol_table.lookup("finite_element_config_mod") - element_order = prog.symbol_table.lookup("element_order") - assert element_order.interface.container_symbol == fe_config_mod - assert prog.symbol_table.lookup("element_order") + element_order_h = prog.symbol_table.lookup("element_order_h") + element_order_v = prog.symbol_table.lookup("element_order_v") + assert element_order_h.interface.container_symbol == fe_config_mod + assert element_order_v.interface.container_symbol == fe_config_mod + assert prog.symbol_table.lookup("element_order_h") + assert prog.symbol_table.lookup("element_order_v") assert isinstance(prog.symbol_table.lookup("fs_continuity_mod"), ContainerSymbol) @@ -155,8 +159,10 @@ def test_create_function_spaces(prog, fortran_writer): # produce consistent ordering in the algorithm. LFRicAlg()._create_function_spaces(prog, set(["w3", "w1"])) fe_config_mod = prog.symbol_table.lookup("finite_element_config_mod") - element_order = prog.symbol_table.lookup("element_order") - assert element_order.interface.container_symbol == fe_config_mod + element_order_h = prog.symbol_table.lookup("element_order_h") + assert element_order_h.interface.container_symbol == fe_config_mod + element_order_v = prog.symbol_table.lookup("element_order_v") + assert element_order_v.interface.container_symbol == fe_config_mod fs_mod_sym = prog.symbol_table.lookup("fs_continuity_mod") gen = fortran_writer(prog) for space in ["w1", "w3"]: @@ -168,9 +174,9 @@ def test_create_function_spaces(prog, fortran_writer): "TYPE(function_space_type), POINTER :: " "vector_space_w3_ptr" in gen) assert ("vector_space_w1_ptr => function_space_collection%" - "get_fs(mesh,element_order,w1)\n " + "get_fs(mesh,element_order_h,element_order_v,w1)\n " "vector_space_w3_ptr => function_space_collection%" - "get_fs(mesh,element_order,w3)" in gen) + "get_fs(mesh,element_order_h,element_order_v,w3)" in gen) def test_initialise_field(prog, fortran_writer): @@ -213,7 +219,9 @@ def test_initialise_quadrature(prog, fortran_writer): ''' Tests for the initialise_quadrature function with the supported XYoZ shape. ''' table = prog.symbol_table - table.new_symbol("element_order", tag="element_order", + table.new_symbol("element_order_h", tag="element_order_h", + symbol_type=DataSymbol, datatype=INTEGER_TYPE) + table.new_symbol("element_order_v", tag="element_order_v", symbol_type=DataSymbol, datatype=INTEGER_TYPE) # Setup symbols that would normally be created in KernCallInvokeArgList. quad_container = table.new_symbol( @@ -231,7 +239,8 @@ def test_initialise_quadrature(prog, fortran_writer): assert qrule.datatype is qtype # Check that the constructor is called in the generated code. gen = fortran_writer(prog) - assert ("qr = quadrature_xyoz_type(element_order + 3,quadrature_rule)" + assert ("qr = quadrature_xyoz_type(MAX(element_order_h, element_order_v) " + "+ 3,quadrature_rule)" in gen) @@ -239,7 +248,9 @@ def test_initialise_quadrature_unsupported_shape(prog): ''' Test that the initialise_quadrature function raises the expected error for an unsupported quadrature shape. ''' table = prog.symbol_table - table.new_symbol("element_order", tag="element_order", + table.new_symbol("element_order_h", tag="element_order_h", + symbol_type=DataSymbol, datatype=INTEGER_TYPE) + table.new_symbol("element_order_v", tag="element_order_v", symbol_type=DataSymbol, datatype=INTEGER_TYPE) # Setup symbols that would normally be created in KernCallInvokeArgList. quad_container = table.new_symbol( @@ -323,11 +334,11 @@ def test_construct_kernel_args(prog, lfrickern, fortran_writer): for space in spaces: assert (f"vector_space_{space}_ptr => function_space_collection%" - f"get_fs(mesh,element_order,{space})" in gen) + f"get_fs(mesh,element_order_h,element_order_v,{space})" in gen) for idx in range(2, 7): assert f"call field_{idx}" in gen - assert ("qr_xyoz = quadrature_xyoz_type(element_order + 3," - "quadrature_rule)" in gen) + assert ("qr_xyoz = quadrature_xyoz_type(MAX(element_order_h, " + "element_order_v) + 3,quadrature_rule)" in gen) # TODO #240 - test for compilation. diff --git a/src/psyclone/tests/domain/lfric/transformations/dynamo0p3_transformations_test.py b/src/psyclone/tests/domain/lfric/transformations/dynamo0p3_transformations_test.py index ca509d42f7..d7eff3a004 100644 --- a/src/psyclone/tests/domain/lfric/transformations/dynamo0p3_transformations_test.py +++ b/src/psyclone/tests/domain/lfric/transformations/dynamo0p3_transformations_test.py @@ -36,6 +36,7 @@ # C.M. Maynard, Met Office / University of Reading # Modified: J. Henrichs, Bureau of Meteorology # Modified: A. B. G. Chalk, STFC Daresbury Lab +# J. Dendy, Met Office ''' Tests of transformations with the LFRic (Dynamo 0.3) API ''' @@ -7332,7 +7333,7 @@ def test_kern_const_name(): def test_kern_const_apply(capsys, monkeypatch): '''Check that we generate the expected output from the apply method - with different valid combinations of the element_order, + with different valid combinations of the element_order_ arguments, number_of_layers and quadrature arguments. ''' @@ -7350,8 +7351,8 @@ def test_kern_const_apply(capsys, monkeypatch): " Modified nqp_h, arg position 21, value 3.\n" " Modified nqp_v, arg position 22, value 3.\n") - # element_order only - kctrans.apply(kernel, {"element_order": 0}) + # element_order_ only + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0}) result, _ = capsys.readouterr() assert result == element_order_expected @@ -7361,22 +7362,24 @@ def test_kern_const_apply(capsys, monkeypatch): result, _ = capsys.readouterr() assert result == number_of_layers_expected - # element_order and quadrature + # element_order_ and quadrature kernel = create_kernel("1.1.0_single_invoke_xyoz_qr.f90") - kctrans.apply(kernel, {"element_order": 0, "quadrature": True}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0, + "quadrature": True}) result, _ = capsys.readouterr() assert result == quadrature_expected + element_order_expected - # element_order and nlayers + # element_order_ and nlayers kernel = create_kernel("1.1.0_single_invoke_xyoz_qr.f90") - kctrans.apply(kernel, {"element_order": 0, "number_of_layers": 20}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0, + "number_of_layers": 20}) result, _ = capsys.readouterr() assert result == number_of_layers_expected + element_order_expected - # element_order, nlayers and quadrature + # element_order_, nlayers and quadrature kernel = create_kernel("1.1.0_single_invoke_xyoz_qr.f90") - kctrans.apply(kernel, {"element_order": 0, "number_of_layers": 20, - "quadrature": True}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0, + "number_of_layers": 20, "quadrature": True}) result, _ = capsys.readouterr() assert result == number_of_layers_expected + quadrature_expected + \ element_order_expected @@ -7402,7 +7405,7 @@ def test_kern_const_anyspace_anydspace_apply(capsys): kctrans = Dynamo0p3KernelConstTrans() - kctrans.apply(kernel, {"element_order": 0}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0}) result, _ = capsys.readouterr() assert result == ( " Skipped dofs, arg position 9, function space any_space_1\n" @@ -7427,7 +7430,7 @@ def test_kern_const_anyw2_apply(capsys): kctrans = Dynamo0p3KernelConstTrans() - kctrans.apply(kernel, {"element_order": 0}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0}) result, _ = capsys.readouterr() assert result == ( " Skipped dofs, arg position 5, function space any_w2\n") @@ -7440,36 +7443,186 @@ def test_kern_const_ndofs(): Note: w2*trace spaces have their dofs on cell faces only. ''' - expected = {"w3": [1, 8, 27, 64, 125, 216, 343, 512, 729, 1000], - "w2": [6, 36, 108, 240, 450, 756, 1176, 1728, 2430, 3300], - "w1": [12, 54, 144, 300, 540, 882, 1344, 1944, 2700, 3630], - "w0": [8, 27, 64, 125, 216, 343, 512, 729, 1000, 1331], - "wtheta": [2, 12, 36, 80, 150, 252, 392, 576, 810, 1100], - "w2h": [4, 24, 72, 160, 300, 504, 784, 1152, 1620, 2200], - "w2v": [2, 12, 36, 80, 150, 252, 392, 576, 810, 1100], - "w2broken": [6, 36, 108, 240, 450, 756, 1176, 1728, 2430, - 3300], - "wchi": [1, 8, 27, 64, 125, 216, 343, 512, 729, 1000], - "w2trace": [6, 24, 54, 96, 150, 216, 294, 384, 486, 600], - "w2htrace": [4, 16, 36, 64, 100, 144, 196, 256, 324, 400], - "w2vtrace": [2, 8, 18, 32, 50, 72, 98, 128, 162, 200]} + # A dictionary of expected ndofs indexed by + # space_to_dofs[space](element_order_h, element_order_v) = + # expected[space](element_order_h + 10*element_order_v) + expected = { + "w3": [1, 4, 9, 16, 25, 36, 49, 64, + 81, 100, 2, 8, 18, 32, 50, 72, + 98, 128, 162, 200, 3, 12, 27, 48, + 75, 108, 147, 192, 243, 300, 4, 16, + 36, 64, 100, 144, 196, 256, 324, 400, + 5, 20, 45, 80, 125, 180, 245, 320, + 405, 500, 6, 24, 54, 96, 150, 216, + 294, 384, 486, 600, 7, 28, 63, 112, + 175, 252, 343, 448, 567, 700, 8, 32, + 72, 128, 200, 288, 392, 512, 648, 800, + 9, 36, 81, 144, 225, 324, 441, 576, + 729, 900, 10, 40, 90, 160, 250, 360, + 490, 640, 810, 1000], + "w2": [6, 20, 42, 72, 110, 156, 210, 272, + 342, 420, 11, 36, 75, 128, 195, 276, + 371, 480, 603, 740, 16, 52, 108, 184, + 280, 396, 532, 688, 864, 1060, 21, 68, + 141, 240, 365, 516, 693, 896, 1125, 1380, + 26, 84, 174, 296, 450, 636, 854, 1104, + 1386, 1700, 31, 100, 207, 352, 535, 756, + 1015, 1312, 1647, 2020, 36, 116, 240, 408, + 620, 876, 1176, 1520, 1908, 2340, 41, 132, + 273, 464, 705, 996, 1337, 1728, 2169, 2660, + 46, 148, 306, 520, 790, 1116, 1498, 1936, + 2430, 2980, 51, 164, 339, 576, 875, 1236, + 1659, 2144, 2691, 3300], + "w1": [12, 33, 64, 105, 156, 217, 288, 369, + 460, 561, 20, 54, 104, 170, 252, 350, + 464, 594, 740, 902, 28, 75, 144, 235, + 348, 483, 640, 819, 1020, 1243, 36, 96, + 184, 300, 444, 616, 816, 1044, 1300, 1584, + 44, 117, 224, 365, 540, 749, 992, 1269, + 1580, 1925, 52, 138, 264, 430, 636, 882, + 1168, 1494, 1860, 2266, 60, 159, 304, 495, + 732, 1015, 1344, 1719, 2140, 2607, 68, 180, + 344, 560, 828, 1148, 1520, 1944, 2420, 2948, + 76, 201, 384, 625, 924, 1281, 1696, 2169, + 2700, 3289, 84, 222, 424, 690, 1020, 1414, + 1872, 2394, 2980, 3630], + "w0": [8, 18, 32, 50, 72, 98, 128, 162, + 200, 242, 12, 27, 48, 75, 108, 147, + 192, 243, 300, 363, 16, 36, 64, 100, + 144, 196, 256, 324, 400, 484, 20, 45, + 80, 125, 180, 245, 320, 405, 500, 605, + 24, 54, 96, 150, 216, 294, 384, 486, + 600, 726, 28, 63, 112, 175, 252, 343, + 448, 567, 700, 847, 32, 72, 128, 200, + 288, 392, 512, 648, 800, 968, 36, 81, + 144, 225, 324, 441, 576, 729, 900, 1089, + 40, 90, 160, 250, 360, 490, 640, 810, + 1000, 1210, 44, 99, 176, 275, 396, 539, + 704, 891, 1100, 1331], + "wtheta": [2, 8, 18, 32, 50, 72, 98, 128, + 162, 200, 3, 12, 27, 48, 75, 108, + 147, 192, 243, 300, 4, 16, 36, 64, + 100, 144, 196, 256, 324, 400, 5, 20, + 45, 80, 125, 180, 245, 320, 405, 500, + 6, 24, 54, 96, 150, 216, 294, 384, + 486, 600, 7, 28, 63, 112, 175, 252, + 343, 448, 567, 700, 8, 32, 72, 128, + 200, 288, 392, 512, 648, 800, 9, 36, + 81, 144, 225, 324, 441, 576, 729, 900, + 10, 40, 90, 160, 250, 360, 490, 640, + 810, 1000, 11, 44, 99, 176, 275, 396, + 539, 704, 891, 1100], + "w2h": [4, 12, 24, 40, 60, 84, 112, 144, + 180, 220, 8, 24, 48, 80, 120, 168, + 224, 288, 360, 440, 12, 36, 72, 120, + 180, 252, 336, 432, 540, 660, 16, 48, + 96, 160, 240, 336, 448, 576, 720, 880, + 20, 60, 120, 200, 300, 420, 560, 720, + 900, 1100, 24, 72, 144, 240, 360, 504, + 672, 864, 1080, 1320, 28, 84, 168, 280, + 420, 588, 784, 1008, 1260, 1540, 32, 96, + 192, 320, 480, 672, 896, 1152, 1440, 1760, + 36, 108, 216, 360, 540, 756, 1008, 1296, + 1620, 1980, 40, 120, 240, 400, 600, 840, + 1120, 1440, 1800, 2200], + "w2v": [2, 8, 18, 32, 50, 72, 98, 128, + 162, 200, 3, 12, 27, 48, 75, 108, + 147, 192, 243, 300, 4, 16, 36, 64, + 100, 144, 196, 256, 324, 400, 5, 20, + 45, 80, 125, 180, 245, 320, 405, 500, + 6, 24, 54, 96, 150, 216, 294, 384, + 486, 600, 7, 28, 63, 112, 175, 252, + 343, 448, 567, 700, 8, 32, 72, 128, + 200, 288, 392, 512, 648, 800, 9, 36, + 81, 144, 225, 324, 441, 576, 729, 900, + 10, 40, 90, 160, 250, 360, 490, 640, + 810, 1000, 11, 44, 99, 176, 275, 396, + 539, 704, 891, 1100], + "w2broken": [6, 20, 42, 72, 110, 156, 210, 272, + 342, 420, 11, 36, 75, 128, 195, 276, + 371, 480, 603, 740, 16, 52, 108, 184, + 280, 396, 532, 688, 864, 1060, 21, 68, + 141, 240, 365, 516, 693, 896, 1125, 1380, + 26, 84, 174, 296, 450, 636, 854, 1104, + 1386, 1700, 31, 100, 207, 352, 535, 756, + 1015, 1312, 1647, 2020, 36, 116, 240, 408, + 620, 876, 1176, 1520, 1908, 2340, 41, 132, + 273, 464, 705, 996, 1337, 1728, 2169, 2660, + 46, 148, 306, 520, 790, 1116, 1498, 1936, + 2430, 2980, 51, 164, 339, 576, 875, 1236, + 1659, 2144, 2691, 3300], + "wchi": [1, 4, 9, 16, 25, 36, 49, 64, + 81, 100, 2, 8, 18, 32, 50, 72, + 98, 128, 162, 200, 3, 12, 27, 48, + 75, 108, 147, 192, 243, 300, 4, 16, + 36, 64, 100, 144, 196, 256, 324, 400, + 5, 20, 45, 80, 125, 180, 245, 320, + 405, 500, 6, 24, 54, 96, 150, 216, + 294, 384, 486, 600, 7, 28, 63, 112, + 175, 252, 343, 448, 567, 700, 8, 32, + 72, 128, 200, 288, 392, 512, 648, 800, + 9, 36, 81, 144, 225, 324, 441, 576, + 729, 900, 10, 40, 90, 160, 250, 360, + 490, 640, 810, 1000], + "w2trace": [6, 16, 30, 48, 70, 96, 126, 160, + 198, 240, 10, 24, 42, 64, 90, 120, + 154, 192, 234, 280, 14, 32, 54, 80, + 110, 144, 182, 224, 270, 320, 18, 40, + 66, 96, 130, 168, 210, 256, 306, 360, + 22, 48, 78, 112, 150, 192, 238, 288, + 342, 400, 26, 56, 90, 128, 170, 216, + 266, 320, 378, 440, 30, 64, 102, 144, + 190, 240, 294, 352, 414, 480, 34, 72, + 114, 160, 210, 264, 322, 384, 450, 520, + 38, 80, 126, 176, 230, 288, 350, 416, + 486, 560, 42, 88, 138, 192, 250, 312, + 378, 448, 522, 600], + "w2htrace": [4, 8, 12, 16, 20, 24, 28, 32, + 36, 40, 8, 16, 24, 32, 40, 48, + 56, 64, 72, 80, 12, 24, 36, 48, + 60, 72, 84, 96, 108, 120, 16, 32, + 48, 64, 80, 96, 112, 128, 144, 160, + 20, 40, 60, 80, 100, 120, 140, 160, + 180, 200, 24, 48, 72, 96, 120, 144, + 168, 192, 216, 240, 28, 56, 84, 112, + 140, 168, 196, 224, 252, 280, 32, 64, + 96, 128, 160, 192, 224, 256, 288, 320, + 36, 72, 108, 144, 180, 216, 252, 288, + 324, 360, 40, 80, 120, 160, 200, 240, + 280, 320, 360, 400], + "w2vtrace": [2, 8, 18, 32, 50, 72, 98, 128, + 162, 200, 2, 8, 18, 32, 50, 72, + 98, 128, 162, 200, 2, 8, 18, 32, + 50, 72, 98, 128, 162, 200, 2, 8, + 18, 32, 50, 72, 98, 128, 162, 200, + 2, 8, 18, 32, 50, 72, 98, 128, + 162, 200, 2, 8, 18, 32, 50, 72, + 98, 128, 162, 200, 2, 8, 18, 32, + 50, 72, 98, 128, 162, 200, 2, 8, + 18, 32, 50, 72, 98, 128, 162, 200, + 2, 8, 18, 32, 50, 72, 98, 128, + 162, 200, 2, 8, 18, 32, 50, 72, + 98, 128, 162, 200]} + kct = Dynamo0p3KernelConstTrans() - for order in range(10): - for function_space in ["w3", "w2", "w1", "w0", "wtheta", "w2h", - "w2v", "w2broken", "wchi", "w2trace", - "w2htrace", "w2vtrace"]: - assert kct.space_to_dofs[function_space](order) == \ - expected[function_space][order] - # wtheta should equal w2v - assert kct.space_to_dofs["wtheta"](order) == \ - kct.space_to_dofs["w2v"](order) - # w2h and w2v should sum up to w2 - assert kct.space_to_dofs["w2h"](order) + \ - kct.space_to_dofs["w2v"](order) == kct.space_to_dofs["w2"](order) - # w2htrace and w2vtrace should sum up to w2trace - assert kct.space_to_dofs["w2htrace"](order) + \ - kct.space_to_dofs["w2vtrace"](order) == \ - kct.space_to_dofs["w2trace"](order) + for order_h in range(10): + for order_v in range(10): + for function_space in ["w3", "w2", "w1", "w0", "wtheta", "w2h", + "w2v", "w2broken", "wchi", "w2trace", + "w2htrace", "w2vtrace"]: + assert kct.space_to_dofs[function_space](order_h, order_v) == \ + expected[function_space][order_h + 10*order_v] + # wtheta should equal w2v + assert kct.space_to_dofs["wtheta"](order_h, order_v) == \ + kct.space_to_dofs["w2v"](order_h, order_v) + # w2h and w2v should sum up to w2 + assert kct.space_to_dofs["w2h"](order_h, order_v) + \ + kct.space_to_dofs["w2v"](order_h, order_v) == \ + kct.space_to_dofs["w2"](order_h, order_v) + # w2htrace and w2vtrace should sum up to w2trace + assert kct.space_to_dofs["w2htrace"](order_h, order_v) + \ + kct.space_to_dofs["w2vtrace"](order_h, order_v) == \ + kct.space_to_dofs["w2trace"](order_h, order_v) def test_kern_const_invalid(): @@ -7495,9 +7648,10 @@ def test_kern_const_invalid(): # Element order < 0 with pytest.raises(TransformationError) as excinfo: - kctrans.apply(kernel, {"element_order": -1}) - assert "The element_order argument must be >= 0 but found '-1'." \ - in str(excinfo.value) + kctrans.apply(kernel, {"element_order_h": -1, "element_order_v": -1}) + assert ("The element_order_h and element_order_v argument must be >= 0 " + "but found element_order_h = '-1', element_order_v = '-1'." + in str(excinfo.value)) # Number of layers < 1 with pytest.raises(TransformationError) as excinfo: @@ -7511,18 +7665,20 @@ def test_kern_const_invalid(): assert "The quadrature argument must be boolean but found 'hello'." \ in str(excinfo.value) - # Not element order and not number of layers + # Not element order(s) and not number of layers with pytest.raises(TransformationError) as excinfo: kctrans.apply(kernel) - assert ("At least one of element_order or number_of_layers must be set " - "otherwise this transformation does nothing.") \ + assert ("At least one of [element_order_h, element_order_v] or " + "number_of_layers must be set otherwise this transformation does " + "nothing.") \ in str(excinfo.value) # Quadrature but not element order with pytest.raises(TransformationError) as excinfo: kctrans.apply(kernel, {"number_of_layers": 20, "quadrature": True}) - assert "If quadrature is set then element_order must also be set" \ + assert ("If quadrature is set then both element_order_h and " + "element_order_v must also be set") \ in str(excinfo.value) @@ -7538,7 +7694,7 @@ def test_kern_const_invalid_dofs(monkeypatch): {"wa": [], "wb": []}) with pytest.raises(InternalError) as excinfo: - kctrans.apply(kernel, {"element_order": 0}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0}) assert "Unsupported function space 'w1' found. Expecting one of " \ in str(excinfo.value) assert "'wa'" in str(excinfo.value) @@ -7559,7 +7715,7 @@ def dummy(): raise NotImplementedError("Monkeypatch error") monkeypatch.setattr(kernel, "get_kernel_schedule", dummy) with pytest.raises(TransformationError) as excinfo: - kctrans.apply(kernel, {"element_order": 0}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0}) assert ( "Failed to parse kernel 'testkern_code'. Error reported was " "'Monkeypatch error'.") in str(excinfo.value) @@ -7576,7 +7732,8 @@ def test_kern_const_invalid_quad(monkeypatch): kctrans = Dynamo0p3KernelConstTrans() monkeypatch.setattr(kernel, "_eval_shapes", ["gh_quadrature_face"]) with pytest.raises(TransformationError) as excinfo: - kctrans.apply(kernel, {"element_order": 0, "quadrature": True}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0, + "quadrature": True}) assert ( "Support is currently limited to 'xyoz' quadrature but found " "['gh_quadrature_face'].") in str(excinfo.value) @@ -7602,7 +7759,7 @@ def test_kern_const_invalid_make_constant1(): symbol_table._argument_list = [] kctrans = Dynamo0p3KernelConstTrans() with pytest.raises(TransformationError) as excinfo: - kctrans.apply(kernel, {"element_order": 0}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0}) assert ("The argument index '7' is greater than the number of " "arguments '0'.") in str(excinfo.value) @@ -7624,13 +7781,13 @@ def test_kern_const_invalid_make_constant2(): # Expecting scalar integer. Set to array. symbol._datatype = ArrayType(INTEGER_TYPE, [10]) with pytest.raises(TransformationError) as excinfo: - kctrans.apply(kernel, {"element_order": 0}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0}) assert ("Expected entry to be a scalar argument but found " "'ArrayType'." in str(excinfo.value)) # Expecting scalar integer. Set to real. symbol._datatype = REAL_TYPE with pytest.raises(TransformationError) as excinfo: - kctrans.apply(kernel, {"element_order": 0}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0}) assert ("Expected entry to be a scalar integer argument but found " "'Scalar'." in str(excinfo.value)) # Expecting scalar integer. Set to constant. @@ -7639,7 +7796,7 @@ def test_kern_const_invalid_make_constant2(): symbol._initial_value = Literal("10", INTEGER_TYPE) symbol._is_constant = True with pytest.raises(TransformationError) as excinfo: - kctrans.apply(kernel, {"element_order": 0}) + kctrans.apply(kernel, {"element_order_h": 0, "element_order_v": 0}) assert ("Expected entry to be a scalar integer argument but found " "a constant." in str(excinfo.value)) diff --git a/src/psyclone/tests/psyad/domain/lfric/test_lfric_adjoint_harness.py b/src/psyclone/tests/psyad/domain/lfric/test_lfric_adjoint_harness.py index dd78ed5571..b6f4e10f64 100644 --- a/src/psyclone/tests/psyad/domain/lfric/test_lfric_adjoint_harness.py +++ b/src/psyclone/tests/psyad/domain/lfric/test_lfric_adjoint_harness.py @@ -32,7 +32,8 @@ # POSSIBILITY OF SUCH DAMAGE. # ----------------------------------------------------------------------------- # Authors: R. W. Ford, A. R. Porter and N. Nobre, STFC Daresbury Lab -# T. Vockerodt, Met Office +# Modified by: J. Dendy, Met Office +# T. Vockerodt, Met Office '''Provides py.test tests of LFRic-specific PSyclone adjoint test-harness functionality.''' @@ -576,7 +577,8 @@ def test_generate_lfric_adjoint_harness(fortran_reader, fortran_writer): adjt_name = "adjoint_test_alg" psyir = generate_lfric_adjoint_harness(tl_psyir, test_name=adjt_name) gen = fortran_writer(psyir).lower() - assert "use finite_element_config_mod, only : element_order" in gen + assert ("use finite_element_config_mod, only : element_order_h, " + "element_order_v" in gen) assert "module adjoint_test_alg_mod" in gen assert "subroutine adjoint_test_alg(mesh, chi, panel_id)" in gen # We should have a field, a copy of that field and an inner-product value @@ -683,9 +685,9 @@ def test_generate_lfric_adjoint_harness_operator(fortran_reader, gen = fortran_writer(psyir) assert "type(operator_type) :: op\n" in gen assert ("vector_space_w0_ptr => function_space_collection%get_fs(mesh," - "element_order,w0)\n" in gen) + "element_order_h,element_order_v,w0)\n" in gen) assert ("vector_space_w3_ptr => function_space_collection%get_fs(mesh," - "element_order,w3)\n" in gen) + "element_order_h,element_order_v,w3)\n" in gen) # Initialise takes the *to* and *from* spaces as arguments in that order. assert ("call op%initialise(vector_space_w3_ptr, vector_space_w0_ptr)" in gen) diff --git a/src/psyclone/tests/psyir/frontend/fparser2_where_handler_test.py b/src/psyclone/tests/psyir/frontend/fparser2_where_handler_test.py index 98ccc257b3..866dccb694 100644 --- a/src/psyclone/tests/psyir/frontend/fparser2_where_handler_test.py +++ b/src/psyclone/tests/psyir/frontend/fparser2_where_handler_test.py @@ -570,7 +570,6 @@ def test_where_with_scalar_assignment(fortran_reader, fortran_writer): @pytest.mark.usefixtures("parser") -@pytest.mark.xfail(reason="#1960 Can't handle array-reduction intrinsics") def test_where_with_array_reduction_intrinsic(): ''' Test that a WHERE containing an array-reduction intrinsic is handled correctly. Currently it is not supported. This will be fixed in #1960. @@ -1014,3 +1013,224 @@ def test_non_array_ref_intrinsic_transformation_error(fortran_reader): references = psyir.walk(Reference) # The d should not have been transformed into an array. assert not isinstance(references[7], ArrayReference) + + +def test_elemental_intrinsic_to_loop(fortran_reader, fortran_writer): + ''' + Tests that if we have an elemental intrinsic (like ABS) that we + expand the where into a loop. + ''' + code = ''' + program where_test + implicit none + real, dimension(100) :: a, b + + where(abs(a) < 2) + b = a + end where + end program + ''' + psyir = fortran_reader.psyir_from_source(code) + correct = '''program where_test + real, dimension(100) :: a + real, dimension(100) :: b + integer :: widx1 + + do widx1 = 1, 100, 1 + if (ABS(a(widx1)) < 2) then + b(widx1) = a(widx1) + end if + enddo + +end program where_test''' + out = fortran_writer(psyir) + assert correct in out + + # Test a case with both an intrinsic and non-intrinsic + code = ''' + program where_test + implicit none + real, dimension(100) :: a, b + + where(dot_product(a,a(:)) + abs(a) < 2) + b = a + end where + end program + ''' + psyir = fortran_reader.psyir_from_source(code) + out = fortran_writer(psyir) + assert isinstance(psyir.children[0].children[0], Loop) + correct = '''do widx1 = 1, 100, 1 + if (DOT_PRODUCT(a, a(:)) + ABS(a(widx1)) < 2) then + b(widx1) = a(widx1) + end if + enddo''' + assert correct in out + + +def test_elemental_function_to_loop(fortran_reader, fortran_writer): + ''' + Tests that if we have an elemental function that we expand the where + into a loop. + ''' + code = ''' + module mymod + contains + real elemental function x(i) + real :: i + x = i + 1.5 + end function + subroutine where_test + implicit none + real, dimension(100) :: a, b + + where(x(a) < 2) + b = a + end where + end subroutine + end module''' + psyir = fortran_reader.psyir_from_source(code) + correct = ''' subroutine where_test() + real, dimension(100) :: a + real, dimension(100) :: b + integer :: widx1 + + do widx1 = 1, 100, 1 + if (x(a(widx1)) < 2) then + b(widx1) = a(widx1) + end if + enddo + + end subroutine where_test''' + out = fortran_writer(psyir) + assert correct in out + + # Test the behaviour if we have a non-elemental function. + code = ''' + module mymod + contains + real function x(i) + real, dimension(*) :: i + x = sum(i) + 1.5 + end function + subroutine where_test + implicit none + real, dimension(100) :: a, b + + where(x(a(:)) + abs(a) < 2) + b = a + end where + end subroutine + end module''' + psyir = fortran_reader.psyir_from_source(code) + assert isinstance(psyir.children[0].children[1].children[0], Loop) + correct = '''do widx1 = 1, 100, 1 + if (x(a(:)) + ABS(a(widx1)) < 2) then + b(widx1) = a(widx1) + end if + enddo''' + out = fortran_writer(psyir) + assert correct in out + + # Test the behaviour if we have a non-elemental and elemental + # functions in the where. + code = ''' + module mymod + contains + real function x(i) + real, dimension(*) :: i + x = sum(i) + 1.5 + end function + real elemental function y(i) + real :: i + y = i + 1.5 + end function + subroutine where_test + implicit none + real, dimension(100) :: a, b + + where(x(a(:)) + y(a) < 2) + b = a + end where + end subroutine + end module''' + psyir = fortran_reader.psyir_from_source(code) + assert isinstance(psyir.children[0].children[2].children[0], Loop) + correct = '''do widx1 = 1, 100, 1 + if (x(a(:)) + y(a(widx1)) < 2) then + b(widx1) = a(widx1) + end if + enddo''' + out = fortran_writer(psyir) + assert correct in out + + # Imported function has unknown elemental status. Only the import error + # is testable at the moment. + code = ''' + subroutine test + use mod, only: somefunc + real, dimension(100) :: a, b + where(somefunc(a) < 2) + b = a + end where + end subroutine''' + psyir = fortran_reader.psyir_from_source(code) + assert isinstance(psyir.children[0].children[0], CodeBlock) + correct = '''! PSyclone CodeBlock (unsupported code) reason: + ! - PSyclone doesn't yet support reference to imported \ +symbols inside WHERE clauses. + WHERE (somefunc(a) < 2) + b = a + END WHERE''' + out = fortran_writer(psyir) + assert correct in out + + code = ''' + subroutine test + use mod + real, dimension(100) :: a, b + where(somefunc(a) < 2) + b = a + end where + end subroutine''' + psyir = fortran_reader.psyir_from_source(code) + assert isinstance(psyir.children[0].children[0], CodeBlock) + correct = '''! PSyclone CodeBlock (unsupported code) reason: + ! - PSyclone doesn't yet support reference to imported \ +symbols inside WHERE clauses. + WHERE (somefunc(a) < 2) + b = a + END WHERE''' + out = fortran_writer(psyir) + assert correct in out + + +def test_array_syntax_to_indexed_unknown_elemental(fortran_reader): + # Check we get a codeblock if we have an function of unknown elemental + # status. + code = ''' + module mymod + contains + real function x(i) + real, dimension(*) :: i + x = sum(i) + 1.5 + end function + subroutine where_test + implicit none + real, dimension(100) :: a, b + + if(x(a(:)) + abs(a) < 2) then + b = a + end if + end subroutine + end module''' + psyir = fortran_reader.psyir_from_source(code) + calls = psyir.walk(Call) + # Override the call to x symbol to be None elemental type + calls[1].routine.symbol.is_elemental = None + ifblock = psyir.walk(IfBlock)[0] + parser = fortran_reader._processor + with pytest.raises(NotImplementedError) as excinfo: + parser._array_syntax_to_indexed(ifblock, ["i"]) + assert ("Found a function call inside a where clause with unknown " + "elemental status: x(a(:)" in str(excinfo.value)) diff --git a/src/psyclone/tests/test_files/dynamo0p3/10.1_operator_nofield.f90 b/src/psyclone/tests/test_files/dynamo0p3/10.1_operator_nofield.f90 index d4d2f90593..64d7dc9a32 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/10.1_operator_nofield.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/10.1_operator_nofield.f90 @@ -31,6 +31,7 @@ ! ----------------------------------------------------------------------------- ! Authors: R. W. Ford and A. R. Porter, STFC Daresbury Lab ! Modified: I. Kavcic, Met Office +! J. Dendy, Met Office program operator_example_nofield @@ -49,10 +50,15 @@ program operator_example_nofield type(operator_type) :: mm_w2 type(quadrature_xyoz_type), pointer :: qr => null integer(i_def) :: mesh_id = 1 - integer(i_def) :: element_order = 0 + integer(i_def) :: element_order_h = 0 + integer(i_def) :: element_order_v = 0 - mm_w2 = operator_type(function_space_collection%get_fs(mesh_id,element_order,W2), & - function_space_collection%get_fs(mesh_id,element_order,W2)) + mm_w2 = operator_type(function_space_collection%get_fs(mesh_id, & + element_order_h, & + element_order_v, W2), & + function_space_collection%get_fs(mesh_id, & + element_order_h, & + element_order_v, W2)) call invoke(testkern_operator_nofield_type(mm_w2, coord, qr)) diff --git a/src/psyclone/tests/test_files/dynamo0p3/10.3_operator_different_spaces.f90 b/src/psyclone/tests/test_files/dynamo0p3/10.3_operator_different_spaces.f90 index 807ae95e4d..6d16008c8c 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/10.3_operator_different_spaces.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/10.3_operator_different_spaces.f90 @@ -31,6 +31,7 @@ ! ----------------------------------------------------------------------------- ! Authors: R. W. Ford and A. R. Porter, STFC Daresbury Lab ! Modified: I. Kavcic, Met Office +! J. Dendy, Met Office program operator_example @@ -49,10 +50,11 @@ program operator_example type(operator_type) :: mapping type(quadrature_xyoz_type), pointer :: qr => null integer(i_def) :: mesh_id = 1 - integer(i_def) :: element_order = 0 + integer(i_def) :: element_order_h = 0 + integer(i_def) :: element_order_v = 0 ! Do not remove long lines, this is used to check psyclone line-breaking functionality - mapping = operator_type(function_space_collection%get_fs(mesh_id,element_order,W3), function_space_collection%get_fs(mesh_id,element_order,W2)) + mapping = operator_type(function_space_collection%get_fs(mesh_id,element_order_h,element_order_v,W3), function_space_collection%get_fs(mesh_id,element_order_h,element_order_v,W2)) call invoke(assemble_weak_derivative_w3_w2_kernel_type(mapping, coord, qr)) diff --git a/src/psyclone/tests/test_files/dynamo0p3/10.5_operator_no_field_different_space.f90 b/src/psyclone/tests/test_files/dynamo0p3/10.5_operator_no_field_different_space.f90 index 4ce107b74a..08852b95fd 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/10.5_operator_no_field_different_space.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/10.5_operator_no_field_different_space.f90 @@ -31,6 +31,7 @@ ! ----------------------------------------------------------------------------- ! Authors: R. W. Ford and A. R. Porter, STFC Daresbury Lab ! Modified: I. Kavcic, Met Office +! L. Dendy, Met Office program operator_example @@ -44,10 +45,15 @@ program operator_example type(operator_type) :: my_mapping integer(i_def) :: mesh_id = 1 - integer(i_def) :: element_order = 0 + integer(i_def) :: element_order_h = 0 + integer(i_def) :: element_order_v = 0 - my_mapping = operator_type(function_space_collection%get_fs(mesh_id,element_order,W2), & - function_space_collection%get_fs(mesh_id,element_order,W3)) + my_mapping = operator_type(function_space_collection%get_fs(mesh_id, & + element_order_h, & + element_order_v,W2), & + function_space_collection%get_fs(mesh_id, & + element_order_h, & + element_order_v,W3)) call invoke(testkern_operator_2_type(my_mapping)) diff --git a/src/psyclone/tests/test_files/dynamo0p3/10.6_operator_no_field_scalar.f90 b/src/psyclone/tests/test_files/dynamo0p3/10.6_operator_no_field_scalar.f90 index 663d889946..8f49c7e389 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/10.6_operator_no_field_scalar.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/10.6_operator_no_field_scalar.f90 @@ -31,6 +31,7 @@ ! ----------------------------------------------------------------------------- ! Authors: R. W. Ford and A. R. Porter, STFC Daresbury Lab ! Modified: I. Kavcic, Met Office +! J. Dendy, Met Office program operator_example @@ -47,11 +48,16 @@ program operator_example type(operator_type) :: my_mapping type(quadrature_xyoz_type), pointer :: qr => null integer(i_def) :: mesh_id = 1 - integer(i_def) :: element_order = 0 + integer(i_def) :: element_order_h = 0 + integer(i_def) :: element_order_v = 0 integer(i_def) :: b(3) - my_mapping = operator_type(function_space_collection%get_fs(mesh_id,element_order,W2), & - function_space_collection%get_fs(mesh_id,element_order,W2)) + my_mapping = operator_type(function_space_collection%get_fs(mesh_id, & + element_order_h, & + element_order_v,W2), & + function_space_collection%get_fs(mesh_id, & + element_order_h, & + element_order_v,W2)) call invoke(testkern_operator_nofield_scalar_type(my_mapping, b(1), qr)) diff --git a/src/psyclone/tests/test_files/dynamo0p3/10.7_operator_read.f90 b/src/psyclone/tests/test_files/dynamo0p3/10.7_operator_read.f90 index 78cd0c9d78..52b7c6ce2a 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/10.7_operator_read.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/10.7_operator_read.f90 @@ -46,12 +46,17 @@ program operator_example type(operator_type) :: mm_w3 type(quadrature_xyoz_type), pointer :: qr => null integer(i_def) :: mesh_id = 1 - integer(i_def) :: element_order = 0 + integer(i_def) :: element_order_h = 0 + integer(i_def) :: element_order_v = 0 integer(i_def) :: a a = 1_i_def - mm_w3 = operator_type(function_space_collection%get_fs(mesh_id,element_order,W3), & - function_space_collection%get_fs(mesh_id,element_order,W3)) + mm_w3 = operator_type(function_space_collection%get_fs(mesh_id, & + element_order_h, & + element_order_v,W3), & + function_space_collection%get_fs(mesh_id, & + element_order_h, & + element_order_v,W3)) call invoke(testkern_operator_read_type(mm_w3, coord, a, qr)) diff --git a/src/psyclone/tests/test_files/dynamo0p3/10.9_operator_first.f90 b/src/psyclone/tests/test_files/dynamo0p3/10.9_operator_first.f90 index 765c6b0444..774b14ab43 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/10.9_operator_first.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/10.9_operator_first.f90 @@ -10,21 +10,21 @@ ! ! Modifications copyright (c) 2017-2025, Science and Technology Facilities Council ! All rights reserved. -! +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: -! +! ! * Redistributions of source code must retain the above copyright notice, this ! list of conditions and the following disclaimer. -! +! ! * Redistributions in binary form must reproduce the above copyright notice, ! this list of conditions and the following disclaimer in the documentation ! and/or other materials provided with the distribution. -! +! ! * Neither the name of the copyright holder nor the names of its ! contributors may be used to endorse or promote products derived from ! this software without specific prior written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -38,6 +38,7 @@ ! ----------------------------------------------------------------------------- ! Modified: R. W. Ford and A. R. Porter, STFC Daresbury Lab ! I. Kavcic, Met Office +! J. Dendy, Met Office !>@brief compute the locally assembled SI operators module si_operators_alg_mod @@ -57,7 +58,7 @@ module si_operators_alg_mod private ! Variables private to this module that can only be accessed by public - ! functions returning pointers to them + ! functions returning pointers to them type(operator_type), target :: m3_rho_star type(operator_type), target :: m3_exner_star type(operator_type), target :: div_star @@ -74,13 +75,13 @@ module si_operators_alg_mod public :: create_si_operators public :: compute_si_operators public :: get_m3_rho_star - public :: get_m3_exner_star + public :: get_m3_exner_star public :: get_div_star public :: get_p2theta - public :: get_ptheta2 + public :: get_ptheta2 public :: get_p3theta - public :: get_compound_div - public :: get_rho_at_u + public :: get_compound_div + public :: get_rho_at_u public :: get_mt_lumped public :: get_tri_precon public :: get_helm_diag @@ -92,7 +93,7 @@ subroutine create_si_operators(mesh_id) use function_space_mod, only: function_space_type use fs_continuity_mod, only: W0, W2, W3, Wtheta - use finite_element_config_mod, only: element_order + use finite_element_config_mod, only: element_order_h, element_order_v use function_space_collection_mod, & only: function_space_collection @@ -106,15 +107,19 @@ subroutine create_si_operators(mesh_id) call log_event( "LFRic: creating si_operators", LOG_LEVEL_INFO ) - w2_fs => function_space_collection%get_fs( mesh_id, element_order, W2 ) - w3_fs => function_space_collection%get_fs( mesh_id, element_order, W3 ) + w2_fs => function_space_collection%get_fs( mesh_id, element_order_h, & + element_order_v, W2 ) + w3_fs => function_space_collection%get_fs( mesh_id, element_order_h, & + element_order_v, W3 ) if (wtheta_on) then - wtheta_fs => function_space_collection%get_fs( mesh_id, element_order, Wtheta ) + wtheta_fs => function_space_collection%get_fs( mesh_id, element_order_h, & + element_order_v, Wtheta ) else - wtheta_fs => function_space_collection%get_fs( mesh_id, element_order, W0 ) + wtheta_fs => function_space_collection%get_fs( mesh_id, element_order_h, & + element_order_v, W0 ) end if ! Should change 0 to theta - + m3_rho_star = operator_type( w3_fs, w3_fs ) m3_exner_star = operator_type( w3_fs, w3_fs ) div_star = operator_type( w3_fs, w2_fs ) @@ -127,7 +132,7 @@ subroutine create_si_operators(mesh_id) mt_lumped = field_type(vector_space = wtheta_fs) if ( preconditioner == solver_preconditioner_tridiagonal ) then - if ( element_order /= 0 ) then + if ( element_order_h /= 0 .or. element_order_v /= 0) then call log_event( "tridiagonal precon only valid for order 0", & LOG_LEVEL_ERROR ) end if @@ -154,7 +159,8 @@ subroutine compute_si_operators(ref_state) invoke_compute_tri_precon_kernel, & invoke_weighted_div_bd_kernel_type use multiplicity_kernel_mod, only: multiplicity_kernel_type - use finite_element_config_mod, only: element_order, wtheta_on + use finite_element_config_mod, only: element_order_h, element_order_v, & + wtheta_on use function_space_mod, only: function_space_type use function_space_collection_mod, only: function_space_collection use matrix_vector_kernel_mod, only: matrix_vector_kernel_type @@ -176,9 +182,9 @@ subroutine compute_si_operators(ref_state) type(evaluator_xyz_type) :: evaluator real(kind=r_solver) :: const2 = 1.0_r_solver - qr = quadrature_type(element_order+3, GAUSSIAN) + qr = quadrature_type(MAX(element_order_h, element_order_v)+3, GAUSSIAN) theta => ref_state(2) - rho => ref_state(3) + rho => ref_state(3) chi => get_coordinates() m3_inv => get_mass_matrix(4) div => get_div() diff --git a/src/psyclone/tests/test_files/dynamo0p3/10_operator.f90 b/src/psyclone/tests/test_files/dynamo0p3/10_operator.f90 index 564dece8aa..923ea1b339 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/10_operator.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/10_operator.f90 @@ -31,6 +31,7 @@ ! ----------------------------------------------------------------------------- ! Authors: R. W. Ford and A. R. Porter, STFC Daresbury Lab ! Modified: I. Kavcic, Met Office +! J. Dendy, Met Office program operator_example @@ -48,12 +49,17 @@ program operator_example type(operator_type) :: mm_w0 type(quadrature_xyoz_type), pointer :: qr => null integer(i_def) :: mesh_id = 1 - integer(i_def) :: element_order = 0 + integer(i_def) :: element_order_h = 0 + integer(i_def) :: element_order_v = 0 integer(i_def) :: a a = 1_i_def - mm_w0 = operator_type(function_space_collection%get_fs(mesh_id,element_order,W0), & - function_space_collection%get_fs(mesh_id,element_order,W0)) + mm_w0 = operator_type(function_space_collection%get_fs(mesh_id, & + element_order_h, & + element_order_v,W0), & + function_space_collection%get_fs(mesh_id, & + element_order_h, & + element_order_v,W0)) call invoke(testkern_operator_type(mm_w0, coord, a, qr)) diff --git a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/field/field_parent_mod.f90 b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/field/field_parent_mod.f90 index 25754c6d91..f7414088a7 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/field/field_parent_mod.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/field/field_parent_mod.f90 @@ -38,6 +38,7 @@ ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Modified by J. Henrichs, Bureau of Meteorology +! J. Dendy, Met Office ! !> @brief A module containing the abstract type that is the parent to all @@ -99,9 +100,12 @@ module field_parent_mod !> Return the id of the mesh used by this field !> @return mesh_id The id of the mesh object associated with the field procedure, public :: get_mesh_id - !> Returns the order of the FEM elements - !> @return elem Element order of this field - procedure, public :: get_element_order + !> Returns the order of the FEM elements in the horizontal direction + !> @return elem_h Element order of this field in the horizontal direction + procedure, public :: get_element_order_h + !> Returns the order of the FEM elements in the vertical direction + !> @return elem_v Element order of this field in the vertical direction + procedure, public :: get_element_order_v !> Returns the name of the field !> @return field name procedure, public :: get_name @@ -333,17 +337,29 @@ function get_mesh_id(self) result(mesh_id) return end function get_mesh_id - ! Function to get element order from the field. - function get_element_order(self) result(elem) + ! Function to get horizontal element order from the field. + function get_element_order_h(self) result(elem_h) implicit none class (field_parent_type) :: self - integer(i_def) :: elem + integer(i_def) :: elem_h - elem = self%vspace%get_element_order() + elem_h = self%vspace%get_element_order_h() return - end function get_element_order + end function get_element_order_h + + ! Function to get vertical element order from the field. + function get_element_order_v(self) result(elem_v) + implicit none + + class (field_parent_type) :: self + integer(i_def) :: elem_v + + elem_v = self%vspace%get_element_order_v() + + return + end function get_element_order_v !> Returns the name of the field function get_name(self) result(name) diff --git a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/fs_continuity_mod.F90 b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/fs_continuity_mod.F90 index 7483284000..b2c9cc04bf 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/fs_continuity_mod.F90 +++ b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/fs_continuity_mod.F90 @@ -7,65 +7,78 @@ ! https://code.metoffice.gov.uk/trac/lfric/browser/LFRic/trunk/LICENCE.original !----------------------------------------------------------------------------- ! -!> @brief Define enumerator variables that describe the different types of continuity. +!> @brief Define enumerator variables that describe the different types of +!> continuity. !> !> @details Enumerator variables that describe the different types of continuity !> that can be used to construct function spaces module fs_continuity_mod -use constants_mod, only: i_native, str_short -use log_mod, only: log_event, log_scratch_space, log_level_error - -implicit none - -private -public :: name_from_functionspace - -character(*), private, parameter :: module_name = 'fs_continuity_mod' - -!------------------------------------------------------------------------------- -! Module parameters -!------------------------------------------------------------------------------- -integer(i_native), public, parameter :: W0 = 173 -integer(i_native), public, parameter :: W1 = 194 -integer(i_native), public, parameter :: W2 = 889 -integer(i_native), public, parameter :: W2V = 857 -integer(i_native), public, parameter :: W2H = 884 -integer(i_native), public, parameter :: W2broken = 211 -integer(i_native), public, parameter :: W2trace = 213 -integer(i_native), public, parameter :: W2Vtrace = 666 -integer(i_native), public, parameter :: W2Htrace = 777 -integer(i_native), public, parameter :: W3 = 424 -integer(i_native), public, parameter :: Wtheta = 274 -integer(i_native), public, parameter :: Wchi = 869 - -integer(i_native), public, parameter :: fs_enumerator(12) = [W0, & - W1, & - W2, & - W2V, & - W2H, & - W2broken, & - W2trace, & - W2Vtrace, & - W2Htrace, & - W3, & - Wtheta, & - Wchi] - -character(str_short), public, parameter :: fs_name(12) & - = [character(str_short) :: 'W0', & - 'W1', & - 'W2', & - 'W2V', & - 'W2H', & - 'W2broken', & - 'W2trace', & - 'W2Htrace', & - 'W2Vtrace', & - 'W3', & - 'Wtheta', & - 'Wchi'] + use constants_mod, only : i_def, l_native, str_short + use log_mod, only : log_event, log_scratch_space, log_level_error + + implicit none + + private + public :: name_from_functionspace, functionspace_from_name, & + is_fs_horizontally_continuous, is_fs_vertically_continuous + + character(*), private, parameter :: module_name = 'fs_continuity_mod' + + !------------------------------------------------------------------------------- + ! Module parameters + !------------------------------------------------------------------------------- + integer(i_def), public, parameter :: W0 = 173 + integer(i_def), public, parameter :: W1 = 194 + integer(i_def), public, parameter :: W2 = 889 + integer(i_def), public, parameter :: W2V = 857 + integer(i_def), public, parameter :: W2H = 884 + integer(i_def), public, parameter :: W2broken = 211 + integer(i_def), public, parameter :: W2Hbroken = 112 + integer(i_def), public, parameter :: W2trace = 213 + integer(i_def), public, parameter :: W2Vtrace = 666 + integer(i_def), public, parameter :: W2Htrace = 777 + integer(i_def), public, parameter :: W3 = 424 + integer(i_def), public, parameter :: Wtheta = 274 + integer(i_def), public, parameter :: Wchi = 869 + + integer(i_def), private, parameter :: num_fs = 13 + + integer(i_def), private, parameter :: fs_enumerator(num_fs, 3) = & + transpose(reshape( [ & +! enumerator horizontally vertically +! continuous continuous + W0, 1, 1, & + W1, 1, 1, & + W2, 1, 1, & + W2V, 0, 1, & + W2H, 1, 0, & + W2broken, 0, 0, & + W2Hbroken, 0, 0, & + W2trace, 1, 1, & + W2Vtrace, 0, 1, & + W2Htrace, 1, 0, & + W3, 0, 0, & + Wtheta, 0, 1, & + Wchi, 0, 0 & + ], [3, num_fs] ) ) + + character(str_short), private, parameter :: fs_name(num_fs) = & + [character(str_short) :: & + 'W0', & + 'W1', & + 'W2', & + 'W2V', & + 'W2H', & + 'W2broken', & + 'W2Hbroken', & + 'W2trace', & + 'W2Htrace', & + 'W2Vtrace', & + 'W3', & + 'Wtheta', & + 'Wchi' ] contains @@ -75,30 +88,123 @@ module fs_continuity_mod !> !> @return String holding the function space name. !> - function name_from_functionspace( fs ) + function name_from_functionspace(fs) implicit none - integer(i_native), intent(in) :: fs + integer(i_def), intent(in) :: fs character(str_short) :: name_from_functionspace - integer(i_native) :: fs_index + integer(i_def) :: fs_index fs_index = 1 do - if (fs_enumerator(fs_index) == fs) then + if (fs_enumerator(fs_index, 1) == fs) then name_from_functionspace = fs_name(fs_index) return end if fs_index = fs_index + 1 - if (fs_index > ubound(fs_enumerator,1)) then - write( log_scratch_space, & - '(A, ": Unrecognised function space: ",I0)' ) module_name, fs - call log_event( log_scratch_space, log_level_error ) + if (fs_index > num_fs) then + write(log_scratch_space, & + '(A, ": Unrecognised function space: ",I0)') module_name, fs + call log_event(log_scratch_space, log_level_error) end if end do end function name_from_functionspace + !> Gets the function space identifier corresponding to a particular name. + !> + !> @param[in] name String holding the function space name. + !> + !> @return One of the function space enumerations. + !> + function functionspace_from_name(name) + + implicit none + + character(*), intent(in) :: name + integer(i_def) :: functionspace_from_name + integer(i_def) :: fs_index + + fs_index = 1 + do + if (fs_name(fs_index) == name) then + functionspace_from_name = fs_enumerator(fs_index, 1) + return + end if + + fs_index = fs_index + 1 + if (fs_index > num_fs) then + call log_event("Unknown function space " // name, log_level_error) + end if + end do + + end function functionspace_from_name + + !> Returns whether the given function space is horizontally continuous. + !> + !> @param[in] fs One of the function space enumerations. + !> + !> @return True=horizontally continuous, False=horizontally discontinuous + !> + function is_fs_horizontally_continuous(fs) result (continuous) + + implicit none + + integer(i_def), intent(in) :: fs + logical(l_native) :: continuous + + integer(i_def) :: fs_index + + continuous = .false. + fs_index = 1 + do + if ( fs_enumerator(fs_index, 1) == fs ) then + if ( fs_enumerator(fs_index, 2) == 1 ) continuous = .true. + exit + end if + fs_index = fs_index + 1 + if (fs_index > num_fs) then + write(log_scratch_space, & + '(A, ": Unrecognised function space: ",I0)') module_name, fs + call log_event(log_scratch_space, log_level_error) + end if + end do + + end function is_fs_horizontally_continuous + + !> Returns whether the given function space is vertically continuous. + !> + !> @param[in] fs One of the function space enumerations. + !> + !> @return True=vertically continuous, False=vertically discontinuous + !> + function is_fs_vertically_continuous(fs) result (continuous) + + implicit none + + integer(i_def), intent(in) :: fs + logical(l_native) :: continuous + + integer(i_def) :: fs_index + + continuous = .false. + fs_index = 1 + do + if ( fs_enumerator(fs_index, 1) == fs ) then + if ( fs_enumerator(fs_index, 3) == 1 ) continuous = .true. + exit + end if + fs_index = fs_index + 1 + if (fs_index > num_fs) then + write(log_scratch_space, & + '(A, ": Unrecognised function space: ",I0)') module_name, fs + call log_event(log_scratch_space, log_level_error) + end if + end do + + end function is_fs_vertically_continuous + end module fs_continuity_mod diff --git a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/fs_continuity_mod.f90 b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/fs_continuity_mod.f90 index 8fd18a41f5..1783118aa5 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/fs_continuity_mod.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/fs_continuity_mod.f90 @@ -9,65 +9,78 @@ ! https://code.metoffice.gov.uk/trac/lfric/browser/LFRic/trunk/LICENCE.original !----------------------------------------------------------------------------- ! -!> @brief Define enumerator variables that describe the different types of continuity. +!> @brief Define enumerator variables that describe the different types of +!> continuity. !> !> @details Enumerator variables that describe the different types of continuity !> that can be used to construct function spaces module fs_continuity_mod -use constants_mod, only: i_native, str_short -use log_mod, only: log_event, log_scratch_space, log_level_error - -implicit none - -private -public :: name_from_functionspace - -character(*), private, parameter :: module_name = 'fs_continuity_mod' - -!------------------------------------------------------------------------------- -! Module parameters -!------------------------------------------------------------------------------- -integer(i_native), public, parameter :: W0 = 173 -integer(i_native), public, parameter :: W1 = 194 -integer(i_native), public, parameter :: W2 = 889 -integer(i_native), public, parameter :: W2V = 857 -integer(i_native), public, parameter :: W2H = 884 -integer(i_native), public, parameter :: W2broken = 211 -integer(i_native), public, parameter :: W2trace = 213 -integer(i_native), public, parameter :: W2Vtrace = 666 -integer(i_native), public, parameter :: W2Htrace = 777 -integer(i_native), public, parameter :: W3 = 424 -integer(i_native), public, parameter :: Wtheta = 274 -integer(i_native), public, parameter :: Wchi = 869 - -integer(i_native), public, parameter :: fs_enumerator(12) = [W0, & - W1, & - W2, & - W2V, & - W2H, & - W2broken, & - W2trace, & - W2Vtrace, & - W2Htrace, & - W3, & - Wtheta, & - Wchi] - -character(str_short), public, parameter :: fs_name(12) & - = [character(str_short) :: 'W0', & - 'W1', & - 'W2', & - 'W2V', & - 'W2H', & - 'W2broken', & - 'W2trace', & - 'W2Htrace', & - 'W2Vtrace', & - 'W3', & - 'Wtheta', & - 'Wchi'] + use constants_mod, only : i_def, l_native, str_short + use log_mod, only : log_event, log_scratch_space, log_level_error + + implicit none + + private + public :: name_from_functionspace, functionspace_from_name, & + is_fs_horizontally_continuous, is_fs_vertically_continuous + + character(*), private, parameter :: module_name = 'fs_continuity_mod' + + !------------------------------------------------------------------------------- + ! Module parameters + !------------------------------------------------------------------------------- + integer(i_def), public, parameter :: W0 = 173 + integer(i_def), public, parameter :: W1 = 194 + integer(i_def), public, parameter :: W2 = 889 + integer(i_def), public, parameter :: W2V = 857 + integer(i_def), public, parameter :: W2H = 884 + integer(i_def), public, parameter :: W2broken = 211 + integer(i_def), public, parameter :: W2Hbroken = 112 + integer(i_def), public, parameter :: W2trace = 213 + integer(i_def), public, parameter :: W2Vtrace = 666 + integer(i_def), public, parameter :: W2Htrace = 777 + integer(i_def), public, parameter :: W3 = 424 + integer(i_def), public, parameter :: Wtheta = 274 + integer(i_def), public, parameter :: Wchi = 869 + + integer(i_def), private, parameter :: num_fs = 13 + + integer(i_def), private, parameter :: fs_enumerator(num_fs, 3) = & + transpose(reshape( [ & +! enumerator horizontally vertically +! continuous continuous + W0, 1, 1, & + W1, 1, 1, & + W2, 1, 1, & + W2V, 0, 1, & + W2H, 1, 0, & + W2broken, 0, 0, & + W2Hbroken, 0, 0, & + W2trace, 1, 1, & + W2Vtrace, 0, 1, & + W2Htrace, 1, 0, & + W3, 0, 0, & + Wtheta, 0, 1, & + Wchi, 0, 0 & + ], [3, num_fs] ) ) + + character(str_short), private, parameter :: fs_name(num_fs) = & + [character(str_short) :: & + 'W0', & + 'W1', & + 'W2', & + 'W2V', & + 'W2H', & + 'W2broken', & + 'W2Hbroken', & + 'W2trace', & + 'W2Htrace', & + 'W2Vtrace', & + 'W3', & + 'Wtheta', & + 'Wchi' ] contains @@ -77,30 +90,123 @@ module fs_continuity_mod !> !> @return String holding the function space name. !> - function name_from_functionspace( fs ) + function name_from_functionspace(fs) implicit none - integer(i_native), intent(in) :: fs + integer(i_def), intent(in) :: fs character(str_short) :: name_from_functionspace - integer(i_native) :: fs_index + integer(i_def) :: fs_index fs_index = 1 do - if (fs_enumerator(fs_index) == fs) then + if (fs_enumerator(fs_index, 1) == fs) then name_from_functionspace = fs_name(fs_index) return end if fs_index = fs_index + 1 - if (fs_index > ubound(fs_enumerator,1)) then - write( log_scratch_space, & - '(A, ": Unrecognised function space: ",I0)' ) module_name, fs - call log_event( log_scratch_space, log_level_error ) + if (fs_index > num_fs) then + write(log_scratch_space, & + '(A, ": Unrecognised function space: ",I0)') module_name, fs + call log_event(log_scratch_space, log_level_error) end if end do end function name_from_functionspace + !> Gets the function space identifier corresponding to a particular name. + !> + !> @param[in] name String holding the function space name. + !> + !> @return One of the function space enumerations. + !> + function functionspace_from_name(name) + + implicit none + + character(*), intent(in) :: name + integer(i_def) :: functionspace_from_name + integer(i_def) :: fs_index + + fs_index = 1 + do + if (fs_name(fs_index) == name) then + functionspace_from_name = fs_enumerator(fs_index, 1) + return + end if + + fs_index = fs_index + 1 + if (fs_index > num_fs) then + call log_event("Unknown function space " // name, log_level_error) + end if + end do + + end function functionspace_from_name + + !> Returns whether the given function space is horizontally continuous. + !> + !> @param[in] fs One of the function space enumerations. + !> + !> @return True=horizontally continuous, False=horizontally discontinuous + !> + function is_fs_horizontally_continuous(fs) result (continuous) + + implicit none + + integer(i_def), intent(in) :: fs + logical(l_native) :: continuous + + integer(i_def) :: fs_index + + continuous = .false. + fs_index = 1 + do + if ( fs_enumerator(fs_index, 1) == fs ) then + if ( fs_enumerator(fs_index, 2) == 1 ) continuous = .true. + exit + end if + fs_index = fs_index + 1 + if (fs_index > num_fs) then + write(log_scratch_space, & + '(A, ": Unrecognised function space: ",I0)') module_name, fs + call log_event(log_scratch_space, log_level_error) + end if + end do + + end function is_fs_horizontally_continuous + + !> Returns whether the given function space is vertically continuous. + !> + !> @param[in] fs One of the function space enumerations. + !> + !> @return True=vertically continuous, False=vertically discontinuous + !> + function is_fs_vertically_continuous(fs) result (continuous) + + implicit none + + integer(i_def), intent(in) :: fs + logical(l_native) :: continuous + + integer(i_def) :: fs_index + + continuous = .false. + fs_index = 1 + do + if ( fs_enumerator(fs_index, 1) == fs ) then + if ( fs_enumerator(fs_index, 3) == 1 ) continuous = .true. + exit + end if + fs_index = fs_index + 1 + if (fs_index > num_fs) then + write(log_scratch_space, & + '(A, ": Unrecognised function space: ",I0)') module_name, fs + call log_event(log_scratch_space, log_level_error) + end if + end do + + end function is_fs_vertically_continuous + end module fs_continuity_mod diff --git a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_constructor_helper_functions_mod.F90 b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_constructor_helper_functions_mod.F90 index 87d0469220..2ffcf2a32b 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_constructor_helper_functions_mod.F90 +++ b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_constructor_helper_functions_mod.F90 @@ -11,10 +11,11 @@ !> module function_space_constructor_helper_functions_mod - use constants_mod, only: i_def, i_halo_index, r_def, IMDI + use constants_mod, only: i_def, i_halo_index, r_def, IMDI, l_def use mesh_mod, only: mesh_type use fs_continuity_mod, only: W0, W1, W2, W2V, W2H, & W2broken, W2trace, & + W2Hbroken, & W2Vtrace, W2Htrace, & W3, Wtheta, Wchi use reference_element_mod, only: reference_element_type, & @@ -25,11 +26,11 @@ module function_space_constructor_helper_functions_mod WB, SB, EB, NB, & SW, SE, NE, NW, & WT, ST, ET, NT - + use log_mod, only: log_event, LOG_LEVEL_ERROR implicit none private - public :: ndof_setup, basis_setup, dofmap_setup, levels_setup + public :: ndof_setup, basis_setup, dofmap_setup, levels_setup, generate_fs_id ! Select entities in the function space type select_entity_type @@ -110,8 +111,7 @@ subroutine setup_select_entities( mesh, entity_all, entity_theta, & entity_w2h%edges = IMDI entity_w2h%verts = IMDI - nullify( reference_element ) - + nullify(reference_element) end subroutine setup_select_entities @@ -187,7 +187,7 @@ subroutine setup_select_data_entities( mesh, entity_all, entity_theta, & entity_w2h%edges = IMDI entity_w2h%verts = IMDI - nullify( reference_element ) + nullify(reference_element) end subroutine setup_select_data_entities @@ -200,41 +200,63 @@ end subroutine setup_select_data_entities !> composite. !> !> @param[in] mesh Mesh to define the function space on. - !> @param[in] element_order Polynomial order of the function space. + !> @param[in] element_order_h Polynomial order of the function space in the + !> horizontal directions. + !> @param[in] element_order_v Polynomial order of the function space in the + !> vertical direction. !> @param[in] gungho_fs Enumeration of the function space. !> @param[out] ndof_vert Number of dofs on each vertex. - !> @param[out] ndof_edge Number of dofs on each edge. - !> @param[out] ndof_face Number of dofs on each face. + !> @param[out] ndof_edge_h Number of dofs on each edge in the horizontal. + !> @param[out] ndof_edge_v Number of dofs on each edge in the vertical. + !> @param[out] ndof_face_h Number of dofs on each face in the horizontal. + !> @param[out] ndof_face_v Number of dofs on each face in the vertical. !> @param[out] ndof_vol Number of dofs in each volume. - !> @param[out] ndof_cell Total Number of dofs associated with a cell. - !> @param[out] ndof_glob Total Number of global dofs. - !> @param[out] ndof_interior Number of dofs with no vertical - !> connectivity. + !> @param[out] ndof_cell Total number of dofs associated with a cell. + !> @param[out] ndof_glob Total number of dofs on a rank. + !> @param[out] ndof_interior Number of dofs with no vertical connectivity. !> @param[out] ndof_exterior Number of dofs with vertical connectivity. - !> - subroutine ndof_setup( mesh, element_order, gungho_fs, & - ndof_vert, ndof_edge, ndof_face, ndof_vol, & - ndof_cell, ndof_glob, ndof_interior, ndof_exterior ) + ! + ! + ! .+---B--+ In the following an edge is called vertical if it is + ! .' | .'| normal to the horizontal plane (such as edge A), and + ! +---+--+' A horizontal if it is parallel to it (such as edge B). + ! | P | | | + ! | ,+--+---+ A face will be called horizontal if it is normal to + ! |.' Q | .' the horizontal plane (such as face P) and vertical if it + ! +------+' is parallel to it (such as face Q). + ! + ! These are chosen to agree with the naming of W2H and + ! W2V. + + subroutine ndof_setup( mesh, element_order_h, element_order_v, gungho_fs, & + ndof_vert, ndof_edge_h, ndof_edge_v, ndof_face_h, & + ndof_face_v, ndof_vol, ndof_cell, ndof_glob, & + ndof_interior, ndof_exterior ) ! NOTE: ndofs will be used as short hand for Number of Degrees Of Freedom implicit none ! Input type(mesh_type), intent(in), pointer :: mesh - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h, element_order_v integer(i_def), intent(in) :: gungho_fs ! Output - ! Number of dofs per ... - integer(i_def), intent(out) :: ndof_vert ! vertex entity - integer(i_def), intent(out) :: ndof_edge ! edge entity - integer(i_def), intent(out) :: ndof_face ! face entity - integer(i_def), intent(out) :: ndof_vol ! volume entity - - integer(i_def), intent(out) :: ndof_cell ! 3D-cell entity - integer(i_def), intent(out) :: ndof_interior ! interior entity (in vertical) - integer(i_def), intent(out) :: ndof_exterior ! exterior entity (in vertical) - integer(i_def), intent(out) :: ndof_glob ! 3D-mesh (on a rank) + integer(i_def), intent(out) :: ndof_vert ! ndof per vertex entity + integer(i_def), intent(out) :: ndof_edge_h ! ndof per horizontal edge + ! entity + integer(i_def), intent(out) :: ndof_edge_v ! ndof per vertical edge entity + integer(i_def), intent(out) :: ndof_face_h ! ndof per horizontal face + ! entity + integer(i_def), intent(out) :: ndof_face_v ! ndof per vertical face entity + integer(i_def), intent(out) :: ndof_vol ! ndof per volume entity + + integer(i_def), intent(out) :: ndof_cell ! ndof per 3D-cell entity + integer(i_def), intent(out) :: ndof_interior ! ndof per interior entity + ! (in vertical) + integer(i_def), intent(out) :: ndof_exterior ! ndof per exterior entity + ! (in vertical) + integer(i_def), intent(out) :: ndof_glob ! ndof per 3D-mesh (on a rank) ! Local variables @@ -244,10 +266,7 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! Variables for properties of the local 3D-Mesh integer(i_def) :: ncells ! No. of 2D-cells in 3D-mesh partition integer(i_def) :: nlayers ! No. of layers of 3D-cells - integer(i_def) :: nface_g ! No. of faces - integer(i_def) :: nedge_g ! No. of edges - integer(i_def) :: nvert_g ! No. of vertices - integer(i_def) :: nedges_per_level ! No. of edges per level + integer(i_def) :: nedges_2d ! No. of edges per level ! Variables for Exterior-Interior topology (vertical direction) integer(i_def) :: nverts_exterior ! No. of vertices per exterior entity @@ -256,25 +275,34 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & integer(i_def) :: nedges_interior ! No. of edges per interior entity integer(i_def) :: nfaces_interior ! No. of faces per interior entity - integer(i_def) :: k + integer(i_def) :: nface_g_h ! Global No. of horizontal faces + integer(i_def) :: nface_g_v ! Global No. of vertical faces + integer(i_def) :: nedge_g_h ! Global No. of horizontal edges + integer(i_def) :: nedge_g_v ! Global No. of vertical edges + integer(i_def) :: nvert_g ! Global No. of vertices - ! Adding ndof for exterior and interior composite entities - ! - ! ndof_exterior = ndof_edge*nedges_exterior - ! + ndof_face*nfaces_exterior - ! + ndof_vert*nverts_exterior + integer(i_def) :: k_h, k_v + + ! Adding ndof for exterior and interior composite entities: ! - ! ndof_interior = ndof_edge*nedges_interior - ! + ndof_face*nfaces_interior - ! + ndof_vol + ! ndof_exterior = ndof_edge_h*nedges_exterior + ! + ndof_face_v*nfaces_exterior + ! + ndof_vert*nverts_exterior + + ! ndof_interior = ndof_edge_v*nedges_interior + ! + ndof_face_h*nfaces_interior + ! + ndof_vol ! - ! Elements on interior/exterior cell decomposition in vertical, - ! the horizontal faces and associated edges/vertices - ! (i.e. top OR bottom ) are classed as exterior entities. - ! The vertical faces/edges are classed as an interior entities. + ! Elements on interior/exterior cell decomposition in vertical. + ! The vertical faces, horizontal edges, and vertices (i.e. top OR bottom ) + ! are classed as exterior entities. + ! The horizontal faces and vertical edges are classed as an interior + ! entities. reference_element => mesh%get_reference_element() + ! Local values: + ! Values for cell entity calculations nverts_exterior = reference_element%get_number_2d_vertices() nedges_exterior = reference_element%get_number_2d_edges() nfaces_exterior = 1 @@ -282,41 +310,45 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & nedges_interior = reference_element%get_number_2d_vertices() nfaces_interior = reference_element%get_number_2d_edges() - - ! Local values - nlayers = mesh % get_nlayers() - ncells = mesh % get_ncells_2d_with_ghost() - nface_g = mesh % get_nfaces() - nedge_g = mesh % get_nedges() - nvert_g = mesh % get_nverts() - nedges_per_level = mesh % get_nedges_2d() - - ndof_vert = 0 - ndof_edge = 0 - ndof_face = 0 - ndof_vol = 0 - ndof_cell = 0 - ndof_glob = 0 - - ndof_interior = 0 - ndof_exterior = 0 - - k = element_order + ! Values for global calculations + nlayers = mesh%get_nlayers() + ncells = mesh%get_ncells_2d_with_ghost() + nedges_2d = mesh%get_nedges_2d() + + nface_g_v = ncells*(nlayers + 1) + nface_g_h = nedges_2d*nlayers + nedge_g_v = mesh%get_nverts_2d()*nlayers + nedge_g_h = nedges_2d*(nlayers + 1) + nvert_g = mesh%get_nverts() + + ! dof values + ndof_vert = 0 + ndof_edge_h = 0 + ndof_edge_v = 0 + ndof_face_h = 0 + ndof_face_v = 0 + ndof_vol = 0 + ndof_cell = 0 + ndof_glob = 0 + + k_h = element_order_h + k_v = element_order_v ! Possible modifications to number of dofs ! on edges depending on presets select case (gungho_fs) case (W0) - ! H1 locates dofs on the element vertices for a element order = 0, + ! H1 locates dofs on the element vertices for element order = 0, ! though the order for the H1 function space is k+1, i.e. ! linear across the element on each axis - ndof_vert = 1 - ndof_edge = k - ndof_face = k*k - ndof_vol = k*k*k - ndof_cell = (k+2)*(k+2)*(k+2) - + ndof_vert = 1 + ndof_edge_h = k_h + ndof_edge_v = k_v + ndof_face_h = k_h*k_v + ndof_face_v = k_h*k_h + ndof_vol = k_h*k_h*k_v + ndof_cell = (k_h + 2)*(k_h + 2)*(k_v + 2) case (W1) ! Dofs located on edges, as vectors @@ -324,11 +356,14 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! For order 0, the vector is constant along the ! edge, but can vary linearly normal to it. - ndof_edge = (k+1) - ndof_face = 2*(k+1)*k - ndof_vol = 3*(k+1)*k*k - ndof_cell = 3*(k+1)*(k+2)*(k+2) - + ndof_edge_h = (k_h + 1) + ndof_edge_v = (k_v + 1) + ndof_face_h = (k_h + 1)*k_v + k_h*(k_v + 1) + ndof_face_v = 2*(k_h + 1)*k_h + ndof_vol = 2*k_h*(k_h + 1)*k_v & + + k_h*k_h*(k_v + 1) + ndof_cell = 2*(k_h + 1)*(k_h + 2)*(k_v + 2) & + + (k_h + 2)*( k_h + 2)*(k_v + 1) case (W2) ! Dofs are located on faces for vector fields @@ -339,29 +374,29 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! vary linearly passing through the face(normal) to ! the next cell. ! - ! So linear in normal: 1-dim, ndof = 2 - ! So constant in tangential: 2-dim, each ndof = 1 - ! So 3 dimensions each with ndof (k+2)(k+1)(k+1) - ! ! NOTE: Not correct for simplices - ndof_face = (k+1)*(k+1) - ndof_vol = 3*(k+1)*(k+1)*k - ndof_cell = 3*(k+1)*(k+1)*(k+2) - + ndof_face_h = (k_h + 1)*(k_v + 1) + ndof_face_v = (k_h + 1)*(k_h + 1) + ndof_vol = 2*k_h*(k_h + 1)*(k_v + 1) & + + (k_h + 1)*(k_h + 1)*k_v + ndof_cell = 2*(k_h + 2)*(k_h + 1)*(k_v + 1) & + + (k_h + 1)*(k_h + 1)*(k_v + 2) case (W2H) + ! Dofs are located at the horizontal components of W2, giving variables + ! the values of the first term in the sums in the W2 case. nfaces_exterior = 0 - ndof_face = (k+1)*(k+1) - ndof_vol = 2*k*(k+1)*(k+1) - ndof_cell = 2*(k+2)*(k+1)*(k+1) - + ndof_face_h = (k_h + 1)*(k_v + 1) + ndof_vol = 2*k_h*(k_h + 1)*(k_v + 1) + ndof_cell = 2*(k_h + 1)*(k_h + 2)*(k_v + 1) case (W2V) + ! Dofs are located at the vertical components of W2, giving variables + ! the values of the second term in the sums in the W2 case. nfaces_interior = 0 - ndof_face = (k+1)*(k+1) - ndof_vol = 1*k*(k+1)*(k+1) - ndof_cell = 1*(k+2)*(k+1)*(k+1) - + ndof_face_v = (k_h + 1)*(k_h + 1) + ndof_vol = (k_h + 1)*(k_h + 1)*k_v + ndof_cell = (k_h + 1)*(k_h + 1)*(k_v + 2) case (W2broken) ! Dofs are geometrically located on faces for @@ -372,15 +407,28 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! ! For order 0 the value of the vector normal to the ! face is constant across the face(tangential) but can - ! varying linearly passing through the face(normal) to + ! vary linearly passing through the face(normal) to ! the next cell. ! - ! So linear in normal: 1-dim, ndof = 2 - ! So constant in tangengial: 2-dim, each ndof = 1 - ! So 3 dimensions each with ndof (k+2)(k+1)(k+1) + ! NOTE: Not correct for simplices + ndof_vol = 2*(k_h + 1)*(k_h + 2)*(k_v + 1) & + + (k_h + 1)*(k_h + 1)*(k_v + 2) + ndof_cell = ndof_vol + + case (W2Hbroken) + ! Dofs are geometrically located on faces for + ! vector fields and direction is normal to the face. + ! However, they are topologically associated with + ! the cell volume. Hence, this function space is + ! discontinuous between cells. + ! + ! For order 0 the value of the vector normal to the + ! face is constant across the face(tangential) but can + ! vary linearly passing through the face(normal) to + ! the next cell. ! ! NOTE: Not correct for simplices - ndof_vol = 3*(k+1)*(k+1)*(k+2) + ndof_vol = 2*(k_h + 1)*(k_h + 2)*(k_v + 1) ndof_cell = ndof_vol case (W2trace) @@ -391,10 +439,11 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! This space is discontinuous across edges/vertices. ! ! NOTE: Not correct for simplices - ndof_face = (k+1)*(k+1) - ndof_cell = 6*ndof_face + ndof_face_h = (k_h + 1)*(k_v + 1) + ndof_face_v = (k_h + 1)*(k_h + 1) + ndof_cell = 4*ndof_face_h + 2*ndof_face_v - case (W2Vtrace) + case (W2Vtrace) ! This function space is the result of taking the trace ! of a W2V Hdiv space (or equivalently taking only the ! vertical components of the trace of the W2 space). @@ -404,8 +453,9 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! This space is discontinuous across edges/vertices. ! ! NOTE: Not correct for simplices - ndof_face = (k+1)*(k+1) - ndof_cell = 2*ndof_face + nfaces_interior = 0 + ndof_face_v = (k_h + 1)*(k_h + 1) + ndof_cell = 2*ndof_face_v case (W2Htrace) ! This function space is the result of taking the trace @@ -417,8 +467,9 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! This space is discontinuous across edges/vertices. ! ! NOTE: Not correct for simplices - ndof_face = (k+1)*(k+1) - ndof_cell = 4*ndof_face + nfaces_exterior = 0 + ndof_face_h = (k_h + 1)*(k_v + 1) + ndof_cell = 4*ndof_face_h case (W3) ! Order of this function space is same as base order @@ -429,46 +480,39 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! between cells. ! Number of dofs on each dimension is lowest order + 1 - ndof_vol = (k+1)*(k+1)*(k+1) + ndof_vol = (k_h + 1)*(k_h + 1)*(k_v + 1) ndof_cell = ndof_vol - case (WTHETA) nfaces_interior = 0 - ndof_face = (k+1)*(k+1) - ndof_vol = k*(k+1)*(k+1) - ndof_cell = (k+2)*(k+1)*(k+1) + ndof_face_v = (k_h + 1)*(k_h + 1) + ndof_vol = (k_h + 1)*(k_h + 1)*k_v + ndof_cell = (k_h + 1)*(k_h + 1)*(k_v + 2) + case (WCHI) - ndof_vol = (k+1)*(k+1)*(k+1) + ndof_vol = (k_h + 1)*(k_h + 1)*(k_v + 1) ndof_cell = ndof_vol end select - ndof_exterior = ndof_vert*nverts_exterior & - + ndof_edge*nedges_exterior & - + ndof_face*nfaces_exterior + ndof_exterior = ndof_vert * nverts_exterior & + + ndof_edge_h * nedges_exterior & + + ndof_face_v * nfaces_exterior - ndof_interior = ndof_edge*nedges_interior & - + ndof_face*nfaces_interior & + ndof_interior = ndof_edge_v * nedges_interior & + + ndof_face_h * nfaces_interior & + ndof_vol ! Calculated the global number of dofs on the function space - select case (gungho_fs) - case (W0, W1, W2, W2broken, W2trace, W3, WCHI) - ndof_glob = ncells*nlayers*ndof_vol + nface_g*ndof_face & - + nedge_g*ndof_edge + nvert_g*ndof_vert + ndof_glob = ncells*nlayers*ndof_vol & + + nface_g_h*ndof_face_h & + + nface_g_v*ndof_face_v & + + nedge_g_h*ndof_edge_h & + + nedge_g_v*ndof_edge_v & + + nvert_g*ndof_vert - case (WTHETA, W2V, W2Vtrace) - ndof_glob = ncells*nlayers*ndof_vol + ncells*(nlayers+1)*ndof_face + nullify(reference_element) - case (W2H, W2Htrace) - ndof_glob = ncells*nlayers*ndof_vol + nedges_per_level*nlayers*ndof_face & - + nedge_g*ndof_edge + nvert_g*ndof_vert - end select - - nullify( reference_element ) - - return end subroutine ndof_setup !--------------------------------------------------------------------------- @@ -479,148 +523,216 @@ end subroutine ndof_setup !> for cube elements. It is used by the function_space_type constructor and !> is unlikely to be useful elsewhere. !> - !> @param[in] element_order Polynomial order of the function space. - !> @param[in] gungho_fs Enumeration of the function space. - !> @param[in] ndof_vert Number dofs on each vertex. - !> @param[in] ndof_cell Total number of dofs associated with a cell. + !> @param[in] element_order_h Polynomial order of the function space in + !> horizontal direction. + !> @param[in] element_order_v Polynomial order of the function space in + !> vertical direction. + !> @param[in] gungho_fs Enumeration of the function space. + !> @param[in] ndof_vert Number dofs on each vertex. + !> @param[in] ndof_cell Total number of dofs associated with a cell. !> @param[in] reference_element Object describing the reference element of !> the mesh. - !> @param[out] basis_index Array containing index of polynomial function. - !> @param[out] basis_order Polynomial order of basis function. - !> @param[out] basis_vector Direction of basis for vector functions. - !> @param[out] basis_x Array of nodal points of the basis functions. - !> @param[out] nodal_coords 3D coordinates of zeros of the basis functions. + !> @param[out] basis_index Array containing index of polynomial + !> function. + !> @param[out] basis_order Polynomial order of basis function. + !> @param[out] basis_vector Direction of basis for vector functions. + !> @param[out] basis_x Array of nodal points of the x and y basis + !> functions. + !> @param[out] basis_z Array of nodal points of the basis z basis + !> functions. + !> @param[out] nodal_coords 3D coordinates of zeros of the basis + !> functions. !> @param[out] dof_on_vert_boundary Array indication if a dof is on the top !> or bottom boundary of a cell. - !> @param[out] entity_dofs Array of labels which maps degree of freedom - !> index to geometric entity the dof lies on. + !> @param[out] entity_dofs Array of labels which maps degree of freedom + !> index to geometric entity the dof lies on. !> - subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & - reference_element, & - basis_index, basis_order, basis_vector, basis_x, & - nodal_coords, dof_on_vert_boundary, entity_dofs ) + subroutine basis_setup( element_order_h, element_order_v, gungho_fs, & + ndof_vert, ndof_cell, reference_element, & + basis_index, basis_order, basis_vector, basis_x, & + basis_z, nodal_coords, dof_on_vert_boundary, & + entity_dofs ) implicit none ! Input - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h + integer(i_def), intent(in) :: element_order_v integer(i_def), intent(in) :: gungho_fs - ! Number of dofs per entity - integer(i_def), intent(in) :: ndof_vert ! ndofs per vertex - integer(i_def), intent(in) :: ndof_cell ! ndofs per 3D-cell + integer(i_def), intent(in) :: ndof_vert ! ndofs (number of dofs) per vertex + integer(i_def), intent(in) :: ndof_cell ! ndofs (number of dofs) per 3D-cell class(reference_element_type), intent(in), pointer :: reference_element ! Output - integer(i_def), intent(out) :: basis_index (:,:) - integer(i_def), intent(out) :: basis_order (:,:) - real(r_def), intent(out) :: basis_vector (:,:) - real(r_def), intent(out) :: basis_x (:,:,:) - real(r_def), intent(out) :: nodal_coords (:,:) - integer(i_def), intent(out) :: dof_on_vert_boundary (:,:) + integer(i_def), intent(out) :: basis_index(:,:) + integer(i_def), intent(out) :: basis_order(:,:) + real(r_def), intent(out) :: basis_vector(:,:) + real(r_def), intent(out) :: basis_x(:,:,:) + real(r_def), intent(out) :: basis_z(:,:) + real(r_def), intent(out) :: nodal_coords(:,:) + integer(i_def), intent(out) :: dof_on_vert_boundary(:,:) integer(i_def), intent(out) :: entity_dofs(:) - integer(i_def) :: k + ! Local variables + integer(i_def) :: k_h, k_v ! Horizontal and vertical element orders + integer(i_def) :: k_switch ! Can be set to k_h or k_v + + integer(i_def) :: i ! General loop variable + integer(i_def) :: jx, jy, jz ! x, y, z loop variables + integer(i_def) :: idx ! Index of dof + integer(i_def) :: j1, j2 ! Face/edge loop variables + integer(i_def) :: j(3) ! Tuple containing face or edge indices such + ! as j1, j2, face_idx and edge_idx + + integer(i_def) :: j2l_edge(12, 3), j2l_face(6, 3) ! Indexes conversion from + ! j to lx, ly and lz + + integer(i_def) :: face_idx(6), edge_idx(12, 2) ! Indices of nodal points + ! on faces and edges + + integer(i_def), allocatable :: lx(:), ly(:), lz(:) ! 3d indices of dofs + + real(r_def), allocatable :: unit_vec(:,:) ! Unit tangent to an edge dof + ! or normal to a face dof - integer(i_def) :: i, jx, jy, jz, poly_order, idx, j1, j2 - integer(i_def) :: j(3), j2l_edge(12,3), j2l_face(6,3), face_idx(6), edge_idx(12,2) - integer(i_def), allocatable :: lx(:), ly(:), lz(:) - real(r_def), allocatable :: unit_vec(:,:) + real(r_def) :: x1h(element_order_h+2) ! Evenly spaces nodes of continuous + ! 1D element (used in horizontal) + real(r_def) :: x1v(element_order_v+2) ! Evenly spaces nodes of continuous + ! 1D element (used in vertical) - real(r_def) :: x1(element_order+2) - real(r_def) :: x2(element_order+2) + real(r_def) :: x2h(element_order_h+2) ! Evenly spaces nodes of discontinuous + ! 1D element (used in horizontal). + ! Note: one larger than required + real(r_def) :: x2v(element_order_v+2) ! Evenly spaces nodes of discontinuous + ! 1D element (used in vertical). + ! Note: one larger than required + + real(r_def) :: coordinate(3) ! Coordinate of a vertex - real(r_def) :: coordinate(3) integer(i_def) :: edges_on_face(reference_element%get_number_edges()) integer(i_def) :: number_faces, number_edges, number_vertices - integer(i_def) :: number_horizontal_edges + integer(i_def) :: number_2d_edges + integer(i_def) :: number_faces_h number_faces = reference_element%get_number_faces() number_edges = reference_element%get_number_edges() number_vertices = reference_element%get_number_vertices() - number_horizontal_edges = reference_element%get_number_2d_edges() + number_2d_edges = reference_element%get_number_2d_edges() + number_faces_h = reference_element%get_number_2d_edges() ! To uniquely specify a 3D tensor product basis function the following is ! needed: ! basis_order(3): The polynomial order in the x,y,z directions - ! basis_x(3,basis_order+1): The nodal points of the polynomials in each - ! direction + ! basis_x(element_order_h + 2, 2, ndof_cell): + ! The nodal points of the polynomials in each horizontal + ! direction at each dof + ! basis_z(element_order_v + 2, ndof_cell): + ! The nodal points of the polynomials in each vertical + ! direction at each dof ! basis_index(3): The index of the nodal points array at which the basis ! function is unity ! basis_vector(3): Additionally if the function space is a vector then a ! unit vector is needed. ! Although not strictly needed the nodal coordinates at which each basis - ! function equals 1 is stored as nodal_coords + ! function equals 1 is stored as nodal_coords. ! A flag is also set to 0 if a basis function is associated with an entity ! on the top or bottom of the cell, i.e has nodal_coord(3) = 0 or 1 - k = element_order + k_h = element_order_h + k_v = element_order_v - ! Allocate to be larger than should be needed - allocate( lx(3*(k+2)**3) ) - allocate( ly(3*(k+2)**3) ) - allocate( lz(3*(k+2)**3) ) + allocate( lx(ndof_cell) ) + allocate( ly(ndof_cell) ) + allocate( lz(ndof_cell) ) lx(:) = 0 ly(:) = 0 lz(:) = 0 ! Positional arrays - need two, i.e quadratic and linear for RT1 - do i=1,k+2 - x1(i) = real(i-1,r_def)/real(k+1,r_def) + do i = 1, k_h + 2 + x1h(i) = real(i - 1, r_def) / real(k_h + 1, r_def) + end do + + if (k_h == 0) then + x2h(1) = 0.5_r_def + else + if (gungho_fs == W3 .or. gungho_fs == Wtheta) then + ! Evenly space the points away from the element edges for high order + ! spaces - this helps with visualising the output + do i = 1, k_h + 1 + x2h(i) = real(i, r_def) / real(k_h + 2, r_def) + end do + else + do i = 1, k_h + 1 + x2h(i) = real(i - 1, r_def) / real(k_h, r_def) + end do + end if + end if + + ! The same for vertical positional arrays + do i = 1, k_v + 2 + x1v(i) = real(i - 1, r_def) / real(k_v + 1, r_def) end do - if ( k == 0 ) then - x2(1) = 0.5_r_def + if (k_v == 0) then + x2v(1) = 0.5_r_def else - if ( gungho_fs == W3 .or. gungho_fs == Wtheta ) then + if (gungho_fs == W3 .or. gungho_fs == Wtheta) then ! Evenly space the points away from the element edges for high order ! spaces - this helps with visualising the output - do i=1,k+1 - x2(i) = real(i,r_def)/real(k+2,r_def) + do i = 1, k_v + 1 + x2v(i) = real(i, r_def) / real(k_v + 2, r_def) end do else - do i=1,k+1 - x2(i) = real(i-1,r_def)/real(k,r_def) + do i = 1, k_v + 1 + x2v(i) = real(i - 1, r_def) / real(k_v, r_def) end do end if end if - if ( k == 0 ) x2(1) = 0.5_r_def ! This value isn't needed and is always multipled by 0 - x2(k+2) = 0.0_r_def + x2h(k_h + 2) = 0.0_r_def + x2v(k_v + 2) = 0.0_r_def - ! Some look arrays based upon reference cube topology - ! index of nodal points for dofs located on faces. - ! Faces are defined as having one coodinate fixed, + ! Some look arrays based upon reference cube topology: + + ! Index of nodal points for dofs located on faces. + ! Faces are defined as having one coordinate fixed, ! i.e. for face 1 x = 0 for all points on the face - ! and for face 4 y = 1 for all points on the face + ! and for face 4 y = 1 for all points on the face. ! This array give the index for the fixed coordinate for each face. ! If a face has fixed coordinate = 0 the index is 1 ! If a face has fixed coordinate = 1 the index is k+2 - face_idx = (/ 1, 1, k+2, k+2, 1, k+2 /) + face_idx = (/ 1, 1, k_h + 2, k_h + 2, 1, k_v + 2 /) - ! index of nodal points for dofs located on edges - ! edges are defined as having two coodinates fixed, - ! i.e. for edge 1 x = 0 & z = 0 for all points on the edge - ! and for edge 6 x = 1 y = 0 for all points on the edge + ! Index of nodal points for dofs located on edges. + ! Edges are defined as having two coordinates fixed, + ! i.e. for edge 1 x = 0 & z = 0 for all points on the edge, + ! and for edge 6 x = 1 y = 0 for all points on the edge. ! These arrays give the index for the two fixed coordinates for each edge. ! If an edge has fixed coordinate = 0 the index is 1 ! If an edge has fixed coordinate = 1 the index is k+2 - edge_idx(:,1) = (/ 1, 1, k+2, k+2, 1, k+2, k+2, 1, 1, 1, k+2, k+2 /) - edge_idx(:,2) = (/ 1, 1, 1, 1, 1, 1, k+2, k+2, k+2, k+2, k+2, k+2 /) + ! The fixed coordinates are stored in order x, y, z so if the fixed + ! coordinates are x and z then edge_idx(:, 1) stores x and edge_idx(:, 1) + ! stores z, and for other combinations they remain in this order. + edge_idx(:, 1) = & + (/ 1, 1, k_h + 2, k_h + 2, 1, k_h + 2, k_h + 2, 1, 1, 1, k_h + 2, k_h + 2 /) + edge_idx(:, 2) = & + (/ 1, 1, 1, 1, 1, 1, k_h + 2, k_h + 2, k_v + 2, k_v + 2, k_v + 2, k_v + 2 /) ! Each dof living on a face or edge will have its index defined by three ! integers (j1, j2, j3) where: - ! for faces one j will be the face index and the other two can vary - ! for edges two j's will be the edge indices and the final one can vary - ! These j's need to be converted to the indices lx ,ly, lz + ! -for faces, one j will be the face index and the other two can vary. + ! -for edges, two j's will be the edge indices and the final one can vary. + ! These j's need to be converted to the indices lx ,ly, lz. ! For faces the first value of j2l is the l that corresponds to the - ! constant coordinate, so for face 1 lx = j3, ly = j2 and lz = j1/ - ! for edge 1: lx = j2, ly = j1, and lz = j3 + ! constant coordinate, so for face 1: lx = j3, ly = j2 and lz = j1; for + ! edge 1: lx = j2, ly = j1, and lz = j3. j2l_face(1,:) = (/ 3, 2, 1 /) j2l_face(2,:) = (/ 2, 3, 1 /) j2l_face(3,:) = (/ 3, 2, 1 /) @@ -628,15 +740,15 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & j2l_face(5,:) = (/ 1, 2, 3 /) j2l_face(6,:) = (/ 1, 2, 3 /) - j2l_edge(1 ,:) = (/ 2, 1, 3 /) - j2l_edge(2 ,:) = (/ 1, 2, 3 /) - j2l_edge(3 ,:) = (/ 2, 1, 3 /) - j2l_edge(4 ,:) = (/ 1, 2, 3 /) - j2l_edge(5 ,:) = (/ 2, 3, 1 /) - j2l_edge(6 ,:) = (/ 2, 3, 1 /) - j2l_edge(7 ,:) = (/ 2, 3, 1 /) - j2l_edge(8 ,:) = (/ 2, 3, 1 /) - j2l_edge(9 ,:) = (/ 2, 1, 3 /) + j2l_edge(1,:) = (/ 2, 1, 3 /) + j2l_edge(2,:) = (/ 1, 2, 3 /) + j2l_edge(3,:) = (/ 2, 1, 3 /) + j2l_edge(4,:) = (/ 1, 2, 3 /) + j2l_edge(5,:) = (/ 2, 3, 1 /) + j2l_edge(6,:) = (/ 2, 3, 1 /) + j2l_edge(7,:) = (/ 2, 3, 1 /) + j2l_edge(8,:) = (/ 2, 3, 1 /) + j2l_edge(9,:) = (/ 2, 1, 3 /) j2l_edge(10,:) = (/ 1, 2, 3 /) j2l_edge(11,:) = (/ 2, 1, 3 /) j2l_edge(12,:) = (/ 1, 2, 3 /) @@ -648,18 +760,16 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! Allocate arrays to allow on the fly evaluation of basis functions select case (gungho_fs) - case (W1, W2, W2H, W2V, W2broken, W2trace, W2Vtrace, W2Htrace) + case (W1, W2, W2H, W2V, W2broken, W2Hbroken, W2trace, W2Vtrace, W2Htrace) allocate( unit_vec(3, ndof_cell) ) end select - select case (gungho_fs) case (W0) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of CG spaces - !--------------------------------------------------------------------------- - poly_order = k+1 + !------------------------------------------------------------------------- ! Compute indices of functions idx = 1 @@ -667,9 +777,9 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! =============================== ! dofs in volume ! =============================== - do jz=2, k+1 - do jy=2, k+1 - do jx=2, k+1 + do jz = 2, k_v + 1 + do jy = 2, k_h + 1 + do jx = 2, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz @@ -683,15 +793,23 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! =============================== ! dofs on faces ! =============================== - do i=1, number_faces - do j1=2, k+1 - do j2=2, k+1 + do i = 1, number_faces + ! For horizontal face loop over vertical then horizontal orders + if (i <= number_faces_h) then + k_switch = k_v + ! For vertical face loop over horizontal order twice + else + k_switch = k_h + end if + + do j1 = 2, k_switch + 1 + do j2 = 2, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) ! Label face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -702,63 +820,70 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! =============================== ! dofs on edges ! =============================== - do i=1, number_edges - do j1=2, k+1 - j(1) = j1 - j(2) = edge_idx(i,1) - j(3) = edge_idx(i,2) - lx(idx) = j(j2l_edge(i,1)) - ly(idx) = j(j2l_edge(i,2)) - lz(idx) = j(j2l_edge(i,3)) + do i = 1, number_edges + ! If edge is horizontal loop to k_h+1 + if ((i <= number_2d_edges) .OR. & + (i > number_edges - number_2d_edges)) then + k_switch = k_h + ! If edge vertical loop to k_v+1 + else + k_switch = k_v + end if + + do j1 = 2, k_switch + 1 + j(1) = j1 + j(2) = edge_idx(i, 1) + j(3) = edge_idx(i, 2) + lx(idx) = j(j2l_edge(i, 1)) + ly(idx) = j(j2l_edge(i, 2)) + lz(idx) = j(j2l_edge(i, 3)) ! Label edge degrees of freedom entity_dofs(idx) = reference_element%get_edge_entity(i) - idx = idx + 1 + idx = idx + 1 end do end do ! =============================== ! dofs on vertices ! =============================== - do i=1, number_vertices - do j1=1, ndof_vert - coordinate = reference_element%get_vertex( i ) - lx(idx) = 1+(k+1)*int(coordinate(1)) - ly(idx) = 1+(k+1)*int(coordinate(2)) - lz(idx) = 1+(k+1)*int(coordinate(3)) + do i = 1, number_vertices + do j1 = 1, ndof_vert + coordinate = reference_element%get_vertex(i) + lx(idx) = 1 + (k_h + 1) * int(coordinate(1)) + ly(idx) = 1 + (k_h + 1) * int(coordinate(2)) + lz(idx) = 1 + (k_v + 1) * int(coordinate(3)) ! Label vertex degrees of freedom entity_dofs(idx) = reference_element%get_vertex_entity(i) - idx = idx + 1 + idx = idx + 1 end do end do - do i=1, ndof_cell - + do i = 1, ndof_cell ! Explicitly for quads, as ngp_h = ngp_v * ngp_v - nodal_coords(1,i) = x1(lx(i)) - nodal_coords(2,i) = x1(ly(i)) - nodal_coords(3,i) = x1(lz(i)) - - basis_order(:,i) = poly_order - basis_x(:,1,i) = x1 - basis_x(:,2,i) = x1 - basis_x(:,3,i) = x1 - + nodal_coords(1, i) = x1h(lx(i)) + nodal_coords(2, i) = x1h(ly(i)) + nodal_coords(3, i) = x1v(lz(i)) + + basis_order(1, i) = k_h + 1 + basis_order(2, i) = k_h + 1 + basis_order(3, i) = k_v + 1 + basis_x(:, 1, i) = x1h(:) + basis_x(:, 2, i) = x1h(:) + basis_z(:, i) = x1v(:) end do - basis_index(1,:) = lx(1:ndof_cell) - basis_index(2,:) = ly(1:ndof_cell) - basis_index(3,:) = lz(1:ndof_cell) - basis_vector(1,:) = 1.0_r_def + basis_index(1,:) = lx(1:ndof_cell) + basis_index(2,:) = ly(1:ndof_cell) + basis_index(3,:) = lz(1:ndof_cell) + basis_vector(1,:) = 1.0_r_def case (W1) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of Hcurl spaces - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- - poly_order = k+1 - - do idx=1, ndof_cell - do i=1, 3 + do idx = 1, ndof_cell + do i = 1, 3 unit_vec(i, idx) = 0.0_r_def end do end do @@ -768,13 +893,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs in volume ! u components - do jz=2, k+1 - do jy=2, k+1 - do jx=1, k+1 + do jz = 2, k_v + 1 + do jy = 2, k_h + 1 + do jx = 1, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_tangent_to_edge( S, unit_vec(:,idx) ) + call reference_element%get_tangent_to_edge(S, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -783,13 +908,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do ! v components - do jz=2, k+1 - do jy=1, k+1 - do jx=2, k+1 + do jz = 2, k_v + 1 + do jy = 1, k_h + 1 + do jx = 2, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_tangent_to_edge( W, unit_vec(:,idx) ) + call reference_element%get_tangent_to_edge(W, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -798,13 +923,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do ! w components - do jz=1, k+1 - do jy=2, k+1 - do jx=2, k+1 + do jz = 1, k_v + 1 + do jy = 2, k_h + 1 + do jx = 2, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_tangent_to_edge( B, unit_vec(:,idx) ) + call reference_element%get_tangent_to_edge(B, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -813,38 +938,48 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do ! dofs on faces - do i=1, number_faces - do j1=2, k+1 - do j2=1, k+1 + do i = 1, number_faces + ! For horizontal face loop over vertical then horizontal orders + if (i <= number_faces_h) then + k_switch = k_v + ! For vertical face loop over horizontal order twice + else + k_switch = k_h + end if + + ! Loop twice to account for two components per face (i.e. vertical + ! faces contain x and y components) + do j1 = 2, k_switch + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_edge_on_face( i, edges_on_face ) - call reference_element%get_tangent_to_edge( edges_on_face(1), & - unit_vec(:,idx) ) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_edge_on_face(i, edges_on_face) + call reference_element%get_tangent_to_edge(edges_on_face(1), & + unit_vec(:, idx)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 end do end do - do j1=1, k+1 - do j2=2, k+1 + do j1 = 1, k_switch + 1 + do j2 = 2, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_edge_on_face( i, edges_on_face ) - call reference_element%get_tangent_to_edge( edges_on_face(2), & - unit_vec(:,idx) ) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_edge_on_face(i, edges_on_face) + call reference_element%get_tangent_to_edge(edges_on_face(2), & + unit_vec(:, idx)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -853,50 +988,60 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do ! dofs on edges - do i=1, number_edges - do j1=1, k+1 + do i = 1, number_edges + ! If edge is horizontal loop to k_h+1 + if ((i <= number_2d_edges) .OR. & + (i > number_edges - number_2d_edges)) then + k_switch = k_h + ! If edge vertical loop to k_v+1 + else + k_switch = k_v + end if + + do j1 = 1, k_switch + 1 j(1) = j1 - j(2) = edge_idx(i,1) - j(3) = edge_idx(i,2) - lx(idx) = j(j2l_edge(i,1)) - ly(idx) = j(j2l_edge(i,2)) - lz(idx) = j(j2l_edge(i,3)) - call reference_element%get_tangent_to_edge( i, unit_vec(:,idx) ) - if (i <= number_horizontal_edges) dof_on_vert_boundary(idx,1) = 0 - if (i > number_edges - number_horizontal_edges) & - dof_on_vert_boundary(idx,2) = 0 + j(2) = edge_idx(i, 1) + j(3) = edge_idx(i, 2) + lx(idx) = j(j2l_edge(i, 1)) + ly(idx) = j(j2l_edge(i, 2)) + lz(idx) = j(j2l_edge(i, 3)) + call reference_element%get_tangent_to_edge(i, unit_vec(:, idx)) + if (i <= number_2d_edges) dof_on_vert_boundary(idx, 1) = 0 + if (i > number_edges - number_2d_edges) & + dof_on_vert_boundary(idx, 2) = 0 ! Label edge degrees of freedom entity_dofs(idx) = reference_element%get_edge_entity(i) idx = idx + 1 end do end do + do i = 1, ndof_cell - do i=1, ndof_cell - - nodal_coords(1,i) = abs(unit_vec(1,i))*x2(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x1(lx(i)) + nodal_coords(1, i) = abs(unit_vec(1, i)) * x2h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x1h(lx(i)) - nodal_coords(2,i) = abs(unit_vec(2,i))*x2(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x1(ly(i)) + nodal_coords(2, i) = abs(unit_vec(2, i)) * x2h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x1h(ly(i)) - nodal_coords(3,i) = abs(unit_vec(3,i))*x2(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x1(lz(i)) + nodal_coords(3, i) = abs(unit_vec(3, i)) * x2v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x1v(lz(i)) - basis_order(1,i) = poly_order - int(abs(unit_vec(1,i))) - basis_order(2,i) = poly_order - int(abs(unit_vec(2,i))) - basis_order(3,i) = poly_order - int(abs(unit_vec(3,i))) + basis_order(1, i) = (k_h + 1) - int(abs(unit_vec(1, i))) + basis_order(2, i) = (k_h + 1) - int(abs(unit_vec(2, i))) + basis_order(3, i) = (k_v + 1) - int(abs(unit_vec(3, i))) - basis_x(:,1,i) = abs(unit_vec(1,i))*x2(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x1(:) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x2h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x1h(:) - basis_x(:,2,i) = abs(unit_vec(2,i))*x2(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x1(:) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x2h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x1h(:) - basis_x(:,3,i) = abs(unit_vec(3,i))*x2(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x1(:) + basis_z(:, i) = abs(unit_vec(3, i)) * x2v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x1v(:) - basis_vector(:,i) = unit_vec(:,i) + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do end do @@ -904,31 +1049,27 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & basis_index(2,:) = ly(1:ndof_cell) basis_index(3,:) = lz(1:ndof_cell) - - case(W2, W2broken) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of Hdiv/discontinuous Hdiv spaces - !--------------------------------------------------------------------------- - - poly_order = k + 1 + !------------------------------------------------------------------------- - do idx=1, ndof_cell - do i=1, 3 - unit_vec(i,idx) = 0.0_r_def + do idx = 1, ndof_cell + do i = 1, 3 + unit_vec(i, idx) = 0.0_r_def end do end do idx = 1 ! dofs in volume ! u components - do jz=1, k+1 - do jy=1, k+1 - do jx=2,k+1 + do jz = 1, k_v + 1 + do jy = 1, k_h + 1 + do jx = 2, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_normal_to_face( W, unit_vec(:,idx) ) + call reference_element%get_normal_to_face(W, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -936,13 +1077,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do ! v components - do jz=1, k+1 - do jy=2, k+1 - do jx=1,k+1 + do jz = 1, k_v + 1 + do jy = 2, k_h + 1 + do jx = 1, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_normal_to_face( S, unit_vec(:,idx) ) + call reference_element%get_normal_to_face(S, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -950,13 +1091,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do ! w components - do jz=2, k+1 - do jy=1, k+1 - do jx=1,k+1 + do jz = 2, k_v + 1 + do jy = 1, k_h + 1 + do jx = 1, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_normal_to_face( B, unit_vec(:,idx) ) + call reference_element%get_normal_to_face(B, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -965,18 +1106,26 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do ! dofs on faces - do i=1, number_faces - do j1=1, k+1 - do j2=1, k+1 + do i = 1, number_faces + ! For horizontal face loop over vertical then horizontal orders + if (i <= number_faces_h) then + k_switch = k_v + ! For vertical face loop over horizontal order twice + else + k_switch = k_h + end if + + do j1 = 1, k_switch + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_normal_to_face( i, unit_vec(:,idx) ) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces ) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_normal_to_face(i, unit_vec(:, idx)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -984,31 +1133,38 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do - do i=1, ndof_cell + do i = 1, ndof_cell + + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) - nodal_coords(1,i) = abs(unit_vec(1,i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(lx(i)) + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) - nodal_coords(2,i) = abs(unit_vec(2,i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(ly(i)) + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) - nodal_coords(3,i) = abs(unit_vec(3,i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(lz(i)) + basis_order(1, i) = (k_h + 1) & + - int(1.0_r_def - abs(unit_vec(1, i)), i_def) - basis_order(1,i) = poly_order - int(1.0_r_def - abs(unit_vec(1,i)), i_def) - basis_order(2,i) = poly_order - int(1.0_r_def - abs(unit_vec(2,i)), i_def) - basis_order(3,i) = poly_order - int(1.0_r_def - abs(unit_vec(3,i)), i_def) + basis_order(2, i) = (k_h + 1) & + - int(1.0_r_def - abs(unit_vec(2, i)), i_def) - basis_x(:,1,i) = abs(unit_vec(1,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(:) + basis_order(3, i) = (k_v + 1) & + - int(1.0_r_def - abs(unit_vec(3, i)), i_def) - basis_x(:,2,i) = abs(unit_vec(2,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(:) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_x(:,3,i) = abs(unit_vec(3,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(:) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) - basis_vector(:,i) = unit_vec(:,i) + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(:) + + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do end do @@ -1016,13 +1172,10 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & basis_index(2,:) = ly(1:ndof_cell) basis_index(3,:) = lz(1:ndof_cell) - - case(W2trace) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of Hdiv trace spaces - !--------------------------------------------------------------------------- - poly_order = k + !------------------------------------------------------------------------- ! Compute indices of functions idx = 1 @@ -1031,8 +1184,16 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs on faces ! =============================== do i = 1, number_faces - do j1 = 1, k + 1 - do j2 = 1, k + 1 + ! For horizontal face loop over vertical then horizontal orders + if (i <= number_faces_h) then + k_switch = k_v + ! For vertical face loop over horizontal order twice + else + k_switch = k_h + end if + + do j1 = 1, k_switch + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) @@ -1041,7 +1202,8 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & lz(idx) = j(j2l_face(i, 3)) ! Gather normals corresponding to each face - call reference_element%get_outward_normal_to_face( i, unit_vec(:,idx) ) + call reference_element%get_outward_normal_to_face(i, & + unit_vec(:, idx)) ! Label face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1050,48 +1212,54 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do do i = 1, ndof_cell - nodal_coords(1, i) = abs(unit_vec(1, i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1, i)))*x2(lx(i)) - nodal_coords(2, i) = abs(unit_vec(2, i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2, i)))*x2(ly(i)) - nodal_coords(3, i) = abs(unit_vec(3, i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3, i)))*x2(lz(i)) - - basis_order(1, i) = poly_order*int(1.0_r_def - abs(unit_vec(1, i)), i_def) & + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) + + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) + + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) + + basis_order(1, i) = k_h * int(1.0_r_def & + - abs(unit_vec(1, i)), i_def) & + int(abs(unit_vec(1, i)), i_def) - basis_order(2, i) = poly_order*int(1.0_r_def - abs(unit_vec(2, i)), i_def) & + + basis_order(2, i) = k_h * int(1.0_r_def & + - abs(unit_vec(2, i)), i_def) & + int(abs(unit_vec(2, i)), i_def) - basis_order(3, i) = poly_order*int(1.0_r_def - abs(unit_vec(3, i)), i_def) & + + basis_order(3, i) = k_v * int(1.0_r_def & + - abs(unit_vec(3, i)), i_def) & + int(abs(unit_vec(3, i)), i_def) - basis_x(:, 1, i) = abs(unit_vec(1, i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1, i)))*x2(:) - basis_x(:, 2, i) = abs(unit_vec(2, i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2, i)))*x2(:) - basis_x(:, 3, i) = abs(unit_vec(3, i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3, i)))*x2(:) - end do + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_index(1, :) = lx(1:ndof_cell) - basis_index(2, :) = ly(1:ndof_cell) - basis_index(3, :) = lz(1:ndof_cell) - basis_vector(:, :) = 1.0_r_def + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(:) + end do + basis_index(1,:) = lx(1:ndof_cell) + basis_index(2,:) = ly(1:ndof_cell) + basis_index(3,:) = lz(1:ndof_cell) + basis_vector(:,:) = 1.0_r_def case(W3) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of DG spaces - !--------------------------------------------------------------------------- - poly_order = k + !------------------------------------------------------------------------- ! compute indices of functions idx = 1 ! dofs in volume - do jz=1, k+1 - do jy=1,k+1 - do jx=1,k+1 + do jz = 1, k_v + 1 + do jy = 1, k_h + 1 + do jx = 1, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz @@ -1102,38 +1270,37 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do - do i=1, ndof_cell - nodal_coords(1,i) = x2(lx(i)) - nodal_coords(2,i) = x2(ly(i)) - nodal_coords(3,i) = x2(lz(i)) - basis_x(:,1,i) = x2 - basis_x(:,2,i) = x2 - basis_x(:,3,i) = x2 + do i = 1, ndof_cell + nodal_coords(1, i) = x2h(lx(i)) + nodal_coords(2, i) = x2h(ly(i)) + nodal_coords(3, i) = x2v(lz(i)) + basis_x(:, 1, i) = x2h(:) + basis_x(:, 2, i) = x2h(:) + basis_z(:, i) = x2v(:) end do - basis_index(1,:) = lx(1:ndof_cell) - basis_index(2,:) = ly(1:ndof_cell) - basis_index(3,:) = lz(1:ndof_cell) + basis_index(1,:) = lx(1:ndof_cell) + basis_index(2,:) = ly(1:ndof_cell) + basis_index(3,:) = lz(1:ndof_cell) basis_vector(1,:) = 1.0_r_def - basis_order(:,:) = poly_order - - + basis_order(1,:) = k_h + basis_order(2,:) = k_h + basis_order(3,:) = k_v case (WTHETA) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of theta spaces - !--------------------------------------------------------------------------- - poly_order = k + 1 + !------------------------------------------------------------------------- idx = 1 ! dofs in volume - (w only) ! w components - do jz=2, k+1 - do jy=1, k+1 - do jx=1, k+1 - lx(idx) = jx - ly(idx) = jy - lz(idx) = jz + do jz = 2, k_v + 1 + do jy = 1, k_h + 1 + do jx = 1, k_h + 1 + lx(idx) = jx + ly(idx) = jy + lz(idx) = jz ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -1144,16 +1311,17 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs on faces do i = number_faces - 1, number_faces - do j1=1, k+1 - do j2=1, k+1 + ! Loop on faces dependent on k_h only + do j1 = 1, k_h + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label top and bottom face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1161,35 +1329,32 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do - do i=1, ndof_cell - nodal_coords(1,i)= x2(lx(i)) - nodal_coords(2,i)= x2(ly(i)) - nodal_coords(3,i)= x1(lz(i)) + do i = 1, ndof_cell + nodal_coords(1, i) = x2h(lx(i)) + nodal_coords(2, i) = x2h(ly(i)) + nodal_coords(3, i) = x1v(lz(i)) - basis_order(1,i) = poly_order - 1 - basis_order(2,i) = poly_order - 1 - basis_order(3,i) = poly_order + basis_order(1, i) = k_h + basis_order(2, i) = k_h + basis_order(3, i) = k_v + 1 - basis_x(:,1,i) = x2(:) - basis_x(:,2,i) = x2(:) - basis_x(:,3,i) = x1(:) + basis_x(:, 1, i) = x2h(:) + basis_x(:, 2, i) = x2h(:) + basis_z(:, i) = x1v(:) end do - basis_index(1,:) = lx(1:ndof_cell) - basis_index(2,:) = ly(1:ndof_cell) - basis_index(3,:) = lz(1:ndof_cell) + basis_index(1,:) = lx(1:ndof_cell) + basis_index(2,:) = ly(1:ndof_cell) + basis_index(3,:) = lz(1:ndof_cell) basis_vector(:,:) = 1.0_r_def - - case (W2V) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of W2V space - !--------------------------------------------------------------------------- - poly_order = k + 1 + !------------------------------------------------------------------------- - do idx=1, ndof_cell - do i=1, 3 + do idx = 1, ndof_cell + do i = 1, 3 unit_vec(i, idx) = 0.0_r_def end do end do @@ -1197,13 +1362,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & idx = 1 ! dofs in volume - (w only) ! w components - do jz=2, k+1 - do jy=1, k+1 - do jx=1, k+1 - lx(idx) = jx - ly(idx) = jy - lz(idx) = jz - call reference_element%get_normal_to_face( B, unit_vec(:,idx) ) + do jz = 2, k_v + 1 + do jy = 1, k_h + 1 + do jx = 1, k_h + 1 + lx(idx) = jx + ly(idx) = jy + lz(idx) = jz + call reference_element%get_normal_to_face(B, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -1214,17 +1379,18 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs on faces do i = number_faces - 1, number_faces - do j1=1, k+1 - do j2=1, k+1 + ! Loop on faces dependent on k_h only + do j1 = 1, k_h + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_normal_to_face( i, unit_vec(:,idx) ) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_normal_to_face(i, unit_vec(:, idx)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label top and bottom face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1232,31 +1398,38 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do - do i=1, ndof_cell + do i = 1, ndof_cell - nodal_coords(1,i) = abs(unit_vec(1,i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(lx(i)) + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) - nodal_coords(2,i) = abs(unit_vec(2,i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(ly(i)) + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) - nodal_coords(3,i) = abs(unit_vec(3,i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(lz(i)) + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) - basis_order(1,i) = poly_order - int(1.0_r_def - abs(unit_vec(1,i)), i_def) - basis_order(2,i) = poly_order - int(1.0_r_def - abs(unit_vec(2,i)), i_def) - basis_order(3,i) = poly_order - int(1.0_r_def - abs(unit_vec(3,i)), i_def) + basis_order(1, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(1, i)), i_def) - basis_x(:,1,i) = abs(unit_vec(1,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(:) + basis_order(2, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(2, i)), i_def) - basis_x(:,2,i) = abs(unit_vec(2,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(:) + basis_order(3, i) = (k_v + 1) - int(1.0_r_def & + - abs(unit_vec(3, i)), i_def) - basis_x(:,3,i) = abs(unit_vec(3,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(:) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_vector(:,i) = unit_vec(:,i) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) + + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(:) + + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do end do @@ -1265,10 +1438,9 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & basis_index(3,:) = lz(1:ndof_cell) case (W2Vtrace) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of W2Vtrace space - !--------------------------------------------------------------------------- - poly_order = k + 1 + !------------------------------------------------------------------------- do idx = 1, ndof_cell do i = 1, 3 @@ -1279,17 +1451,18 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & idx = 1 ! dofs on faces do i = number_faces - 1, number_faces - do j1 = 1, k+1 - do j2 = 1, k+1 + ! Loop on faces dependent on k_h only + do j1 = 1, k_h + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_normal_to_face( i, unit_vec(:,idx) ) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_normal_to_face(i, unit_vec(:, idx)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label top and bottom face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1299,29 +1472,36 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & do i = 1, ndof_cell - nodal_coords(1,i) = abs(unit_vec(1,i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(lx(i)) + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) - nodal_coords(2,i) = abs(unit_vec(2,i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(ly(i)) + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) - nodal_coords(3,i) = abs(unit_vec(3,i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(lz(i)) + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) - basis_order(1,i) = poly_order - int(1.0_r_def - abs(unit_vec(1,i)), i_def) - basis_order(2,i) = poly_order - int(1.0_r_def - abs(unit_vec(2,i)), i_def) - basis_order(3,i) = poly_order - int(1.0_r_def - abs(unit_vec(3,i)), i_def) + basis_order(1, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(1, i)), i_def) - basis_x(:,1,i) = abs(unit_vec(1,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(:) + basis_order(2, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(2, i)), i_def) - basis_x(:,2,i) = abs(unit_vec(2,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(:) + basis_order(3, i) = (k_v + 1) - int(1.0_r_def & + - abs(unit_vec(3, i)), i_def) - basis_x(:,3,i) = abs(unit_vec(3,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(:) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_vector(:,i) = unit_vec(:,i) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) + + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(:) + + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do end do @@ -1329,16 +1509,14 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & basis_index(2,:) = ly(1:ndof_cell) basis_index(3,:) = lz(1:ndof_cell) - - case (W2H) - !--------------------------------------------------------------------------- + case (W2H, W2Hbroken) + !------------------------------------------------------------------------- ! Section for test/trial functions of W2H space - !--------------------------------------------------------------------------- - poly_order = k + 1 + !------------------------------------------------------------------------- - do idx=1, ndof_cell - do i=1, 3 - unit_vec(i,idx) = 0.0_r_def + do idx = 1, ndof_cell + do i = 1, 3 + unit_vec(i, idx) = 0.0_r_def end do end do @@ -1348,13 +1526,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs in volume - (u and v only) !============================================ ! u components - do jz=1,k+1 - do jy=1,k+1 - do jx=2,k+1 - lx(idx) = jx - ly(idx) = jy - lz(idx) = jz - call reference_element%get_normal_to_face( W, unit_vec(:,idx) ) + do jz = 1, k_v + 1 + do jy = 1, k_h + 1 + do jx = 2, k_h + 1 + lx(idx) = jx + ly(idx) = jy + lz(idx) = jz + call reference_element%get_normal_to_face(W, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -1362,13 +1540,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do ! v components - do jz=1,k+1 - do jy=2,k+1 - do jx=1,k+1 - lx(idx) = jx - ly(idx) = jy - lz(idx) = jz - call reference_element%get_normal_to_face( S, unit_vec(:,idx) ) + do jz = 1, k_v + 1 + do jy = 2, k_h + 1 + do jx = 1, k_h + 1 + lx(idx) = jx + ly(idx) = jy + lz(idx) = jz + call reference_element%get_normal_to_face(S, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -1379,16 +1557,17 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & !============================================ ! dofs on faces !============================================ - do i=1, number_faces - 2 - do j1=1, k+1 - do j2=1, k+1 + do i = 1, number_faces - 2 + ! No vertical faces considered so one horizontal and one vertical loop + do j1 = 1, k_v + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_normal_to_face( i, unit_vec(:,idx) ) + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_normal_to_face(i, unit_vec(:, idx)) ! Label horizontal face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1396,46 +1575,52 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do + do i = 1, ndof_cell + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) + + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) + + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) - do i=1, ndof_cell - nodal_coords(1,i) = abs(unit_vec(1,i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(lx(i)) + basis_order(1, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(1, i)), i_def) - nodal_coords(2,i) = abs(unit_vec(2,i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(ly(i)) + basis_order(2, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(2, i)), i_def) - nodal_coords(3,i) = abs(unit_vec(3,i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(lz(i)) + basis_order(3, i) = (k_v + 1) - int(1.0_r_def & + - abs(unit_vec(3, i)), i_def) - basis_order(1,i) = poly_order - int(1.0_r_def - abs(unit_vec(1,i)), i_def) - basis_order(2,i) = poly_order - int(1.0_r_def - abs(unit_vec(2,i)), i_def) - basis_order(3,i) = poly_order - int(1.0_r_def - abs(unit_vec(3,i)), i_def) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_x(:,1,i) = abs(unit_vec(1,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(:) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) - basis_x(:,2,i) = abs(unit_vec(2,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(:) - basis_x(:,3,i) = abs(unit_vec(3,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(:) + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec( 3, i))) * x2v(: ) + + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do - basis_vector(:,i) = unit_vec(:,i) end do basis_index(1,:) = lx(1:ndof_cell) basis_index(2,:) = ly(1:ndof_cell) basis_index(3,:) = lz(1:ndof_cell) - case (W2Htrace) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of W2Htrace space - !--------------------------------------------------------------------------- - poly_order = k + 1 + !------------------------------------------------------------------------- do idx = 1, ndof_cell do i = 1, 3 - unit_vec(i,idx) = 0.0_r_def + unit_vec(i, idx) = 0.0_r_def end do end do @@ -1444,15 +1629,16 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs on faces !============================================ do i = 1, number_faces - 2 - do j1 = 1, k+1 - do j2 = 1, k+1 + ! No vertical faces considered so one horizontal and one vertical loop + do j1 = 1, k_h + 1 + do j2 = 1, k_v + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_normal_to_face( i, unit_vec(:,idx) ) + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_normal_to_face(i, unit_vec(:, idx)) ! Label horizontal face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1461,47 +1647,55 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do do i = 1, ndof_cell - nodal_coords(1,i) = abs(unit_vec(1,i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(lx(i)) + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) + + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) + + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) - nodal_coords(2,i) = abs(unit_vec(2,i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(ly(i)) + basis_order(1, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(1, i)), i_def) - nodal_coords(3,i) = abs(unit_vec(3,i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(lz(i)) + basis_order(2, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(2, i)), i_def) - basis_order(1,i) = poly_order - int(1.0_r_def - abs(unit_vec(1,i)), i_def) - basis_order(2,i) = poly_order - int(1.0_r_def - abs(unit_vec(2,i)), i_def) - basis_order(3,i) = poly_order - int(1.0_r_def - abs(unit_vec(3,i)), i_def) + basis_order(3, i) = (k_v + 1) - int(1.0_r_def & + - abs(unit_vec(3, i)), i_def) - basis_x(:,1,i) = abs(unit_vec(1,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(:) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_x(:,2,i) = abs(unit_vec(2,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(:) - basis_x(:,3,i) = abs(unit_vec(3,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(:) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) + + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(:) + + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do - basis_vector(:,i) = unit_vec(:,i) end do basis_index(1,:) = lx(1:ndof_cell) basis_index(2,:) = ly(1:ndof_cell) basis_index(3,:) = lz(1:ndof_cell) - case(WCHI) - !--------------------------------------------------------------------------- + case(WCHI) + !------------------------------------------------------------------------- ! Section for test/trial functions of DG spaces - !--------------------------------------------------------------------------- - poly_order = k + !------------------------------------------------------------------------- ! compute indices of functions idx = 1 ! dofs in volume - do jz=1, k+1 - do jy=1,k+1 - do jx=1,k+1 + do jz = 1, k_v + 1 + do jy = 1, k_h + 1 + do jx = 1, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz @@ -1512,35 +1706,36 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do - do i=1, ndof_cell - nodal_coords(1,i) = x2(lx(i)) - nodal_coords(2,i) = x2(ly(i)) - nodal_coords(3,i) = x2(lz(i)) - basis_x(:,1,i) = x2 - basis_x(:,2,i) = x2 - basis_x(:,3,i) = x2 + do i = 1, ndof_cell + nodal_coords(1, i) = x2h(lx(i)) + nodal_coords(2, i) = x2h(ly(i)) + nodal_coords(3, i) = x2v(lz(i)) + basis_x(:, 1, i) = x2h(:) + basis_x(:, 2, i) = x2h(:) + basis_z(:, i) = x2v(:) end do - basis_index(1,:) = lx(1:ndof_cell) - basis_index(2,:) = ly(1:ndof_cell) - basis_index(3,:) = lz(1:ndof_cell) + basis_index(1,:) = lx(1:ndof_cell) + basis_index(2,:) = ly(1:ndof_cell) + basis_index(3,:) = lz(1:ndof_cell) basis_vector(1,:) = 1.0_r_def - basis_order(:,:) = poly_order + basis_order(1,:) = k_h + basis_order(2,:) = k_h + basis_order(3,:) = k_v end select - deallocate( lx ) - deallocate( ly ) - deallocate( lz ) + deallocate(lx) + deallocate(ly) + deallocate(lz) ! Allocate arrays to allow on the fly evaluation of basis functions select case (gungho_fs) - case (W1, W2, W2H, W2V, W2broken, W2trace, W2Vtrace, W2Htrace) - deallocate( unit_vec ) + case (W1, W2, W2H, W2V, W2broken, W2Hbroken, W2trace, W2Vtrace, W2Htrace) + deallocate(unit_vec) end select - return end subroutine basis_setup !----------------------------------------------------------------------------- @@ -1553,13 +1748,20 @@ end subroutine basis_setup !> !> @param[in] mesh Mesh to define the function space on. !> @param[in] gungho_fs Enumeration of the function space. - !> @param[in] element_order Polynomial order of the function space. + !> @param[in] element_order_h Polynomial order of the function space in + !> horizontal direction. + !> @param[in] element_order_v Polynomial order of the function space in + !> vertical direction. !> @param[in] ndata The number of data values to be held !> at each dof location + !> @param[in] ndata_first Flag for ndata or nlayer first data + !> layout !> @param[in] ncells_2d_with_ghost Number of 2d cells with ghost cells. !> @param[in] ndof_vert Number of dofs on vertices. - !> @param[in] ndof_edge Number of dofs on edges. - !> @param[in] ndof_face Number of dofs on faces. + !> @param[in] ndof_edge_h Number of dofs on horizontal edges. + !> @param[in] ndof_edge_v Number of dofs on vertical edges. + !> @param[in] ndof_face_h Number of dofs on horizontal faces. + !> @param[in] ndof_face_v Number of dofs on vertical faces. !> @param[in] ndof_vol Number of dofs in volumes. !> @param[in] ndof_cell Number of dofs associated with a cell. !> @param[out] last_dof_owned Index of last owned dof for the @@ -1577,50 +1779,82 @@ end subroutine basis_setup !> horizontal domain !> @param[out] global_vert_dof_id_2d Global id of vertex dofs on the 2D !> horizontal domain - !> - subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & - ncells_2d_with_ghost, & - ndof_vert, ndof_edge, ndof_face, & - ndof_vol, ndof_cell, last_dof_owned, & - last_dof_annexed, last_dof_halo, dofmap, & - global_dof_id, & - global_cell_dof_id_2d, & - global_edge_dof_id_2d, & - global_vert_dof_id_2d ) + ! + ! .+---B--+ In the following an edge is called vertical if it is + ! .' | .'| normal to the horizontal plane (such as edge A), and + ! +---+--+' A horizontal if it is parallel to it (such as edge B). + ! | P | | | + ! | ,+--+---+ A face will be called horizontal if it is normal to + ! |.' Q | .' the horizontal plane (such as face P) and vertical if it + ! +------+' is parallel to it (such as face Q). + ! + ! These are chosen to agree with the naming of W2H and + ! W2V. + + subroutine dofmap_setup( mesh, gungho_fs, element_order_h, element_order_v, & + ndata, ndata_first, ncells_2d_with_ghost, ndof_vert,& + ndof_edge_h, ndof_edge_v, ndof_face_h, ndof_face_v, & + ndof_vol, ndof_cell, last_dof_owned, & + last_dof_annexed, last_dof_halo, dofmap, & + global_dof_id, global_cell_dof_id_2d, & + global_edge_dof_id_2d, global_vert_dof_id_2d ) implicit none + ! Input type(mesh_type), intent(in), pointer :: mesh integer(i_def), intent(in) :: gungho_fs - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h + integer(i_def), intent(in) :: element_order_v integer(i_def), intent(in) :: ndata + + logical(l_def), intent(in) :: ndata_first + integer(i_def), intent(in) :: ncells_2d_with_ghost integer(i_def), intent(in) :: ndof_vert - integer(i_def), intent(in) :: ndof_edge - integer(i_def), intent(in) :: ndof_face + integer(i_def), intent(in) :: ndof_edge_h + integer(i_def), intent(in) :: ndof_edge_v + integer(i_def), intent(in) :: ndof_face_h + integer(i_def), intent(in) :: ndof_face_v integer(i_def), intent(in) :: ndof_vol integer(i_def), intent(in) :: ndof_cell + + ! Output integer(i_def), intent(out) :: last_dof_owned integer(i_def), intent(out) :: last_dof_annexed - integer(i_def), intent(out) :: last_dof_halo(:) - integer(i_def), intent(out) :: dofmap(ndof_cell,0:ncells_2d_with_ghost) + integer(i_def), intent(out) :: last_dof_halo(0:) + + integer(i_def), intent(out) :: dofmap(ndof_cell, 0:ncells_2d_with_ghost) integer(i_halo_index), intent(out) :: global_dof_id(:) - integer(i_def), intent(out) :: global_cell_dof_id_2d(:) - integer(i_def), intent(out) :: global_edge_dof_id_2d(:) - integer(i_def), intent(out) :: global_vert_dof_id_2d(:) + + integer(i_def), intent(out) :: global_cell_dof_id_2d(:) + integer(i_def), intent(out) :: global_edge_dof_id_2d(:) + integer(i_def), intent(out) :: global_vert_dof_id_2d(:) + + ! Local variables class(reference_element_type), pointer :: reference_element => null() - integer(i_def) :: number_horizontal_faces, & - number_horizontal_edges, & - number_horizontal_vertices - integer(i_def) :: number_faces, number_edges, number_vertices + integer(i_def) :: number_faces ! Number of faces per cell + integer(i_def) :: number_edges ! Number of edges per cell + integer(i_def) :: number_vertices ! Number of vertices per cell - integer(i_def) :: ncells + integer(i_def) :: number_horizontal_faces ! Number of horizontal faces per + ! cell + integer(i_def) :: number_horizontal_edges ! Number of horizontal edges per + ! cell + integer(i_def) :: number_2d_vertices ! Number of vertices of 2d cell + ! entity + + + integer(i_def) :: ncells ! Number of cells in the rank (including ghosts) ! Loop counters integer(i_def) :: icell, iface, iedge, ivert, idof, idepth, k, m + ! Loop upper bound for ndof loops on vertical or horizontal edges + integer(i_def) :: ndof_stop + ! Number of layers integer(i_def) :: nlayers @@ -1634,7 +1868,7 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & integer(i_def) :: nvert_layer, nedge_layer, nface_layer ! Start and end points of the cell indices to loop over - integer(i_def) :: start,finish + integer(i_def) :: start, finish ! Entity dofmaps integer(i_def), allocatable :: dofmap_d0(:,:), & @@ -1676,31 +1910,46 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & integer(i_halo_index) :: num_layers, num_dofs, num_ndata - !========================================================= + integer(i_def) :: ndata_offset + + !=========================================================================== reference_element => mesh%get_reference_element() - number_faces = reference_element%get_number_faces() - number_edges = reference_element%get_number_edges() - number_vertices = reference_element%get_number_vertices() - number_horizontal_faces = reference_element%get_number_horizontal_faces() - number_horizontal_edges = reference_element%get_number_2d_edges() - number_horizontal_vertices = reference_element%get_number_2d_vertices() + + number_faces = reference_element%get_number_faces() + number_edges = reference_element%get_number_edges() + number_vertices = reference_element%get_number_vertices() + + number_horizontal_faces = reference_element%get_number_horizontal_faces() + number_horizontal_edges = reference_element%get_number_2d_edges() + number_2d_vertices = reference_element%get_number_2d_vertices() ncells = ncells_2d_with_ghost + ! Offset for multidata fields with continuous vertical components + ! If ndata_first we need to add ndata to the dof value + ! => dof on top entity (face, edge, vert) = dof on bottom entity + ndata + ! If nlayer_first we need to add 1 to the dof value + ! => dof on top entity (face, edge, vert) = dof on bottom entity + 1 + if ( ndata_first ) then + ndata_offset = ndata + else + ndata_offset = 1 + end if + ! dofmaps for a 3D horizontal layer - nlayers = mesh % get_nlayers() - nvert_layer = 2 * mesh % get_nverts_2d() - nedge_layer = 2 * mesh % get_nedges_2d() & - + mesh % get_nverts_2d() - nface_layer = mesh % get_nedges_2d() & + nlayers = mesh%get_nlayers() + nvert_layer = 2 * mesh%get_nverts_2d() + nedge_layer = 2 * mesh%get_nedges_2d() & + + mesh%get_nverts_2d() + nface_layer = mesh%get_nedges_2d() & + 2 * ncells dofmap_size(:) = 1 - dofmap_size(0) = max( dofmap_size(0), ndof_vert ) - dofmap_size(1) = max( dofmap_size(1), ndof_edge ) - dofmap_size(2) = max( dofmap_size(2), ndof_face ) - dofmap_size(3) = max( dofmap_size(3), ndof_vol ) + dofmap_size(0) = max(dofmap_size(0), ndof_vert) + dofmap_size(1) = max(dofmap_size(1), ndof_edge_h, ndof_edge_v) + dofmap_size(2) = max(dofmap_size(2), ndof_face_h, ndof_face_v) + dofmap_size(3) = max(dofmap_size(3), ndof_vol) allocate( dof_column_height (ndof_cell, 0:ncells)) allocate( dof_cell_owner (ndof_cell, 0:ncells)) @@ -1750,13 +1999,12 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & dof_cell_owner_d3 (:,:) = 0 ! Sum the number of cells in all the inner halos - tot_num_inner=0 - do idepth=1,mesh%get_inner_depth() + tot_num_inner = 0 + do idepth = 1, mesh%get_inner_depth() tot_num_inner = tot_num_inner + & - mesh%get_num_cells_inner(idepth) + mesh%get_num_cells_inner(idepth) end do - ! Assume we have all possible global connectivity information ! in practice this requires connectivity ! (3,2) -> faces on cells @@ -1764,101 +2012,102 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! (3,0) -> vertices on cells id_owned = 1 - id_halo = -1 + id_halo = -1 ! loop over 3 entities (cells) starting with core + inner halos + edge ! + first depth halo then proceding with further halo depths as required - start=1 - finish=tot_num_inner + & - mesh%get_num_cells_edge() + & - mesh%get_num_cells_halo(1) + start = 1 + finish = tot_num_inner & + + mesh%get_num_cells_edge() & + + mesh%get_num_cells_halo(1) select case (gungho_fs) case(W0, W1, W2, W2broken, W2trace, W3, WCHI) select_entity => select_entity_all case(WTHETA) select_entity => select_entity_theta - case(W2H, W2Htrace) + case(W2H, W2Htrace, W2Hbroken) select_entity => select_entity_w2h case(W2V, W2Vtrace) select_entity => select_entity_w2v end select - halo_loop: do idepth = 1, mesh % get_halo_depth()+1 - cell_loop: do icell = start, finish + halo_loop : do idepth = 1, mesh%get_halo_depth() + 1 + cell_loop : do icell = start, finish ! Assign dofs for connectivity (3,3) (dofs in cell) !--------------------------------------------------------- - if (mesh % is_cell_owned(icell)) then - do idof=1, ndof_vol - dofmap_d3 (idof,icell) = id_owned - dof_column_height_d3 (idof,icell) = nlayers - dof_cell_owner_d3 (idof,icell) = icell + if (mesh%is_cell_owned(icell)) then + do idof = 1, ndof_vol + dofmap_d3 (idof, icell) = id_owned + dof_column_height_d3 (idof, icell) = nlayers + dof_cell_owner_d3 (idof, icell) = icell id_owned = id_owned + (ndata * nlayers) end do else - do idof=1, ndof_vol - dofmap_d3 (idof,icell) = id_halo - dof_column_height_d3 (idof,icell) = nlayers - dof_cell_owner_d3 (idof,icell) = icell + do idof = 1, ndof_vol + dofmap_d3 (idof, icell) = id_halo + dof_column_height_d3 (idof, icell) = nlayers + dof_cell_owner_d3 (idof, icell) = icell id_halo = id_halo - (ndata * nlayers) end do end if ! Assign dofs for connectivity (3,2) (dofs on faces) !--------------------------------------------------------- - do iface=1, number_horizontal_faces - if (any(select_entity % faces==iface)) then - face_id = mesh%get_face_on_cell(iface,icell) - - if (mesh%is_edge_owned(iface,icell)) then - - if ( dofmap_d2(1,face_id) == 0 ) then - do idof=1, ndof_face - dofmap_d2(idof,face_id) = id_owned - dof_column_height_d2(idof,face_id) = nlayers - dof_cell_owner_d2(idof,face_id) = & - mesh%get_edge_cell_owner(iface,icell) + + ! Horizontal faces + do iface = 1, number_horizontal_faces + if (any(select_entity%faces == iface)) then + face_id = mesh%get_face_on_cell(iface, icell) + if (mesh%is_edge_owned(iface, icell)) then + if (dofmap_d2(1, face_id) == 0) then + do idof = 1, ndof_face_h + dofmap_d2(idof, face_id) = id_owned + dof_column_height_d2(idof, face_id) = nlayers + dof_cell_owner_d2(idof, face_id) = & + mesh%get_edge_cell_owner(iface, icell) + id_owned = id_owned + (ndata * nlayers) end do end if else - if ( dofmap_d2(1,face_id) == 0 ) then - do idof=1, ndof_face - dofmap_d2(idof,face_id) = id_halo - dof_column_height_d2(idof,face_id) = nlayers - dof_cell_owner_d2(idof,face_id) = & - mesh%get_edge_cell_owner(iface,icell) + if (dofmap_d2(1, face_id) == 0) then + do idof = 1, ndof_face_h + dofmap_d2(idof, face_id) = id_halo + dof_column_height_d2(idof, face_id) = nlayers + dof_cell_owner_d2(idof, face_id) = & + mesh%get_edge_cell_owner(iface, icell) + id_halo = id_halo - (ndata * nlayers) end do end if end if end if ! select_entity end do - - if (mesh % is_cell_owned(icell)) then + ! Vertical faces + if (mesh%is_cell_owned(icell)) then id0 = id_owned do iface = number_horizontal_faces + 1, number_faces - if (any(select_entity % faces==iface)) then - face_id = mesh % get_face_on_cell(iface,icell) - - if ( dofmap_d2(1,face_id) == 0 ) then - do idof=1, ndof_face - dofmap_d2(idof,face_id) = id_owned + if (any(select_entity%faces==iface)) then + face_id = mesh%get_face_on_cell(iface, icell) + if (dofmap_d2(1, face_id) == 0) then + do idof = 1, ndof_face_v + dofmap_d2(idof, face_id) = id_owned if (iface == number_horizontal_faces + 1) then - dof_column_height_d2(idof,face_id) = nlayers + 1 + dof_column_height_d2(idof, face_id) = nlayers + 1 else - dof_column_height_d2(idof,face_id) = 0 + dof_column_height_d2(idof, face_id) = 0 end if - dof_cell_owner_d2(idof,face_id) = icell - id_owned = id_owned + (ndata * ( nlayers + 1) ) + dof_cell_owner_d2(idof, face_id) = icell + id_owned = id_owned + (ndata * (nlayers + 1)) end do end if if (iface == number_horizontal_faces + 1) then - id_owned = id0 + ndata + id_owned = id0 + ndata_offset else - id_owned = id_owned - ndata + id_owned = id_owned - ndata_offset end if end if ! select_entity @@ -1866,89 +2115,97 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & else id0 = id_halo do iface = number_horizontal_faces + 1, number_faces - if (any(select_entity % faces==iface)) then - face_id = mesh % get_face_on_cell(iface,icell) - if ( dofmap_d2(1,face_id) == 0 ) then - do idof=1, ndof_face - dofmap_d2(idof,face_id) = id_halo - if ( iface == number_horizontal_faces + 1 ) then - dof_column_height_d2(idof,face_id) = nlayers + 1 + if (any(select_entity%faces == iface)) then + face_id = mesh%get_face_on_cell(iface, icell) + if (dofmap_d2(1, face_id) == 0) then + do idof = 1, ndof_face_v + dofmap_d2(idof, face_id) = id_halo + if (iface == number_horizontal_faces + 1) then + dof_column_height_d2(idof, face_id) = nlayers + 1 else - dof_column_height_d2(idof,face_id) = 0 + dof_column_height_d2(idof, face_id) = 0 end if - dof_cell_owner_d2(idof,face_id) = icell - id_halo = id_halo - (ndata * ( nlayers + 1) ) + dof_cell_owner_d2(idof, face_id) = icell + id_halo = id_halo - (ndata * (nlayers + 1)) end do end if if (iface == number_horizontal_faces + 1) then - id_halo = id0 - ndata + id_halo = id0 - ndata_offset else - id_halo = id_halo + ndata + id_halo = id_halo + ndata_offset end if end if ! select_entity end do end if ! is cell owned ! assign dofs for connectivity (3,1) (dofs on edges) + + ! Horizontal edges do iedge = 1, number_horizontal_edges - bottom_edge_id = mesh%get_edge_on_cell( iedge, icell ) - top_edge_id = mesh%get_edge_on_cell( iedge + number_edges & - - number_horizontal_edges, & - icell ) - if (mesh%is_edge_owned(iedge,icell)) then - if ( dofmap_d1(1,bottom_edge_id) == 0 ) then - do idof=1,ndof_edge - dofmap_d1(idof,bottom_edge_id) = id_owned - dofmap_d1(idof,top_edge_id) = id_owned + ndata - dof_column_height_d1(idof,bottom_edge_id) = nlayers + 1 - dof_column_height_d1(idof,top_edge_id ) = 0 - dof_cell_owner_d1(idof,bottom_edge_id) = & - mesh%get_edge_cell_owner(iedge,icell) - dof_cell_owner_d1(idof,top_edge_id ) = & - mesh%get_edge_cell_owner(iedge,icell) - id_owned = id_owned + (ndata * ( nlayers + 1) ) + bottom_edge_id = mesh%get_edge_on_cell(iedge, icell) + top_edge_id = mesh%get_edge_on_cell(iedge + number_edges & + - number_horizontal_edges, & + icell) + if (mesh%is_edge_owned(iedge, icell)) then + if (dofmap_d1(1, bottom_edge_id) == 0) then + do idof = 1, ndof_edge_h + dofmap_d1(idof, bottom_edge_id) = id_owned + dofmap_d1(idof, top_edge_id) = id_owned + ndata_offset + dof_column_height_d1(idof, bottom_edge_id) = nlayers + 1 + dof_column_height_d1(idof, top_edge_id) = 0 + dof_cell_owner_d1(idof, bottom_edge_id) = & + mesh%get_edge_cell_owner(iedge, icell) + + dof_cell_owner_d1(idof, top_edge_id) = & + mesh%get_edge_cell_owner(iedge, icell) + + id_owned = id_owned + (ndata * (nlayers + 1)) end do end if else - if ( dofmap_d1(1,bottom_edge_id) == 0 ) then - do idof=1,ndof_edge - dofmap_d1(idof,bottom_edge_id) = id_halo - dofmap_d1(idof,top_edge_id) = id_halo - ndata - dof_column_height_d1(idof,bottom_edge_id) = nlayers + 1 - dof_column_height_d1(idof,top_edge_id ) = 0 - dof_cell_owner_d1(idof,bottom_edge_id) = & - mesh%get_edge_cell_owner(iedge,icell) - dof_cell_owner_d1(idof,top_edge_id ) = & - mesh%get_edge_cell_owner(iedge,icell) - id_halo = id_halo - (ndata * ( nlayers + 1) ) + if (dofmap_d1(1, bottom_edge_id) == 0) then + do idof = 1, ndof_edge_h + dofmap_d1(idof, bottom_edge_id) = id_halo + dofmap_d1(idof, top_edge_id) = id_halo - ndata_offset + dof_column_height_d1(idof, bottom_edge_id) = nlayers + 1 + dof_column_height_d1(idof, top_edge_id) = 0 + dof_cell_owner_d1(idof, bottom_edge_id) = & + mesh%get_edge_cell_owner(iedge, icell) + + dof_cell_owner_d1(idof, top_edge_id) = & + mesh%get_edge_cell_owner(iedge, icell) + + id_halo = id_halo - (ndata * (nlayers + 1)) end do end if end if end do - do iedge = number_horizontal_edges + 1, & - number_edges - number_horizontal_edges - side_edge_id = mesh%get_edge_on_cell(iedge,icell) - if (mesh%is_vertex_owned( iedge - number_horizontal_edges, & - icell )) then - if ( dofmap_d1(1,side_edge_id) == 0 ) then - do idof=1,ndof_edge - dofmap_d1(idof,side_edge_id) = id_owned - dof_column_height_d1(idof,side_edge_id) = nlayers - dof_cell_owner_d1(idof,side_edge_id) & - = mesh%get_vertex_cell_owner( iedge - number_horizontal_edges, & - icell) - id_owned = id_owned + ( nlayers * ndata ) + ! Vertical edges + do iedge = number_horizontal_edges + 1, number_edges & + - number_horizontal_edges + side_edge_id = mesh%get_edge_on_cell(iedge, icell) + if (mesh%is_vertex_owned(iedge - number_horizontal_edges, icell)) then + if (dofmap_d1(1, side_edge_id) == 0) then + do idof = 1, ndof_edge_v + dofmap_d1(idof, side_edge_id) = id_owned + dof_column_height_d1(idof, side_edge_id) = nlayers + dof_cell_owner_d1(idof, side_edge_id) = & + mesh%get_vertex_cell_owner(iedge - number_horizontal_edges, & + icell) + + id_owned = id_owned + (nlayers * ndata) end do end if else - if ( dofmap_d1(1,side_edge_id) == 0 ) then - do idof=1,ndof_edge - dofmap_d1(idof,side_edge_id) = id_halo - dof_column_height_d1(idof,side_edge_id) = nlayers - dof_cell_owner_d1(idof,side_edge_id) & - = mesh%get_vertex_cell_owner( iedge - number_horizontal_edges, & - icell) - id_halo = id_halo - ( nlayers * ndata ) + if (dofmap_d1(1, side_edge_id) == 0) then + do idof = 1, ndof_edge_v + dofmap_d1(idof, side_edge_id) = id_halo + dof_column_height_d1(idof, side_edge_id) = nlayers + dof_cell_owner_d1(idof, side_edge_id) = & + mesh%get_vertex_cell_owner(iedge - number_horizontal_edges, & + icell) + + id_halo = id_halo - (nlayers * ndata) end do end if end if @@ -1957,86 +2214,90 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! Assign dofs for connectivity (3,0) (dofs on verts) !--------------------------------------------------------- - do ivert=1, number_horizontal_vertices - bottom_vert_id = mesh % get_vert_on_cell(ivert,icell) - top_vert_id & - = mesh % get_vert_on_cell( ivert + number_horizontal_vertices, & - icell ) - - if (mesh % is_vertex_owned(ivert,icell)) then - - if ( dofmap_d0(1,bottom_vert_id) == 0 ) then - do idof=1, ndof_vert - dofmap_d0(idof,bottom_vert_id) = id_owned - dofmap_d0(idof,top_vert_id) = id_owned + ndata - dof_column_height_d0(idof,bottom_vert_id) = nlayers + 1 - dof_column_height_d0(idof,top_vert_id ) = 0 - dof_cell_owner_d0(idof,bottom_vert_id) = & - mesh % get_vertex_cell_owner(ivert,icell) - dof_cell_owner_d0(idof,top_vert_id ) = & - mesh % get_vertex_cell_owner(ivert,icell) - id_owned = id_owned + (ndata * ( nlayers + 1) ) + do ivert = 1, number_2d_vertices + bottom_vert_id = mesh%get_vert_on_cell(ivert, icell) + top_vert_id = mesh%get_vert_on_cell(ivert + number_2d_vertices, icell) + if (mesh%is_vertex_owned(ivert, icell)) then + if (dofmap_d0(1, bottom_vert_id) == 0) then + do idof = 1, ndof_vert + dofmap_d0(idof, bottom_vert_id) = id_owned + dofmap_d0(idof, top_vert_id) = id_owned + ndata_offset + dof_column_height_d0(idof, bottom_vert_id) = nlayers + 1 + dof_column_height_d0(idof, top_vert_id) = 0 + dof_cell_owner_d0(idof, bottom_vert_id) = & + mesh%get_vertex_cell_owner(ivert, icell) + + dof_cell_owner_d0(idof, top_vert_id) = & + mesh%get_vertex_cell_owner(ivert, icell) + + id_owned = id_owned + (ndata * (nlayers + 1)) end do end if else - if ( dofmap_d0(1,bottom_vert_id) == 0 ) then - do idof=1, ndof_vert - dofmap_d0(idof,bottom_vert_id) = id_halo - dofmap_d0(idof,top_vert_id) = id_halo - ndata - dof_column_height_d0(idof,bottom_vert_id) = nlayers + 1 - dof_column_height_d0(idof,top_vert_id ) = 0 - dof_cell_owner_d0(idof,bottom_vert_id) = & - mesh%get_vertex_cell_owner(ivert,icell) - dof_cell_owner_d0(idof,top_vert_id ) = & - mesh%get_vertex_cell_owner(ivert,icell) - id_halo = id_halo - (ndata * ( nlayers + 1) ) + if (dofmap_d0(1, bottom_vert_id) == 0) then + do idof = 1, ndof_vert + dofmap_d0(idof, bottom_vert_id) = id_halo + dofmap_d0(idof, top_vert_id) = id_halo - ndata_offset + dof_column_height_d0(idof, bottom_vert_id) = nlayers + 1 + dof_column_height_d0(idof, top_vert_id) = 0 + dof_cell_owner_d0(idof, bottom_vert_id) = & + mesh%get_vertex_cell_owner(ivert, icell) + + dof_cell_owner_d0(idof, top_vert_id) = & + mesh%get_vertex_cell_owner(ivert, icell) + + id_halo = id_halo - (ndata * (nlayers + 1)) end do end if end if end do - if(icell == tot_num_inner + mesh%get_num_cells_edge())then + if (icell == tot_num_inner + mesh%get_num_cells_edge()) then last_dof_owned = id_owned - 1 last_dof_annexed = id_owned - id_halo - 2 end if end do cell_loop - if (idepth <= mesh%get_halo_depth()) & - last_dof_halo(idepth) = id_owned - id_halo - 2 + if (idepth <= mesh%get_halo_depth()) then + last_dof_halo(idepth) = id_owned - id_halo - 2 + end if - start = finish+1 + start = finish + 1 if (idepth < mesh%get_halo_depth()) then - finish = start + mesh % get_num_cells_halo(idepth+1)-1 + finish = start + mesh%get_num_cells_halo(idepth + 1) - 1 else - finish = start + mesh % get_num_cells_ghost()-1 + finish = start + mesh%get_num_cells_ghost() - 1 end if end do halo_loop + ! The zeroth depth halo contains no dofs, so set the last dof to be the + ! same as the last dof before it in memory - i.e. the last annexed dof + last_dof_halo(0) = last_dof_annexed ! Copy from the dofmap_dn arrays into one dofmap array dof_column_height(:,:) = -999 - dof_cell_owner(:,:) = -999 - dofmap(:,:) = -999 + dof_cell_owner(:,:) = -999 + dofmap(:,:) = -999 - do icell=1, ncells + do icell = 1, ncells dof_idx = 1 ! dofs in volumes !---------------------------------------- - do idof=1, ndof_vol - if ( dofmap_d3(idof,icell) /= 0 ) then + do idof = 1, ndof_vol + if (dofmap_d3(idof, icell) /= 0) then - if ( dofmap_d3(idof,icell) > 0 ) then - dofmap(dof_idx,icell) = dofmap_d3(idof,icell) - else if ( dofmap_d3(idof,icell) < 0 ) then - dofmap(dof_idx,icell) = id_owned - (dofmap_d3(idof,icell) + 1) + if (dofmap_d3(idof, icell) > 0) then + dofmap(dof_idx, icell) = dofmap_d3(idof, icell) + else if (dofmap_d3(idof, icell) < 0) then + dofmap(dof_idx, icell) = id_owned - (dofmap_d3(idof, icell) + 1) end if - dof_column_height(dof_idx,icell) = dof_column_height_d3(idof,icell) - dof_cell_owner(dof_idx,icell) = dof_cell_owner_d3(idof,icell) + dof_column_height(dof_idx, icell) = dof_column_height_d3(idof, icell) + dof_cell_owner(dof_idx, icell) = dof_cell_owner_d3(idof, icell) dof_idx = dof_idx + 1 end if @@ -2044,18 +2305,25 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! dofs on faces !---------------------------------------- - do iface=1, number_faces - face_id = mesh % get_face_on_cell(iface,icell) - do idof=1, ndof_face - if ( dofmap_d2(idof,face_id) /= 0 ) then - if ( dofmap_d2(idof,face_id) > 0 ) then - dofmap(dof_idx,icell) = dofmap_d2(idof,face_id) - else if ( dofmap_d2(idof,face_id) < 0 ) then - dofmap(dof_idx,icell) = id_owned - (dofmap_d2(idof,face_id) + 1) + do iface = 1, number_faces + face_id = mesh%get_face_on_cell(iface, icell) + if (iface <= number_horizontal_faces) then + ndof_stop = ndof_face_h ! Horizontal faces + else + ndof_stop = ndof_face_v ! Vertical faces + end if + + do idof = 1, ndof_stop + if (dofmap_d2(idof, face_id) /= 0) then + if (dofmap_d2(idof, face_id) > 0) then + dofmap(dof_idx, icell) = dofmap_d2(idof, face_id) + else if (dofmap_d2(idof, face_id) < 0) then + dofmap(dof_idx, icell) = id_owned - (dofmap_d2(idof, face_id) + 1) end if - dof_column_height(dof_idx,icell) = dof_column_height_d2(idof,face_id) - dof_cell_owner(dof_idx,icell) = dof_cell_owner_d2(idof,face_id) + dof_column_height(dof_idx, icell) = dof_column_height_d2(idof, & + face_id) + dof_cell_owner(dof_idx, icell) = dof_cell_owner_d2(idof, face_id) dof_idx = dof_idx + 1 end if @@ -2064,17 +2332,26 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! dofs on edges !---------------------------------------- - do iedge=1, number_edges - edge_id = mesh % get_edge_on_cell(iedge,icell) - do idof=1, ndof_edge - if ( dofmap_d1(idof,edge_id) /= 0 ) then - if ( dofmap_d1(idof,edge_id) > 0 ) then - dofmap(dof_idx,icell) = dofmap_d1(idof,edge_id) - else if ( dofmap_d1(idof,edge_id) < 0 ) then - dofmap(dof_idx,icell) = id_owned - (dofmap_d1(idof,edge_id) + 1) + do iedge = 1, number_edges + edge_id = mesh%get_edge_on_cell(iedge, icell) + if ((iedge <= number_horizontal_edges) .or. & + (iedge > number_edges - number_horizontal_edges)) then + ndof_stop = ndof_edge_h ! Horizontal edges + else + ndof_stop = ndof_edge_v ! Vertical edges + end if + + do idof = 1, ndof_stop + if (dofmap_d1(idof, edge_id) /= 0) then + if (dofmap_d1(idof, edge_id) > 0) then + dofmap(dof_idx, icell) = dofmap_d1(idof, edge_id) + else if (dofmap_d1(idof, edge_id) < 0) then + dofmap(dof_idx, icell) = id_owned - (dofmap_d1(idof, edge_id) + 1) end if - dof_column_height(dof_idx,icell) = dof_column_height_d1(idof,edge_id) - dof_cell_owner(dof_idx,icell) = dof_cell_owner_d1(idof,edge_id) + + dof_column_height(dof_idx, icell) = dof_column_height_d1(idof, & + edge_id) + dof_cell_owner(dof_idx, icell) = dof_cell_owner_d1(idof, edge_id) dof_idx = dof_idx + 1 end if end do @@ -2082,17 +2359,19 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! dofs on vertices !---------------------------------------- - do ivert=1, number_vertices - vert_id = mesh % get_vert_on_cell(ivert,icell) - do idof=1, ndof_vert - if ( dofmap_d0(idof,vert_id) /= 0 ) then - if ( dofmap_d0(idof,vert_id) > 0 ) then - dofmap(dof_idx,icell) = dofmap_d0(idof,vert_id) - else if ( dofmap_d0(idof,vert_id) < 0 ) then - dofmap(dof_idx,icell) = id_owned - (dofmap_d0(idof,vert_id) + 1) + do ivert = 1, number_vertices + vert_id = mesh%get_vert_on_cell(ivert, icell) + do idof = 1, ndof_vert + if (dofmap_d0(idof, vert_id) /= 0) then + if (dofmap_d0(idof, vert_id) > 0) then + dofmap(dof_idx, icell) = dofmap_d0(idof, vert_id) + else if (dofmap_d0(idof, vert_id) < 0) then + dofmap(dof_idx, icell) = id_owned - (dofmap_d0(idof, vert_id) + 1) end if - dof_column_height(dof_idx,icell) = dof_column_height_d0(idof,vert_id) - dof_cell_owner(dof_idx,icell) = dof_cell_owner_d0(idof,vert_id) + + dof_column_height(dof_idx, icell) = dof_column_height_d0(idof, & + vert_id) + dof_cell_owner(dof_idx, icell) = dof_cell_owner_d0(idof, vert_id) dof_idx = dof_idx + 1 end if end do @@ -2100,52 +2379,58 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & end do - dofmap(:,0) = 0 + dofmap(:, 0) = 0 - if (allocated( dofmap_d0 )) deallocate( dofmap_d0 ) - if (allocated( dofmap_d1 )) deallocate( dofmap_d1 ) - if (allocated( dofmap_d2 )) deallocate( dofmap_d2 ) - if (allocated( dofmap_d3 )) deallocate( dofmap_d3 ) + if (allocated(dofmap_d0)) deallocate(dofmap_d0) + if (allocated(dofmap_d1)) deallocate(dofmap_d1) + if (allocated(dofmap_d2)) deallocate(dofmap_d2) + if (allocated(dofmap_d3)) deallocate(dofmap_d3) - if (allocated( dof_column_height_d0 )) deallocate( dof_column_height_d0 ) - if (allocated( dof_column_height_d1 )) deallocate( dof_column_height_d1 ) - if (allocated( dof_column_height_d2 )) deallocate( dof_column_height_d2 ) - if (allocated( dof_column_height_d3 )) deallocate( dof_column_height_d3 ) + if (allocated(dof_column_height_d0)) deallocate(dof_column_height_d0) + if (allocated(dof_column_height_d1)) deallocate(dof_column_height_d1) + if (allocated(dof_column_height_d2)) deallocate(dof_column_height_d2) + if (allocated(dof_column_height_d3)) deallocate(dof_column_height_d3) - if (allocated( dof_cell_owner_d0 )) deallocate( dof_cell_owner_d0 ) - if (allocated( dof_cell_owner_d1 )) deallocate( dof_cell_owner_d1 ) - if (allocated( dof_cell_owner_d2 )) deallocate( dof_cell_owner_d2 ) - if (allocated( dof_cell_owner_d3 )) deallocate( dof_cell_owner_d3 ) + if (allocated(dof_cell_owner_d0)) deallocate(dof_cell_owner_d0) + if (allocated(dof_cell_owner_d1)) deallocate(dof_cell_owner_d1) + if (allocated(dof_cell_owner_d2)) deallocate(dof_cell_owner_d2) + if (allocated(dof_cell_owner_d3)) deallocate(dof_cell_owner_d3) ! Special cases for lowest order w3 and wtheta. These allow global_dof_id ! to have an index space with no gaps in it for these specific funct spaces - num_layers=int(nlayers,i_halo_index)+1_i_halo_index - if(element_order==0.and.gungho_fs==W3)num_layers=int(nlayers,i_halo_index) - num_dofs=int(ndof_cell,i_halo_index) - if(element_order==0.and.gungho_fs==WTHETA)num_dofs=1_i_halo_index - num_ndata=int(ndata,i_halo_index) + num_layers = int(nlayers, i_halo_index) + 1_i_halo_index + num_dofs = int(ndof_cell, i_halo_index) + num_ndata = int(ndata, i_halo_index) + if( element_order_h == 0 .and. element_order_v == 0 ) then + if (gungho_fs == W3) then + num_layers = int(nlayers, i_halo_index) + else if( gungho_fs == WTHETA ) then + num_dofs = 1_i_halo_index + end if + end if ! Calculate a globally unique id for each dof, such that each partition ! that needs access to that dof will calculate the same id global_dof_id(:) = 0_i_halo_index - do icell=1, ncells - global_cell_id = mesh % get_gid_from_lid(icell) - do idof=1, ndof_cell - if (icell == dof_cell_owner(idof,icell)) then - do k=1, dof_column_height(idof, icell) - do m=1, ndata + do icell = 1, ncells + global_cell_id = mesh%get_gid_from_lid(icell) + do idof = 1, ndof_cell + if (icell == dof_cell_owner(idof, icell)) then + do k = 1, dof_column_height(idof, icell) + do m = 1, ndata ! The following line is very confused by the casting that is ! required, but it is actually calculating the global id as being: - ! (global_cell_id-1) * num_dofs*ndata*num_layers + - ! (idof-1) * ndata*num_layers + - ! (k - 1)* ndata + - ! (m - 1) - global_dof_id( dofmap(idof,icell)+(k-1)+(m-1) ) = & - (int(global_cell_id,i_halo_index)-1_i_halo_index)* & - num_dofs*num_ndata*num_layers + & - (int(idof,i_halo_index)-1_i_halo_index)* num_ndata*num_layers + & - (int(k,i_halo_index) - 1_i_halo_index)* num_ndata + & - int(m,i_halo_index) - 1_i_halo_index + ! (global_cell_id-1) * num_dofs * ndata * num_layers + ! + (idof-1) * ndata*num_layers + ! + (k - 1) * ndata + ! + (m - 1) + global_dof_id(dofmap(idof, icell) + (k - 1) * ndata + (m - 1)) = & + (int(global_cell_id, i_halo_index) - 1_i_halo_index) & + * num_dofs * num_ndata * num_layers & + + (int(idof, i_halo_index) - 1_i_halo_index) & + * num_ndata * num_layers & + + (int(k, i_halo_index) - 1_i_halo_index) * num_ndata & + + (int(m, i_halo_index) - 1_i_halo_index) end do end do end if @@ -2157,75 +2442,32 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! will work for all function spaces - even if they don't have cell vol dofs ! loop over local cells - do icell=1, mesh%get_last_edge_cell() - global_cell_id = mesh % get_gid_from_lid(icell) - do m=1, ndata + do icell = 1, mesh%get_last_edge_cell() + global_cell_id = mesh%get_gid_from_lid(icell) + do m = 1, ndata ! The global ids must be 0 based - global_cell_dof_id_2d( (icell-1)*ndata + m ) = & - (global_cell_id - 1)*ndata + m - 1 + global_cell_dof_id_2d((icell - 1) * ndata + m) = (global_cell_id - 1) & + * ndata & + + m - 1 end do end do - ! Calculate a globally unique id for the dofs on the edges of each cell - ! in the 2D horizontal part of the local domain - only possible for - ! function spaces that (appear to) have 2d edge dofs - ! (for the moment, using W2H as an example of such a function space - ! - the 2d layer at the half levels appears to have edge dofs). - if(element_order==0 .and. gungho_fs==W2H)then - ! loop over local cells - do icell=1, mesh%get_last_edge_cell() - ! loop over 2d edges within a cell - do iedge=1, mesh%get_nedges_per_cell_2d() - if(mesh%is_edge_owned(iedge,icell))then - do m=1, ndata - global_edge_dof_id_2d(((dofmap(iedge,icell)-1)/(nlayers*ndata))+1) = & - (mesh%get_edge_gid_on_cell(iedge,icell) - 1)*ndata + m - 1 - end do - endif - end do - end do - else - global_edge_dof_id_2d(:) = -1 - end if - - ! Calculate a globally unique id for the dofs on the vertices of each cell - ! in the 2D horizontal part of the local domain - only possible for - ! function spaces that have vertex dofs. - ! (for the moment, using W0 as an example of such a function space). - if(element_order==0 .and. gungho_fs==W0)then - ! loop over local cells - do icell=1, mesh%get_last_edge_cell() - ! loop over 2d vertices within a cell - do ivert=1, mesh%get_nverts_per_cell_2d() - if(mesh%is_vertex_owned(ivert,icell))then - do m=1, ndata - global_vert_dof_id_2d(((dofmap(ivert,icell)-1)/((nlayers+1)*ndata))+1) = & - (mesh%get_vert_gid_on_cell(ivert,icell) - 1)*ndata + m - 1 - end do - endif - end do - end do - else - global_vert_dof_id_2d(:) = -1 - end if + if (allocated(dof_column_height)) deallocate(dof_column_height) + if (allocated(dof_cell_owner)) deallocate(dof_cell_owner) + + if (allocated(select_entity_all%faces)) deallocate(select_entity_all%faces) + if (allocated(select_entity_all%edges)) deallocate(select_entity_all%edges) + if (allocated(select_entity_all%verts)) deallocate(select_entity_all%verts) + if (allocated(select_entity_theta%faces)) deallocate(select_entity_theta%faces) + if (allocated(select_entity_theta%edges)) deallocate(select_entity_theta%edges) + if (allocated(select_entity_theta%verts)) deallocate(select_entity_theta%verts) + if (allocated(select_entity_w2v%faces)) deallocate(select_entity_w2v%faces) + if (allocated(select_entity_w2v%edges)) deallocate(select_entity_w2v%edges) + if (allocated(select_entity_w2v%verts)) deallocate(select_entity_w2v%verts) + if (allocated(select_entity_w2h%faces)) deallocate(select_entity_w2h%faces) + if (allocated(select_entity_w2h%edges)) deallocate(select_entity_w2h%edges) + if (allocated(select_entity_w2h%verts)) deallocate(select_entity_w2h%verts) - if (allocated(dof_column_height)) deallocate( dof_column_height ) - if (allocated(dof_cell_owner)) deallocate( dof_cell_owner ) - - if (allocated( select_entity_all % faces )) deallocate( select_entity_all % faces ) - if (allocated( select_entity_all % edges )) deallocate( select_entity_all % edges ) - if (allocated( select_entity_all % verts )) deallocate( select_entity_all % verts ) - if (allocated( select_entity_theta % faces )) deallocate( select_entity_theta % faces ) - if (allocated( select_entity_theta % edges )) deallocate( select_entity_theta % edges ) - if (allocated( select_entity_theta % verts )) deallocate( select_entity_theta % verts ) - if (allocated( select_entity_w2v % faces )) deallocate( select_entity_w2v % faces ) - if (allocated( select_entity_w2v % edges )) deallocate( select_entity_w2v % edges ) - if (allocated( select_entity_w2v % verts )) deallocate( select_entity_w2v % verts ) - if (allocated( select_entity_w2h % faces )) deallocate( select_entity_w2h % faces ) - if (allocated( select_entity_w2h % edges )) deallocate( select_entity_w2h % edges ) - if (allocated( select_entity_w2h % verts )) deallocate( select_entity_w2h % verts ) - - return end subroutine dofmap_setup !----------------------------------------------------------------------------- @@ -2238,36 +2480,38 @@ end subroutine dofmap_setup !> @param[in] fs Integer enumeration of the function space. !> @param[out] levels Array of fractional levels. !> - subroutine levels_setup( mesh, nlayers, fs, levels ) + subroutine levels_setup(mesh, nlayers, fs, levels) implicit none - type(mesh_type), intent(in) :: mesh - integer(i_def), intent(in) :: nlayers - integer(i_def), intent(in) :: fs - real(r_def), intent(out), allocatable :: levels(:) + type(mesh_type), intent(in) :: mesh + + integer(i_def), intent(in) :: nlayers + integer(i_def), intent(in) :: fs - class(reference_element_type), pointer :: reference_element => null() + real(r_def), intent(out), allocatable :: levels(:) + + class(reference_element_type), pointer :: reference_element => null() real(r_def), allocatable :: vert_coords(:,:) real(r_def), allocatable :: edge_coords(:,:) real(r_def), allocatable :: face_coords(:,:) real(r_def), allocatable :: volume_coords(:,:) ! Variable to hold the number of levels we found - integer(i_def) :: idx + integer(i_def) :: idx ! working array to hold fractional levels real(r_def), allocatable :: tmp_levs(:) - type(select_data_entity_type) :: select_data_entity_all, & - select_data_entity_theta, & - select_data_entity_w2h, & - select_data_entity_w2v + type(select_data_entity_type) :: select_data_entity_all, & + select_data_entity_theta, & + select_data_entity_w2h, & + select_data_entity_w2v reference_element => mesh%get_reference_element() - call reference_element%get_vertex_coordinates( vert_coords ) - call reference_element%get_edge_centre_coordinates( edge_coords ) - call reference_element%get_face_centre_coordinates( face_coords ) - call reference_element%get_volume_centre_coordinates( volume_coords ) + call reference_element%get_vertex_coordinates(vert_coords) + call reference_element%get_edge_centre_coordinates(edge_coords) + call reference_element%get_face_centre_coordinates(face_coords) + call reference_element%get_volume_centre_coordinates(volume_coords) call setup_select_data_entities( mesh, & select_data_entity_all, & @@ -2277,7 +2521,6 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) select case (fs) - case (W0) ! W0 locates data on vertices @@ -2305,7 +2548,6 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) tmp_levs, & idx ) - case (W3) ! W3 locates data on cell volume @@ -2315,7 +2557,6 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) tmp_levs, & idx ) - case (WTHETA) ! WTheta locates data on selected faces ! (top and bottom) @@ -2326,8 +2567,7 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) tmp_levs, & idx ) - - case (W2H) + case (W2H, W2Hbroken) ! W2H locates data on selected faces ! (top and bottom) @@ -2337,7 +2577,6 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) tmp_levs, & idx ) - case (W2V) ! W2V locates data on selected faces ! (W, S, E, N) @@ -2359,10 +2598,10 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) ! Allocate the out array to be the size of the number of levels we found ! and copy in the data from the temp array - allocate( levels( size(tmp_levs(1:(idx-1))) ) ) - levels=tmp_levs(1:(idx-1)) + allocate(levels(size(tmp_levs(1:(idx - 1))))) + levels = tmp_levs(1:(idx - 1)) - nullify( reference_element ) + nullify(reference_element) if (allocated(vert_coords)) deallocate(vert_coords) if (allocated(edge_coords)) deallocate(edge_coords) if (allocated(face_coords)) deallocate(face_coords) @@ -2401,20 +2640,20 @@ subroutine compute_levels( nlayers, & ! Local variables for computation real(r_def) :: l - integer(i_def) :: ilayer, idof + integer(i_def) :: ilayer, idof ! Allocate temp levels array to be the maximum possible size - allocate(tmp_levs(size(entity_array)*nlayers)) - tmp_levs = 999.0 - idx=1 + allocate(tmp_levs(size(entity_array) * nlayers)) + tmp_levs = 999.0_r_def + idx = 1 - do ilayer=0, (nlayers - 1) + do ilayer = 0, (nlayers - 1) do idof = 1, size(entity_array) ! Check this mesh entity is not marked as missing for this function ! space if (entity_array(idof) /= IMDI) then - l = ilayer + coords_array(entity_array(idof),3) - if ( .not.(any(tmp_levs == l)) ) then + l = ilayer + coords_array(entity_array(idof), 3) + if (.not.(any(tmp_levs == l))) then tmp_levs(idx) = l ! keep track of how many items we added idx = idx + 1 @@ -2425,4 +2664,47 @@ subroutine compute_levels( nlayers, & end subroutine compute_levels + !> @brief Generate a unique integer id for a function space + !> @param[in] lfric_fs Function space continuity flag + !> @param[in] element_order_h Polynomial order of the space in the horizontal + !> @param[in] element_order_v Polynomial order of the space in the vertical + !> @param[in] mesh_id Id of the mesh to build the function space on + !> @param[in] ndata Number of multidata points + !> @param[in] ndata_first ndata of layer first layout of multidata array + !> @result fs_id Unique id for the function space + function generate_fs_id(lfric_fs, element_order_h, element_order_v, mesh_id, & + ndata, ndata_first) result(fs_id) + + implicit none + + integer(i_def), intent(in) :: lfric_fs + integer(i_def), intent(in) :: element_order_h + integer(i_def), intent(in) :: element_order_v + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: ndata + logical(l_def), intent(in) :: ndata_first + + integer(i_def) :: fs_id + integer(i_def) :: ndata_first_int + + if ( ndata_first ) then + ndata_first_int = 1 + else + ndata_first_int = 2 + end if + + ! Temporary clause for #4443, will be removed when split element orders are + ! fully enabled in #4462 + if ( element_order_h /= element_order_v ) then + call log_event( & + 'Current infrastructure requires element orders to match', & + LOG_LEVEL_ERROR) + else + fs_id = ndata + 1000_i_def*element_order_h + 10000_i_def*element_order_v & + + 100000_i_def*lfric_fs + 10000000_i_def*mesh_id & + + 1000000000_i_def*ndata_first_int + end if + + end function generate_fs_id + end module function_space_constructor_helper_functions_mod diff --git a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_constructor_helper_functions_mod.f90 b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_constructor_helper_functions_mod.f90 index 7775d4f55f..f159b66ee8 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_constructor_helper_functions_mod.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_constructor_helper_functions_mod.f90 @@ -13,10 +13,11 @@ !> module function_space_constructor_helper_functions_mod - use constants_mod, only: i_def, i_halo_index, r_def, IMDI + use constants_mod, only: i_def, i_halo_index, r_def, IMDI, l_def use mesh_mod, only: mesh_type use fs_continuity_mod, only: W0, W1, W2, W2V, W2H, & W2broken, W2trace, & + W2Hbroken, & W2Vtrace, W2Htrace, & W3, Wtheta, Wchi use reference_element_mod, only: reference_element_type, & @@ -27,11 +28,11 @@ module function_space_constructor_helper_functions_mod WB, SB, EB, NB, & SW, SE, NE, NW, & WT, ST, ET, NT - + use log_mod, only: log_event, LOG_LEVEL_ERROR implicit none private - public :: ndof_setup, basis_setup, dofmap_setup, levels_setup + public :: ndof_setup, basis_setup, dofmap_setup, levels_setup, generate_fs_id ! Select entities in the function space type select_entity_type @@ -112,8 +113,7 @@ subroutine setup_select_entities( mesh, entity_all, entity_theta, & entity_w2h%edges = IMDI entity_w2h%verts = IMDI - nullify( reference_element ) - + nullify(reference_element) end subroutine setup_select_entities @@ -189,7 +189,7 @@ subroutine setup_select_data_entities( mesh, entity_all, entity_theta, & entity_w2h%edges = IMDI entity_w2h%verts = IMDI - nullify( reference_element ) + nullify(reference_element) end subroutine setup_select_data_entities @@ -202,41 +202,63 @@ end subroutine setup_select_data_entities !> composite. !> !> @param[in] mesh Mesh to define the function space on. - !> @param[in] element_order Polynomial order of the function space. + !> @param[in] element_order_h Polynomial order of the function space in the + !> horizontal directions. + !> @param[in] element_order_v Polynomial order of the function space in the + !> vertical direction. !> @param[in] gungho_fs Enumeration of the function space. !> @param[out] ndof_vert Number of dofs on each vertex. - !> @param[out] ndof_edge Number of dofs on each edge. - !> @param[out] ndof_face Number of dofs on each face. + !> @param[out] ndof_edge_h Number of dofs on each edge in the horizontal. + !> @param[out] ndof_edge_v Number of dofs on each edge in the vertical. + !> @param[out] ndof_face_h Number of dofs on each face in the horizontal. + !> @param[out] ndof_face_v Number of dofs on each face in the vertical. !> @param[out] ndof_vol Number of dofs in each volume. - !> @param[out] ndof_cell Total Number of dofs associated with a cell. - !> @param[out] ndof_glob Total Number of global dofs. - !> @param[out] ndof_interior Number of dofs with no vertical - !> connectivity. + !> @param[out] ndof_cell Total number of dofs associated with a cell. + !> @param[out] ndof_glob Total number of dofs on a rank. + !> @param[out] ndof_interior Number of dofs with no vertical connectivity. !> @param[out] ndof_exterior Number of dofs with vertical connectivity. - !> - subroutine ndof_setup( mesh, element_order, gungho_fs, & - ndof_vert, ndof_edge, ndof_face, ndof_vol, & - ndof_cell, ndof_glob, ndof_interior, ndof_exterior ) + ! + ! + ! .+---B--+ In the following an edge is called vertical if it is + ! .' | .'| normal to the horizontal plane (such as edge A), and + ! +---+--+' A horizontal if it is parallel to it (such as edge B). + ! | P | | | + ! | ,+--+---+ A face will be called horizontal if it is normal to + ! |.' Q | .' the horizontal plane (such as face P) and vertical if it + ! +------+' is parallel to it (such as face Q). + ! + ! These are chosen to agree with the naming of W2H and + ! W2V. + + subroutine ndof_setup( mesh, element_order_h, element_order_v, gungho_fs, & + ndof_vert, ndof_edge_h, ndof_edge_v, ndof_face_h, & + ndof_face_v, ndof_vol, ndof_cell, ndof_glob, & + ndof_interior, ndof_exterior ) ! NOTE: ndofs will be used as short hand for Number of Degrees Of Freedom implicit none ! Input type(mesh_type), intent(in), pointer :: mesh - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h, element_order_v integer(i_def), intent(in) :: gungho_fs ! Output - ! Number of dofs per ... - integer(i_def), intent(out) :: ndof_vert ! vertex entity - integer(i_def), intent(out) :: ndof_edge ! edge entity - integer(i_def), intent(out) :: ndof_face ! face entity - integer(i_def), intent(out) :: ndof_vol ! volume entity - - integer(i_def), intent(out) :: ndof_cell ! 3D-cell entity - integer(i_def), intent(out) :: ndof_interior ! interior entity (in vertical) - integer(i_def), intent(out) :: ndof_exterior ! exterior entity (in vertical) - integer(i_def), intent(out) :: ndof_glob ! 3D-mesh (on a rank) + integer(i_def), intent(out) :: ndof_vert ! ndof per vertex entity + integer(i_def), intent(out) :: ndof_edge_h ! ndof per horizontal edge + ! entity + integer(i_def), intent(out) :: ndof_edge_v ! ndof per vertical edge entity + integer(i_def), intent(out) :: ndof_face_h ! ndof per horizontal face + ! entity + integer(i_def), intent(out) :: ndof_face_v ! ndof per vertical face entity + integer(i_def), intent(out) :: ndof_vol ! ndof per volume entity + + integer(i_def), intent(out) :: ndof_cell ! ndof per 3D-cell entity + integer(i_def), intent(out) :: ndof_interior ! ndof per interior entity + ! (in vertical) + integer(i_def), intent(out) :: ndof_exterior ! ndof per exterior entity + ! (in vertical) + integer(i_def), intent(out) :: ndof_glob ! ndof per 3D-mesh (on a rank) ! Local variables @@ -246,10 +268,7 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! Variables for properties of the local 3D-Mesh integer(i_def) :: ncells ! No. of 2D-cells in 3D-mesh partition integer(i_def) :: nlayers ! No. of layers of 3D-cells - integer(i_def) :: nface_g ! No. of faces - integer(i_def) :: nedge_g ! No. of edges - integer(i_def) :: nvert_g ! No. of vertices - integer(i_def) :: nedges_per_level ! No. of edges per level + integer(i_def) :: nedges_2d ! No. of edges per level ! Variables for Exterior-Interior topology (vertical direction) integer(i_def) :: nverts_exterior ! No. of vertices per exterior entity @@ -258,25 +277,34 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & integer(i_def) :: nedges_interior ! No. of edges per interior entity integer(i_def) :: nfaces_interior ! No. of faces per interior entity - integer(i_def) :: k + integer(i_def) :: nface_g_h ! Global No. of horizontal faces + integer(i_def) :: nface_g_v ! Global No. of vertical faces + integer(i_def) :: nedge_g_h ! Global No. of horizontal edges + integer(i_def) :: nedge_g_v ! Global No. of vertical edges + integer(i_def) :: nvert_g ! Global No. of vertices - ! Adding ndof for exterior and interior composite entities - ! - ! ndof_exterior = ndof_edge*nedges_exterior - ! + ndof_face*nfaces_exterior - ! + ndof_vert*nverts_exterior + integer(i_def) :: k_h, k_v + + ! Adding ndof for exterior and interior composite entities: ! - ! ndof_interior = ndof_edge*nedges_interior - ! + ndof_face*nfaces_interior - ! + ndof_vol + ! ndof_exterior = ndof_edge_h*nedges_exterior + ! + ndof_face_v*nfaces_exterior + ! + ndof_vert*nverts_exterior + + ! ndof_interior = ndof_edge_v*nedges_interior + ! + ndof_face_h*nfaces_interior + ! + ndof_vol ! - ! Elements on interior/exterior cell decomposition in vertical, - ! the horizontal faces and associated edges/vertices - ! (i.e. top OR bottom ) are classed as exterior entities. - ! The vertical faces/edges are classed as an interior entities. + ! Elements on interior/exterior cell decomposition in vertical. + ! The vertical faces, horizontal edges, and vertices (i.e. top OR bottom ) + ! are classed as exterior entities. + ! The horizontal faces and vertical edges are classed as an interior + ! entities. reference_element => mesh%get_reference_element() + ! Local values: + ! Values for cell entity calculations nverts_exterior = reference_element%get_number_2d_vertices() nedges_exterior = reference_element%get_number_2d_edges() nfaces_exterior = 1 @@ -284,41 +312,45 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & nedges_interior = reference_element%get_number_2d_vertices() nfaces_interior = reference_element%get_number_2d_edges() - - ! Local values - nlayers = mesh % get_nlayers() - ncells = mesh % get_ncells_2d_with_ghost() - nface_g = mesh % get_nfaces() - nedge_g = mesh % get_nedges() - nvert_g = mesh % get_nverts() - nedges_per_level = mesh % get_nedges_2d() - - ndof_vert = 0 - ndof_edge = 0 - ndof_face = 0 - ndof_vol = 0 - ndof_cell = 0 - ndof_glob = 0 - - ndof_interior = 0 - ndof_exterior = 0 - - k = element_order + ! Values for global calculations + nlayers = mesh%get_nlayers() + ncells = mesh%get_ncells_2d_with_ghost() + nedges_2d = mesh%get_nedges_2d() + + nface_g_v = ncells*(nlayers + 1) + nface_g_h = nedges_2d*nlayers + nedge_g_v = mesh%get_nverts_2d()*nlayers + nedge_g_h = nedges_2d*(nlayers + 1) + nvert_g = mesh%get_nverts() + + ! dof values + ndof_vert = 0 + ndof_edge_h = 0 + ndof_edge_v = 0 + ndof_face_h = 0 + ndof_face_v = 0 + ndof_vol = 0 + ndof_cell = 0 + ndof_glob = 0 + + k_h = element_order_h + k_v = element_order_v ! Possible modifications to number of dofs ! on edges depending on presets select case (gungho_fs) case (W0) - ! H1 locates dofs on the element vertices for a element order = 0, + ! H1 locates dofs on the element vertices for element order = 0, ! though the order for the H1 function space is k+1, i.e. ! linear across the element on each axis - ndof_vert = 1 - ndof_edge = k - ndof_face = k*k - ndof_vol = k*k*k - ndof_cell = (k+2)*(k+2)*(k+2) - + ndof_vert = 1 + ndof_edge_h = k_h + ndof_edge_v = k_v + ndof_face_h = k_h*k_v + ndof_face_v = k_h*k_h + ndof_vol = k_h*k_h*k_v + ndof_cell = (k_h + 2)*(k_h + 2)*(k_v + 2) case (W1) ! Dofs located on edges, as vectors @@ -326,11 +358,14 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! For order 0, the vector is constant along the ! edge, but can vary linearly normal to it. - ndof_edge = (k+1) - ndof_face = 2*(k+1)*k - ndof_vol = 3*(k+1)*k*k - ndof_cell = 3*(k+1)*(k+2)*(k+2) - + ndof_edge_h = (k_h + 1) + ndof_edge_v = (k_v + 1) + ndof_face_h = (k_h + 1)*k_v + k_h*(k_v + 1) + ndof_face_v = 2*(k_h + 1)*k_h + ndof_vol = 2*k_h*(k_h + 1)*k_v & + + k_h*k_h*(k_v + 1) + ndof_cell = 2*(k_h + 1)*(k_h + 2)*(k_v + 2) & + + (k_h + 2)*( k_h + 2)*(k_v + 1) case (W2) ! Dofs are located on faces for vector fields @@ -341,29 +376,29 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! vary linearly passing through the face(normal) to ! the next cell. ! - ! So linear in normal: 1-dim, ndof = 2 - ! So constant in tangential: 2-dim, each ndof = 1 - ! So 3 dimensions each with ndof (k+2)(k+1)(k+1) - ! ! NOTE: Not correct for simplices - ndof_face = (k+1)*(k+1) - ndof_vol = 3*(k+1)*(k+1)*k - ndof_cell = 3*(k+1)*(k+1)*(k+2) - + ndof_face_h = (k_h + 1)*(k_v + 1) + ndof_face_v = (k_h + 1)*(k_h + 1) + ndof_vol = 2*k_h*(k_h + 1)*(k_v + 1) & + + (k_h + 1)*(k_h + 1)*k_v + ndof_cell = 2*(k_h + 2)*(k_h + 1)*(k_v + 1) & + + (k_h + 1)*(k_h + 1)*(k_v + 2) case (W2H) + ! Dofs are located at the horizontal components of W2, giving variables + ! the values of the first term in the sums in the W2 case. nfaces_exterior = 0 - ndof_face = (k+1)*(k+1) - ndof_vol = 2*k*(k+1)*(k+1) - ndof_cell = 2*(k+2)*(k+1)*(k+1) - + ndof_face_h = (k_h + 1)*(k_v + 1) + ndof_vol = 2*k_h*(k_h + 1)*(k_v + 1) + ndof_cell = 2*(k_h + 1)*(k_h + 2)*(k_v + 1) case (W2V) + ! Dofs are located at the vertical components of W2, giving variables + ! the values of the second term in the sums in the W2 case. nfaces_interior = 0 - ndof_face = (k+1)*(k+1) - ndof_vol = 1*k*(k+1)*(k+1) - ndof_cell = 1*(k+2)*(k+1)*(k+1) - + ndof_face_v = (k_h + 1)*(k_h + 1) + ndof_vol = (k_h + 1)*(k_h + 1)*k_v + ndof_cell = (k_h + 1)*(k_h + 1)*(k_v + 2) case (W2broken) ! Dofs are geometrically located on faces for @@ -374,15 +409,28 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! ! For order 0 the value of the vector normal to the ! face is constant across the face(tangential) but can - ! varying linearly passing through the face(normal) to + ! vary linearly passing through the face(normal) to ! the next cell. ! - ! So linear in normal: 1-dim, ndof = 2 - ! So constant in tangengial: 2-dim, each ndof = 1 - ! So 3 dimensions each with ndof (k+2)(k+1)(k+1) + ! NOTE: Not correct for simplices + ndof_vol = 2*(k_h + 1)*(k_h + 2)*(k_v + 1) & + + (k_h + 1)*(k_h + 1)*(k_v + 2) + ndof_cell = ndof_vol + + case (W2Hbroken) + ! Dofs are geometrically located on faces for + ! vector fields and direction is normal to the face. + ! However, they are topologically associated with + ! the cell volume. Hence, this function space is + ! discontinuous between cells. + ! + ! For order 0 the value of the vector normal to the + ! face is constant across the face(tangential) but can + ! vary linearly passing through the face(normal) to + ! the next cell. ! ! NOTE: Not correct for simplices - ndof_vol = 3*(k+1)*(k+1)*(k+2) + ndof_vol = 2*(k_h + 1)*(k_h + 2)*(k_v + 1) ndof_cell = ndof_vol case (W2trace) @@ -393,10 +441,11 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! This space is discontinuous across edges/vertices. ! ! NOTE: Not correct for simplices - ndof_face = (k+1)*(k+1) - ndof_cell = 6*ndof_face + ndof_face_h = (k_h + 1)*(k_v + 1) + ndof_face_v = (k_h + 1)*(k_h + 1) + ndof_cell = 4*ndof_face_h + 2*ndof_face_v - case (W2Vtrace) + case (W2Vtrace) ! This function space is the result of taking the trace ! of a W2V Hdiv space (or equivalently taking only the ! vertical components of the trace of the W2 space). @@ -406,8 +455,9 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! This space is discontinuous across edges/vertices. ! ! NOTE: Not correct for simplices - ndof_face = (k+1)*(k+1) - ndof_cell = 2*ndof_face + nfaces_interior = 0 + ndof_face_v = (k_h + 1)*(k_h + 1) + ndof_cell = 2*ndof_face_v case (W2Htrace) ! This function space is the result of taking the trace @@ -419,8 +469,9 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! This space is discontinuous across edges/vertices. ! ! NOTE: Not correct for simplices - ndof_face = (k+1)*(k+1) - ndof_cell = 4*ndof_face + nfaces_exterior = 0 + ndof_face_h = (k_h + 1)*(k_v + 1) + ndof_cell = 4*ndof_face_h case (W3) ! Order of this function space is same as base order @@ -431,46 +482,39 @@ subroutine ndof_setup( mesh, element_order, gungho_fs, & ! between cells. ! Number of dofs on each dimension is lowest order + 1 - ndof_vol = (k+1)*(k+1)*(k+1) + ndof_vol = (k_h + 1)*(k_h + 1)*(k_v + 1) ndof_cell = ndof_vol - case (WTHETA) nfaces_interior = 0 - ndof_face = (k+1)*(k+1) - ndof_vol = k*(k+1)*(k+1) - ndof_cell = (k+2)*(k+1)*(k+1) + ndof_face_v = (k_h + 1)*(k_h + 1) + ndof_vol = (k_h + 1)*(k_h + 1)*k_v + ndof_cell = (k_h + 1)*(k_h + 1)*(k_v + 2) + case (WCHI) - ndof_vol = (k+1)*(k+1)*(k+1) + ndof_vol = (k_h + 1)*(k_h + 1)*(k_v + 1) ndof_cell = ndof_vol end select - ndof_exterior = ndof_vert*nverts_exterior & - + ndof_edge*nedges_exterior & - + ndof_face*nfaces_exterior + ndof_exterior = ndof_vert * nverts_exterior & + + ndof_edge_h * nedges_exterior & + + ndof_face_v * nfaces_exterior - ndof_interior = ndof_edge*nedges_interior & - + ndof_face*nfaces_interior & + ndof_interior = ndof_edge_v * nedges_interior & + + ndof_face_h * nfaces_interior & + ndof_vol ! Calculated the global number of dofs on the function space - select case (gungho_fs) - case (W0, W1, W2, W2broken, W2trace, W3, WCHI) - ndof_glob = ncells*nlayers*ndof_vol + nface_g*ndof_face & - + nedge_g*ndof_edge + nvert_g*ndof_vert + ndof_glob = ncells*nlayers*ndof_vol & + + nface_g_h*ndof_face_h & + + nface_g_v*ndof_face_v & + + nedge_g_h*ndof_edge_h & + + nedge_g_v*ndof_edge_v & + + nvert_g*ndof_vert - case (WTHETA, W2V, W2Vtrace) - ndof_glob = ncells*nlayers*ndof_vol + ncells*(nlayers+1)*ndof_face + nullify(reference_element) - case (W2H, W2Htrace) - ndof_glob = ncells*nlayers*ndof_vol + nedges_per_level*nlayers*ndof_face & - + nedge_g*ndof_edge + nvert_g*ndof_vert - end select - - nullify( reference_element ) - - return end subroutine ndof_setup !--------------------------------------------------------------------------- @@ -481,148 +525,216 @@ end subroutine ndof_setup !> for cube elements. It is used by the function_space_type constructor and !> is unlikely to be useful elsewhere. !> - !> @param[in] element_order Polynomial order of the function space. - !> @param[in] gungho_fs Enumeration of the function space. - !> @param[in] ndof_vert Number dofs on each vertex. - !> @param[in] ndof_cell Total number of dofs associated with a cell. + !> @param[in] element_order_h Polynomial order of the function space in + !> horizontal direction. + !> @param[in] element_order_v Polynomial order of the function space in + !> vertical direction. + !> @param[in] gungho_fs Enumeration of the function space. + !> @param[in] ndof_vert Number dofs on each vertex. + !> @param[in] ndof_cell Total number of dofs associated with a cell. !> @param[in] reference_element Object describing the reference element of !> the mesh. - !> @param[out] basis_index Array containing index of polynomial function. - !> @param[out] basis_order Polynomial order of basis function. - !> @param[out] basis_vector Direction of basis for vector functions. - !> @param[out] basis_x Array of nodal points of the basis functions. - !> @param[out] nodal_coords 3D coordinates of zeros of the basis functions. + !> @param[out] basis_index Array containing index of polynomial + !> function. + !> @param[out] basis_order Polynomial order of basis function. + !> @param[out] basis_vector Direction of basis for vector functions. + !> @param[out] basis_x Array of nodal points of the x and y basis + !> functions. + !> @param[out] basis_z Array of nodal points of the basis z basis + !> functions. + !> @param[out] nodal_coords 3D coordinates of zeros of the basis + !> functions. !> @param[out] dof_on_vert_boundary Array indication if a dof is on the top !> or bottom boundary of a cell. - !> @param[out] entity_dofs Array of labels which maps degree of freedom - !> index to geometric entity the dof lies on. + !> @param[out] entity_dofs Array of labels which maps degree of freedom + !> index to geometric entity the dof lies on. !> - subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & - reference_element, & - basis_index, basis_order, basis_vector, basis_x, & - nodal_coords, dof_on_vert_boundary, entity_dofs ) + subroutine basis_setup( element_order_h, element_order_v, gungho_fs, & + ndof_vert, ndof_cell, reference_element, & + basis_index, basis_order, basis_vector, basis_x, & + basis_z, nodal_coords, dof_on_vert_boundary, & + entity_dofs ) implicit none ! Input - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h + integer(i_def), intent(in) :: element_order_v integer(i_def), intent(in) :: gungho_fs - ! Number of dofs per entity - integer(i_def), intent(in) :: ndof_vert ! ndofs per vertex - integer(i_def), intent(in) :: ndof_cell ! ndofs per 3D-cell + integer(i_def), intent(in) :: ndof_vert ! ndofs (number of dofs) per vertex + integer(i_def), intent(in) :: ndof_cell ! ndofs (number of dofs) per 3D-cell class(reference_element_type), intent(in), pointer :: reference_element ! Output - integer(i_def), intent(out) :: basis_index (:,:) - integer(i_def), intent(out) :: basis_order (:,:) - real(r_def), intent(out) :: basis_vector (:,:) - real(r_def), intent(out) :: basis_x (:,:,:) - real(r_def), intent(out) :: nodal_coords (:,:) - integer(i_def), intent(out) :: dof_on_vert_boundary (:,:) + integer(i_def), intent(out) :: basis_index(:,:) + integer(i_def), intent(out) :: basis_order(:,:) + real(r_def), intent(out) :: basis_vector(:,:) + real(r_def), intent(out) :: basis_x(:,:,:) + real(r_def), intent(out) :: basis_z(:,:) + real(r_def), intent(out) :: nodal_coords(:,:) + integer(i_def), intent(out) :: dof_on_vert_boundary(:,:) integer(i_def), intent(out) :: entity_dofs(:) - integer(i_def) :: k + ! Local variables + integer(i_def) :: k_h, k_v ! Horizontal and vertical element orders + integer(i_def) :: k_switch ! Can be set to k_h or k_v + + integer(i_def) :: i ! General loop variable + integer(i_def) :: jx, jy, jz ! x, y, z loop variables + integer(i_def) :: idx ! Index of dof + integer(i_def) :: j1, j2 ! Face/edge loop variables + integer(i_def) :: j(3) ! Tuple containing face or edge indices such + ! as j1, j2, face_idx and edge_idx + + integer(i_def) :: j2l_edge(12, 3), j2l_face(6, 3) ! Indexes conversion from + ! j to lx, ly and lz + + integer(i_def) :: face_idx(6), edge_idx(12, 2) ! Indices of nodal points + ! on faces and edges + + integer(i_def), allocatable :: lx(:), ly(:), lz(:) ! 3d indices of dofs + + real(r_def), allocatable :: unit_vec(:,:) ! Unit tangent to an edge dof + ! or normal to a face dof - integer(i_def) :: i, jx, jy, jz, poly_order, idx, j1, j2 - integer(i_def) :: j(3), j2l_edge(12,3), j2l_face(6,3), face_idx(6), edge_idx(12,2) - integer(i_def), allocatable :: lx(:), ly(:), lz(:) - real(r_def), allocatable :: unit_vec(:,:) + real(r_def) :: x1h(element_order_h+2) ! Evenly spaces nodes of continuous + ! 1D element (used in horizontal) + real(r_def) :: x1v(element_order_v+2) ! Evenly spaces nodes of continuous + ! 1D element (used in vertical) - real(r_def) :: x1(element_order+2) - real(r_def) :: x2(element_order+2) + real(r_def) :: x2h(element_order_h+2) ! Evenly spaces nodes of discontinuous + ! 1D element (used in horizontal). + ! Note: one larger than required + real(r_def) :: x2v(element_order_v+2) ! Evenly spaces nodes of discontinuous + ! 1D element (used in vertical). + ! Note: one larger than required + + real(r_def) :: coordinate(3) ! Coordinate of a vertex - real(r_def) :: coordinate(3) integer(i_def) :: edges_on_face(reference_element%get_number_edges()) integer(i_def) :: number_faces, number_edges, number_vertices - integer(i_def) :: number_horizontal_edges + integer(i_def) :: number_2d_edges + integer(i_def) :: number_faces_h number_faces = reference_element%get_number_faces() number_edges = reference_element%get_number_edges() number_vertices = reference_element%get_number_vertices() - number_horizontal_edges = reference_element%get_number_2d_edges() + number_2d_edges = reference_element%get_number_2d_edges() + number_faces_h = reference_element%get_number_2d_edges() ! To uniquely specify a 3D tensor product basis function the following is ! needed: ! basis_order(3): The polynomial order in the x,y,z directions - ! basis_x(3,basis_order+1): The nodal points of the polynomials in each - ! direction + ! basis_x(element_order_h + 2, 2, ndof_cell): + ! The nodal points of the polynomials in each horizontal + ! direction at each dof + ! basis_z(element_order_v + 2, ndof_cell): + ! The nodal points of the polynomials in each vertical + ! direction at each dof ! basis_index(3): The index of the nodal points array at which the basis ! function is unity ! basis_vector(3): Additionally if the function space is a vector then a ! unit vector is needed. ! Although not strictly needed the nodal coordinates at which each basis - ! function equals 1 is stored as nodal_coords + ! function equals 1 is stored as nodal_coords. ! A flag is also set to 0 if a basis function is associated with an entity ! on the top or bottom of the cell, i.e has nodal_coord(3) = 0 or 1 - k = element_order + k_h = element_order_h + k_v = element_order_v - ! Allocate to be larger than should be needed - allocate( lx(3*(k+2)**3) ) - allocate( ly(3*(k+2)**3) ) - allocate( lz(3*(k+2)**3) ) + allocate( lx(ndof_cell) ) + allocate( ly(ndof_cell) ) + allocate( lz(ndof_cell) ) lx(:) = 0 ly(:) = 0 lz(:) = 0 ! Positional arrays - need two, i.e quadratic and linear for RT1 - do i=1,k+2 - x1(i) = real(i-1,r_def)/real(k+1,r_def) + do i = 1, k_h + 2 + x1h(i) = real(i - 1, r_def) / real(k_h + 1, r_def) + end do + + if (k_h == 0) then + x2h(1) = 0.5_r_def + else + if (gungho_fs == W3 .or. gungho_fs == Wtheta) then + ! Evenly space the points away from the element edges for high order + ! spaces - this helps with visualising the output + do i = 1, k_h + 1 + x2h(i) = real(i, r_def) / real(k_h + 2, r_def) + end do + else + do i = 1, k_h + 1 + x2h(i) = real(i - 1, r_def) / real(k_h, r_def) + end do + end if + end if + + ! The same for vertical positional arrays + do i = 1, k_v + 2 + x1v(i) = real(i - 1, r_def) / real(k_v + 1, r_def) end do - if ( k == 0 ) then - x2(1) = 0.5_r_def + if (k_v == 0) then + x2v(1) = 0.5_r_def else - if ( gungho_fs == W3 .or. gungho_fs == Wtheta ) then + if (gungho_fs == W3 .or. gungho_fs == Wtheta) then ! Evenly space the points away from the element edges for high order ! spaces - this helps with visualising the output - do i=1,k+1 - x2(i) = real(i,r_def)/real(k+2,r_def) + do i = 1, k_v + 1 + x2v(i) = real(i, r_def) / real(k_v + 2, r_def) end do else - do i=1,k+1 - x2(i) = real(i-1,r_def)/real(k,r_def) + do i = 1, k_v + 1 + x2v(i) = real(i - 1, r_def) / real(k_v, r_def) end do end if end if - if ( k == 0 ) x2(1) = 0.5_r_def ! This value isn't needed and is always multipled by 0 - x2(k+2) = 0.0_r_def + x2h(k_h + 2) = 0.0_r_def + x2v(k_v + 2) = 0.0_r_def - ! Some look arrays based upon reference cube topology - ! index of nodal points for dofs located on faces. - ! Faces are defined as having one coodinate fixed, + ! Some look arrays based upon reference cube topology: + + ! Index of nodal points for dofs located on faces. + ! Faces are defined as having one coordinate fixed, ! i.e. for face 1 x = 0 for all points on the face - ! and for face 4 y = 1 for all points on the face + ! and for face 4 y = 1 for all points on the face. ! This array give the index for the fixed coordinate for each face. ! If a face has fixed coordinate = 0 the index is 1 ! If a face has fixed coordinate = 1 the index is k+2 - face_idx = (/ 1, 1, k+2, k+2, 1, k+2 /) + face_idx = (/ 1, 1, k_h + 2, k_h + 2, 1, k_v + 2 /) - ! index of nodal points for dofs located on edges - ! edges are defined as having two coodinates fixed, - ! i.e. for edge 1 x = 0 & z = 0 for all points on the edge - ! and for edge 6 x = 1 y = 0 for all points on the edge + ! Index of nodal points for dofs located on edges. + ! Edges are defined as having two coordinates fixed, + ! i.e. for edge 1 x = 0 & z = 0 for all points on the edge, + ! and for edge 6 x = 1 y = 0 for all points on the edge. ! These arrays give the index for the two fixed coordinates for each edge. ! If an edge has fixed coordinate = 0 the index is 1 ! If an edge has fixed coordinate = 1 the index is k+2 - edge_idx(:,1) = (/ 1, 1, k+2, k+2, 1, k+2, k+2, 1, 1, 1, k+2, k+2 /) - edge_idx(:,2) = (/ 1, 1, 1, 1, 1, 1, k+2, k+2, k+2, k+2, k+2, k+2 /) + ! The fixed coordinates are stored in order x, y, z so if the fixed + ! coordinates are x and z then edge_idx(:, 1) stores x and edge_idx(:, 1) + ! stores z, and for other combinations they remain in this order. + edge_idx(:, 1) = & + (/ 1, 1, k_h + 2, k_h + 2, 1, k_h + 2, k_h + 2, 1, 1, 1, k_h + 2, k_h + 2 /) + edge_idx(:, 2) = & + (/ 1, 1, 1, 1, 1, 1, k_h + 2, k_h + 2, k_v + 2, k_v + 2, k_v + 2, k_v + 2 /) ! Each dof living on a face or edge will have its index defined by three ! integers (j1, j2, j3) where: - ! for faces one j will be the face index and the other two can vary - ! for edges two j's will be the edge indices and the final one can vary - ! These j's need to be converted to the indices lx ,ly, lz + ! -for faces, one j will be the face index and the other two can vary. + ! -for edges, two j's will be the edge indices and the final one can vary. + ! These j's need to be converted to the indices lx ,ly, lz. ! For faces the first value of j2l is the l that corresponds to the - ! constant coordinate, so for face 1 lx = j3, ly = j2 and lz = j1/ - ! for edge 1: lx = j2, ly = j1, and lz = j3 + ! constant coordinate, so for face 1: lx = j3, ly = j2 and lz = j1; for + ! edge 1: lx = j2, ly = j1, and lz = j3. j2l_face(1,:) = (/ 3, 2, 1 /) j2l_face(2,:) = (/ 2, 3, 1 /) j2l_face(3,:) = (/ 3, 2, 1 /) @@ -630,15 +742,15 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & j2l_face(5,:) = (/ 1, 2, 3 /) j2l_face(6,:) = (/ 1, 2, 3 /) - j2l_edge(1 ,:) = (/ 2, 1, 3 /) - j2l_edge(2 ,:) = (/ 1, 2, 3 /) - j2l_edge(3 ,:) = (/ 2, 1, 3 /) - j2l_edge(4 ,:) = (/ 1, 2, 3 /) - j2l_edge(5 ,:) = (/ 2, 3, 1 /) - j2l_edge(6 ,:) = (/ 2, 3, 1 /) - j2l_edge(7 ,:) = (/ 2, 3, 1 /) - j2l_edge(8 ,:) = (/ 2, 3, 1 /) - j2l_edge(9 ,:) = (/ 2, 1, 3 /) + j2l_edge(1,:) = (/ 2, 1, 3 /) + j2l_edge(2,:) = (/ 1, 2, 3 /) + j2l_edge(3,:) = (/ 2, 1, 3 /) + j2l_edge(4,:) = (/ 1, 2, 3 /) + j2l_edge(5,:) = (/ 2, 3, 1 /) + j2l_edge(6,:) = (/ 2, 3, 1 /) + j2l_edge(7,:) = (/ 2, 3, 1 /) + j2l_edge(8,:) = (/ 2, 3, 1 /) + j2l_edge(9,:) = (/ 2, 1, 3 /) j2l_edge(10,:) = (/ 1, 2, 3 /) j2l_edge(11,:) = (/ 2, 1, 3 /) j2l_edge(12,:) = (/ 1, 2, 3 /) @@ -650,18 +762,16 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! Allocate arrays to allow on the fly evaluation of basis functions select case (gungho_fs) - case (W1, W2, W2H, W2V, W2broken, W2trace, W2Vtrace, W2Htrace) + case (W1, W2, W2H, W2V, W2broken, W2Hbroken, W2trace, W2Vtrace, W2Htrace) allocate( unit_vec(3, ndof_cell) ) end select - select case (gungho_fs) case (W0) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of CG spaces - !--------------------------------------------------------------------------- - poly_order = k+1 + !------------------------------------------------------------------------- ! Compute indices of functions idx = 1 @@ -669,9 +779,9 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! =============================== ! dofs in volume ! =============================== - do jz=2, k+1 - do jy=2, k+1 - do jx=2, k+1 + do jz = 2, k_v + 1 + do jy = 2, k_h + 1 + do jx = 2, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz @@ -685,15 +795,23 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! =============================== ! dofs on faces ! =============================== - do i=1, number_faces - do j1=2, k+1 - do j2=2, k+1 + do i = 1, number_faces + ! For horizontal face loop over vertical then horizontal orders + if (i <= number_faces_h) then + k_switch = k_v + ! For vertical face loop over horizontal order twice + else + k_switch = k_h + end if + + do j1 = 2, k_switch + 1 + do j2 = 2, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) ! Label face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -704,63 +822,70 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! =============================== ! dofs on edges ! =============================== - do i=1, number_edges - do j1=2, k+1 - j(1) = j1 - j(2) = edge_idx(i,1) - j(3) = edge_idx(i,2) - lx(idx) = j(j2l_edge(i,1)) - ly(idx) = j(j2l_edge(i,2)) - lz(idx) = j(j2l_edge(i,3)) + do i = 1, number_edges + ! If edge is horizontal loop to k_h+1 + if ((i <= number_2d_edges) .OR. & + (i > number_edges - number_2d_edges)) then + k_switch = k_h + ! If edge vertical loop to k_v+1 + else + k_switch = k_v + end if + + do j1 = 2, k_switch + 1 + j(1) = j1 + j(2) = edge_idx(i, 1) + j(3) = edge_idx(i, 2) + lx(idx) = j(j2l_edge(i, 1)) + ly(idx) = j(j2l_edge(i, 2)) + lz(idx) = j(j2l_edge(i, 3)) ! Label edge degrees of freedom entity_dofs(idx) = reference_element%get_edge_entity(i) - idx = idx + 1 + idx = idx + 1 end do end do ! =============================== ! dofs on vertices ! =============================== - do i=1, number_vertices - do j1=1, ndof_vert - coordinate = reference_element%get_vertex( i ) - lx(idx) = 1+(k+1)*int(coordinate(1)) - ly(idx) = 1+(k+1)*int(coordinate(2)) - lz(idx) = 1+(k+1)*int(coordinate(3)) + do i = 1, number_vertices + do j1 = 1, ndof_vert + coordinate = reference_element%get_vertex(i) + lx(idx) = 1 + (k_h + 1) * int(coordinate(1)) + ly(idx) = 1 + (k_h + 1) * int(coordinate(2)) + lz(idx) = 1 + (k_v + 1) * int(coordinate(3)) ! Label vertex degrees of freedom entity_dofs(idx) = reference_element%get_vertex_entity(i) - idx = idx + 1 + idx = idx + 1 end do end do - do i=1, ndof_cell - + do i = 1, ndof_cell ! Explicitly for quads, as ngp_h = ngp_v * ngp_v - nodal_coords(1,i) = x1(lx(i)) - nodal_coords(2,i) = x1(ly(i)) - nodal_coords(3,i) = x1(lz(i)) - - basis_order(:,i) = poly_order - basis_x(:,1,i) = x1 - basis_x(:,2,i) = x1 - basis_x(:,3,i) = x1 - + nodal_coords(1, i) = x1h(lx(i)) + nodal_coords(2, i) = x1h(ly(i)) + nodal_coords(3, i) = x1v(lz(i)) + + basis_order(1, i) = k_h + 1 + basis_order(2, i) = k_h + 1 + basis_order(3, i) = k_v + 1 + basis_x(:, 1, i) = x1h(:) + basis_x(:, 2, i) = x1h(:) + basis_z(:, i) = x1v(:) end do - basis_index(1,:) = lx(1:ndof_cell) - basis_index(2,:) = ly(1:ndof_cell) - basis_index(3,:) = lz(1:ndof_cell) - basis_vector(1,:) = 1.0_r_def + basis_index(1,:) = lx(1:ndof_cell) + basis_index(2,:) = ly(1:ndof_cell) + basis_index(3,:) = lz(1:ndof_cell) + basis_vector(1,:) = 1.0_r_def case (W1) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of Hcurl spaces - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- - poly_order = k+1 - - do idx=1, ndof_cell - do i=1, 3 + do idx = 1, ndof_cell + do i = 1, 3 unit_vec(i, idx) = 0.0_r_def end do end do @@ -770,13 +895,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs in volume ! u components - do jz=2, k+1 - do jy=2, k+1 - do jx=1, k+1 + do jz = 2, k_v + 1 + do jy = 2, k_h + 1 + do jx = 1, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_tangent_to_edge( S, unit_vec(:,idx) ) + call reference_element%get_tangent_to_edge(S, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -785,13 +910,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do ! v components - do jz=2, k+1 - do jy=1, k+1 - do jx=2, k+1 + do jz = 2, k_v + 1 + do jy = 1, k_h + 1 + do jx = 2, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_tangent_to_edge( W, unit_vec(:,idx) ) + call reference_element%get_tangent_to_edge(W, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -800,13 +925,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do ! w components - do jz=1, k+1 - do jy=2, k+1 - do jx=2, k+1 + do jz = 1, k_v + 1 + do jy = 2, k_h + 1 + do jx = 2, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_tangent_to_edge( B, unit_vec(:,idx) ) + call reference_element%get_tangent_to_edge(B, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -815,38 +940,48 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do ! dofs on faces - do i=1, number_faces - do j1=2, k+1 - do j2=1, k+1 + do i = 1, number_faces + ! For horizontal face loop over vertical then horizontal orders + if (i <= number_faces_h) then + k_switch = k_v + ! For vertical face loop over horizontal order twice + else + k_switch = k_h + end if + + ! Loop twice to account for two components per face (i.e. vertical + ! faces contain x and y components) + do j1 = 2, k_switch + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_edge_on_face( i, edges_on_face ) - call reference_element%get_tangent_to_edge( edges_on_face(1), & - unit_vec(:,idx) ) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_edge_on_face(i, edges_on_face) + call reference_element%get_tangent_to_edge(edges_on_face(1), & + unit_vec(:, idx)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 end do end do - do j1=1, k+1 - do j2=2, k+1 + do j1 = 1, k_switch + 1 + do j2 = 2, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_edge_on_face( i, edges_on_face ) - call reference_element%get_tangent_to_edge( edges_on_face(2), & - unit_vec(:,idx) ) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_edge_on_face(i, edges_on_face) + call reference_element%get_tangent_to_edge(edges_on_face(2), & + unit_vec(:, idx)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -855,50 +990,60 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do ! dofs on edges - do i=1, number_edges - do j1=1, k+1 + do i = 1, number_edges + ! If edge is horizontal loop to k_h+1 + if ((i <= number_2d_edges) .OR. & + (i > number_edges - number_2d_edges)) then + k_switch = k_h + ! If edge vertical loop to k_v+1 + else + k_switch = k_v + end if + + do j1 = 1, k_switch + 1 j(1) = j1 - j(2) = edge_idx(i,1) - j(3) = edge_idx(i,2) - lx(idx) = j(j2l_edge(i,1)) - ly(idx) = j(j2l_edge(i,2)) - lz(idx) = j(j2l_edge(i,3)) - call reference_element%get_tangent_to_edge( i, unit_vec(:,idx) ) - if (i <= number_horizontal_edges) dof_on_vert_boundary(idx,1) = 0 - if (i > number_edges - number_horizontal_edges) & - dof_on_vert_boundary(idx,2) = 0 + j(2) = edge_idx(i, 1) + j(3) = edge_idx(i, 2) + lx(idx) = j(j2l_edge(i, 1)) + ly(idx) = j(j2l_edge(i, 2)) + lz(idx) = j(j2l_edge(i, 3)) + call reference_element%get_tangent_to_edge(i, unit_vec(:, idx)) + if (i <= number_2d_edges) dof_on_vert_boundary(idx, 1) = 0 + if (i > number_edges - number_2d_edges) & + dof_on_vert_boundary(idx, 2) = 0 ! Label edge degrees of freedom entity_dofs(idx) = reference_element%get_edge_entity(i) idx = idx + 1 end do end do + do i = 1, ndof_cell - do i=1, ndof_cell - - nodal_coords(1,i) = abs(unit_vec(1,i))*x2(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x1(lx(i)) + nodal_coords(1, i) = abs(unit_vec(1, i)) * x2h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x1h(lx(i)) - nodal_coords(2,i) = abs(unit_vec(2,i))*x2(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x1(ly(i)) + nodal_coords(2, i) = abs(unit_vec(2, i)) * x2h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x1h(ly(i)) - nodal_coords(3,i) = abs(unit_vec(3,i))*x2(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x1(lz(i)) + nodal_coords(3, i) = abs(unit_vec(3, i)) * x2v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x1v(lz(i)) - basis_order(1,i) = poly_order - int(abs(unit_vec(1,i))) - basis_order(2,i) = poly_order - int(abs(unit_vec(2,i))) - basis_order(3,i) = poly_order - int(abs(unit_vec(3,i))) + basis_order(1, i) = (k_h + 1) - int(abs(unit_vec(1, i))) + basis_order(2, i) = (k_h + 1) - int(abs(unit_vec(2, i))) + basis_order(3, i) = (k_v + 1) - int(abs(unit_vec(3, i))) - basis_x(:,1,i) = abs(unit_vec(1,i))*x2(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x1(:) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x2h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x1h(:) - basis_x(:,2,i) = abs(unit_vec(2,i))*x2(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x1(:) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x2h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x1h(:) - basis_x(:,3,i) = abs(unit_vec(3,i))*x2(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x1(:) + basis_z(:, i) = abs(unit_vec(3, i)) * x2v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x1v(:) - basis_vector(:,i) = unit_vec(:,i) + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do end do @@ -906,31 +1051,27 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & basis_index(2,:) = ly(1:ndof_cell) basis_index(3,:) = lz(1:ndof_cell) - - case(W2, W2broken) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of Hdiv/discontinuous Hdiv spaces - !--------------------------------------------------------------------------- - - poly_order = k + 1 + !------------------------------------------------------------------------- - do idx=1, ndof_cell - do i=1, 3 - unit_vec(i,idx) = 0.0_r_def + do idx = 1, ndof_cell + do i = 1, 3 + unit_vec(i, idx) = 0.0_r_def end do end do idx = 1 ! dofs in volume ! u components - do jz=1, k+1 - do jy=1, k+1 - do jx=2,k+1 + do jz = 1, k_v + 1 + do jy = 1, k_h + 1 + do jx = 2, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_normal_to_face( W, unit_vec(:,idx) ) + call reference_element%get_normal_to_face(W, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -938,13 +1079,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do ! v components - do jz=1, k+1 - do jy=2, k+1 - do jx=1,k+1 + do jz = 1, k_v + 1 + do jy = 2, k_h + 1 + do jx = 1, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_normal_to_face( S, unit_vec(:,idx) ) + call reference_element%get_normal_to_face(S, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -952,13 +1093,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do ! w components - do jz=2, k+1 - do jy=1, k+1 - do jx=1,k+1 + do jz = 2, k_v + 1 + do jy = 1, k_h + 1 + do jx = 1, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz - call reference_element%get_normal_to_face( B, unit_vec(:,idx) ) + call reference_element%get_normal_to_face(B, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -967,18 +1108,26 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do ! dofs on faces - do i=1, number_faces - do j1=1, k+1 - do j2=1, k+1 + do i = 1, number_faces + ! For horizontal face loop over vertical then horizontal orders + if (i <= number_faces_h) then + k_switch = k_v + ! For vertical face loop over horizontal order twice + else + k_switch = k_h + end if + + do j1 = 1, k_switch + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_normal_to_face( i, unit_vec(:,idx) ) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces ) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_normal_to_face(i, unit_vec(:, idx)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -986,31 +1135,38 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do - do i=1, ndof_cell + do i = 1, ndof_cell + + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) - nodal_coords(1,i) = abs(unit_vec(1,i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(lx(i)) + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) - nodal_coords(2,i) = abs(unit_vec(2,i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(ly(i)) + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) - nodal_coords(3,i) = abs(unit_vec(3,i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(lz(i)) + basis_order(1, i) = (k_h + 1) & + - int(1.0_r_def - abs(unit_vec(1, i)), i_def) - basis_order(1,i) = poly_order - int(1.0_r_def - abs(unit_vec(1,i)), i_def) - basis_order(2,i) = poly_order - int(1.0_r_def - abs(unit_vec(2,i)), i_def) - basis_order(3,i) = poly_order - int(1.0_r_def - abs(unit_vec(3,i)), i_def) + basis_order(2, i) = (k_h + 1) & + - int(1.0_r_def - abs(unit_vec(2, i)), i_def) - basis_x(:,1,i) = abs(unit_vec(1,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(:) + basis_order(3, i) = (k_v + 1) & + - int(1.0_r_def - abs(unit_vec(3, i)), i_def) - basis_x(:,2,i) = abs(unit_vec(2,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(:) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_x(:,3,i) = abs(unit_vec(3,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(:) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) - basis_vector(:,i) = unit_vec(:,i) + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(:) + + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do end do @@ -1018,13 +1174,10 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & basis_index(2,:) = ly(1:ndof_cell) basis_index(3,:) = lz(1:ndof_cell) - - case(W2trace) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of Hdiv trace spaces - !--------------------------------------------------------------------------- - poly_order = k + !------------------------------------------------------------------------- ! Compute indices of functions idx = 1 @@ -1033,8 +1186,16 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs on faces ! =============================== do i = 1, number_faces - do j1 = 1, k + 1 - do j2 = 1, k + 1 + ! For horizontal face loop over vertical then horizontal orders + if (i <= number_faces_h) then + k_switch = k_v + ! For vertical face loop over horizontal order twice + else + k_switch = k_h + end if + + do j1 = 1, k_switch + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) @@ -1043,7 +1204,8 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & lz(idx) = j(j2l_face(i, 3)) ! Gather normals corresponding to each face - call reference_element%get_outward_normal_to_face( i, unit_vec(:,idx) ) + call reference_element%get_outward_normal_to_face(i, & + unit_vec(:, idx)) ! Label face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1052,48 +1214,54 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do do i = 1, ndof_cell - nodal_coords(1, i) = abs(unit_vec(1, i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1, i)))*x2(lx(i)) - nodal_coords(2, i) = abs(unit_vec(2, i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2, i)))*x2(ly(i)) - nodal_coords(3, i) = abs(unit_vec(3, i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3, i)))*x2(lz(i)) - - basis_order(1, i) = poly_order*int(1.0_r_def - abs(unit_vec(1, i)), i_def) & + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) + + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) + + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) + + basis_order(1, i) = k_h * int(1.0_r_def & + - abs(unit_vec(1, i)), i_def) & + int(abs(unit_vec(1, i)), i_def) - basis_order(2, i) = poly_order*int(1.0_r_def - abs(unit_vec(2, i)), i_def) & + + basis_order(2, i) = k_h * int(1.0_r_def & + - abs(unit_vec(2, i)), i_def) & + int(abs(unit_vec(2, i)), i_def) - basis_order(3, i) = poly_order*int(1.0_r_def - abs(unit_vec(3, i)), i_def) & + + basis_order(3, i) = k_v * int(1.0_r_def & + - abs(unit_vec(3, i)), i_def) & + int(abs(unit_vec(3, i)), i_def) - basis_x(:, 1, i) = abs(unit_vec(1, i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1, i)))*x2(:) - basis_x(:, 2, i) = abs(unit_vec(2, i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2, i)))*x2(:) - basis_x(:, 3, i) = abs(unit_vec(3, i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3, i)))*x2(:) - end do + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_index(1, :) = lx(1:ndof_cell) - basis_index(2, :) = ly(1:ndof_cell) - basis_index(3, :) = lz(1:ndof_cell) - basis_vector(:, :) = 1.0_r_def + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(:) + end do + basis_index(1,:) = lx(1:ndof_cell) + basis_index(2,:) = ly(1:ndof_cell) + basis_index(3,:) = lz(1:ndof_cell) + basis_vector(:,:) = 1.0_r_def case(W3) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of DG spaces - !--------------------------------------------------------------------------- - poly_order = k + !------------------------------------------------------------------------- ! compute indices of functions idx = 1 ! dofs in volume - do jz=1, k+1 - do jy=1,k+1 - do jx=1,k+1 + do jz = 1, k_v + 1 + do jy = 1, k_h + 1 + do jx = 1, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz @@ -1104,38 +1272,37 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do - do i=1, ndof_cell - nodal_coords(1,i) = x2(lx(i)) - nodal_coords(2,i) = x2(ly(i)) - nodal_coords(3,i) = x2(lz(i)) - basis_x(:,1,i) = x2 - basis_x(:,2,i) = x2 - basis_x(:,3,i) = x2 + do i = 1, ndof_cell + nodal_coords(1, i) = x2h(lx(i)) + nodal_coords(2, i) = x2h(ly(i)) + nodal_coords(3, i) = x2v(lz(i)) + basis_x(:, 1, i) = x2h(:) + basis_x(:, 2, i) = x2h(:) + basis_z(:, i) = x2v(:) end do - basis_index(1,:) = lx(1:ndof_cell) - basis_index(2,:) = ly(1:ndof_cell) - basis_index(3,:) = lz(1:ndof_cell) + basis_index(1,:) = lx(1:ndof_cell) + basis_index(2,:) = ly(1:ndof_cell) + basis_index(3,:) = lz(1:ndof_cell) basis_vector(1,:) = 1.0_r_def - basis_order(:,:) = poly_order - - + basis_order(1,:) = k_h + basis_order(2,:) = k_h + basis_order(3,:) = k_v case (WTHETA) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of theta spaces - !--------------------------------------------------------------------------- - poly_order = k + 1 + !------------------------------------------------------------------------- idx = 1 ! dofs in volume - (w only) ! w components - do jz=2, k+1 - do jy=1, k+1 - do jx=1, k+1 - lx(idx) = jx - ly(idx) = jy - lz(idx) = jz + do jz = 2, k_v + 1 + do jy = 1, k_h + 1 + do jx = 1, k_h + 1 + lx(idx) = jx + ly(idx) = jy + lz(idx) = jz ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -1146,16 +1313,17 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs on faces do i = number_faces - 1, number_faces - do j1=1, k+1 - do j2=1, k+1 + ! Loop on faces dependent on k_h only + do j1 = 1, k_h + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label top and bottom face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1163,35 +1331,32 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do - do i=1, ndof_cell - nodal_coords(1,i)= x2(lx(i)) - nodal_coords(2,i)= x2(ly(i)) - nodal_coords(3,i)= x1(lz(i)) + do i = 1, ndof_cell + nodal_coords(1, i) = x2h(lx(i)) + nodal_coords(2, i) = x2h(ly(i)) + nodal_coords(3, i) = x1v(lz(i)) - basis_order(1,i) = poly_order - 1 - basis_order(2,i) = poly_order - 1 - basis_order(3,i) = poly_order + basis_order(1, i) = k_h + basis_order(2, i) = k_h + basis_order(3, i) = k_v + 1 - basis_x(:,1,i) = x2(:) - basis_x(:,2,i) = x2(:) - basis_x(:,3,i) = x1(:) + basis_x(:, 1, i) = x2h(:) + basis_x(:, 2, i) = x2h(:) + basis_z(:, i) = x1v(:) end do - basis_index(1,:) = lx(1:ndof_cell) - basis_index(2,:) = ly(1:ndof_cell) - basis_index(3,:) = lz(1:ndof_cell) + basis_index(1,:) = lx(1:ndof_cell) + basis_index(2,:) = ly(1:ndof_cell) + basis_index(3,:) = lz(1:ndof_cell) basis_vector(:,:) = 1.0_r_def - - case (W2V) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of W2V space - !--------------------------------------------------------------------------- - poly_order = k + 1 + !------------------------------------------------------------------------- - do idx=1, ndof_cell - do i=1, 3 + do idx = 1, ndof_cell + do i = 1, 3 unit_vec(i, idx) = 0.0_r_def end do end do @@ -1199,13 +1364,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & idx = 1 ! dofs in volume - (w only) ! w components - do jz=2, k+1 - do jy=1, k+1 - do jx=1, k+1 - lx(idx) = jx - ly(idx) = jy - lz(idx) = jz - call reference_element%get_normal_to_face( B, unit_vec(:,idx) ) + do jz = 2, k_v + 1 + do jy = 1, k_h + 1 + do jx = 1, k_h + 1 + lx(idx) = jx + ly(idx) = jy + lz(idx) = jz + call reference_element%get_normal_to_face(B, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -1216,17 +1381,18 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs on faces do i = number_faces - 1, number_faces - do j1=1, k+1 - do j2=1, k+1 + ! Loop on faces dependent on k_h only + do j1 = 1, k_h + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_normal_to_face( i, unit_vec(:,idx) ) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_normal_to_face(i, unit_vec(:, idx)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label top and bottom face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1234,31 +1400,38 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do - do i=1, ndof_cell + do i = 1, ndof_cell - nodal_coords(1,i) = abs(unit_vec(1,i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(lx(i)) + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) - nodal_coords(2,i) = abs(unit_vec(2,i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(ly(i)) + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) - nodal_coords(3,i) = abs(unit_vec(3,i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(lz(i)) + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) - basis_order(1,i) = poly_order - int(1.0_r_def - abs(unit_vec(1,i)), i_def) - basis_order(2,i) = poly_order - int(1.0_r_def - abs(unit_vec(2,i)), i_def) - basis_order(3,i) = poly_order - int(1.0_r_def - abs(unit_vec(3,i)), i_def) + basis_order(1, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(1, i)), i_def) - basis_x(:,1,i) = abs(unit_vec(1,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(:) + basis_order(2, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(2, i)), i_def) - basis_x(:,2,i) = abs(unit_vec(2,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(:) + basis_order(3, i) = (k_v + 1) - int(1.0_r_def & + - abs(unit_vec(3, i)), i_def) - basis_x(:,3,i) = abs(unit_vec(3,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(:) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_vector(:,i) = unit_vec(:,i) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) + + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(:) + + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do end do @@ -1267,10 +1440,9 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & basis_index(3,:) = lz(1:ndof_cell) case (W2Vtrace) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of W2Vtrace space - !--------------------------------------------------------------------------- - poly_order = k + 1 + !------------------------------------------------------------------------- do idx = 1, ndof_cell do i = 1, 3 @@ -1281,17 +1453,18 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & idx = 1 ! dofs on faces do i = number_faces - 1, number_faces - do j1 = 1, k+1 - do j2 = 1, k+1 + ! Loop on faces dependent on k_h only + do j1 = 1, k_h + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_normal_to_face( i, unit_vec(:,idx) ) - if (i == number_faces - 1) dof_on_vert_boundary(idx,1) = 0 - if (i == number_faces) dof_on_vert_boundary(idx,2) = 0 + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_normal_to_face(i, unit_vec(:, idx)) + if (i == number_faces - 1) dof_on_vert_boundary(idx, 1) = 0 + if (i == number_faces) dof_on_vert_boundary(idx, 2) = 0 ! Label top and bottom face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1301,29 +1474,36 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & do i = 1, ndof_cell - nodal_coords(1,i) = abs(unit_vec(1,i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(lx(i)) + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) - nodal_coords(2,i) = abs(unit_vec(2,i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(ly(i)) + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) - nodal_coords(3,i) = abs(unit_vec(3,i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(lz(i)) + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) - basis_order(1,i) = poly_order - int(1.0_r_def - abs(unit_vec(1,i)), i_def) - basis_order(2,i) = poly_order - int(1.0_r_def - abs(unit_vec(2,i)), i_def) - basis_order(3,i) = poly_order - int(1.0_r_def - abs(unit_vec(3,i)), i_def) + basis_order(1, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(1, i)), i_def) - basis_x(:,1,i) = abs(unit_vec(1,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(:) + basis_order(2, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(2, i)), i_def) - basis_x(:,2,i) = abs(unit_vec(2,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(:) + basis_order(3, i) = (k_v + 1) - int(1.0_r_def & + - abs(unit_vec(3, i)), i_def) - basis_x(:,3,i) = abs(unit_vec(3,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(:) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_vector(:,i) = unit_vec(:,i) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) + + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(:) + + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do end do @@ -1331,16 +1511,14 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & basis_index(2,:) = ly(1:ndof_cell) basis_index(3,:) = lz(1:ndof_cell) - - case (W2H) - !--------------------------------------------------------------------------- + case (W2H, W2Hbroken) + !------------------------------------------------------------------------- ! Section for test/trial functions of W2H space - !--------------------------------------------------------------------------- - poly_order = k + 1 + !------------------------------------------------------------------------- - do idx=1, ndof_cell - do i=1, 3 - unit_vec(i,idx) = 0.0_r_def + do idx = 1, ndof_cell + do i = 1, 3 + unit_vec(i, idx) = 0.0_r_def end do end do @@ -1350,13 +1528,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs in volume - (u and v only) !============================================ ! u components - do jz=1,k+1 - do jy=1,k+1 - do jx=2,k+1 - lx(idx) = jx - ly(idx) = jy - lz(idx) = jz - call reference_element%get_normal_to_face( W, unit_vec(:,idx) ) + do jz = 1, k_v + 1 + do jy = 1, k_h + 1 + do jx = 2, k_h + 1 + lx(idx) = jx + ly(idx) = jy + lz(idx) = jz + call reference_element%get_normal_to_face(W, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -1364,13 +1542,13 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do ! v components - do jz=1,k+1 - do jy=2,k+1 - do jx=1,k+1 - lx(idx) = jx - ly(idx) = jy - lz(idx) = jz - call reference_element%get_normal_to_face( S, unit_vec(:,idx) ) + do jz = 1, k_v + 1 + do jy = 2, k_h + 1 + do jx = 1, k_h + 1 + lx(idx) = jx + ly(idx) = jy + lz(idx) = jz + call reference_element%get_normal_to_face(S, unit_vec(:, idx)) ! Label volume degrees of freedom entity_dofs(idx) = V idx = idx + 1 @@ -1381,16 +1559,17 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & !============================================ ! dofs on faces !============================================ - do i=1, number_faces - 2 - do j1=1, k+1 - do j2=1, k+1 + do i = 1, number_faces - 2 + ! No vertical faces considered so one horizontal and one vertical loop + do j1 = 1, k_v + 1 + do j2 = 1, k_h + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_normal_to_face( i, unit_vec(:,idx) ) + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_normal_to_face(i, unit_vec(:, idx)) ! Label horizontal face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1398,46 +1577,52 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do + do i = 1, ndof_cell + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) + + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) + + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) - do i=1, ndof_cell - nodal_coords(1,i) = abs(unit_vec(1,i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(lx(i)) + basis_order(1, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(1, i)), i_def) - nodal_coords(2,i) = abs(unit_vec(2,i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(ly(i)) + basis_order(2, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(2, i)), i_def) - nodal_coords(3,i) = abs(unit_vec(3,i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(lz(i)) + basis_order(3, i) = (k_v + 1) - int(1.0_r_def & + - abs(unit_vec(3, i)), i_def) - basis_order(1,i) = poly_order - int(1.0_r_def - abs(unit_vec(1,i)), i_def) - basis_order(2,i) = poly_order - int(1.0_r_def - abs(unit_vec(2,i)), i_def) - basis_order(3,i) = poly_order - int(1.0_r_def - abs(unit_vec(3,i)), i_def) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_x(:,1,i) = abs(unit_vec(1,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(:) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) - basis_x(:,2,i) = abs(unit_vec(2,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(:) - basis_x(:,3,i) = abs(unit_vec(3,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(:) + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec( 3, i))) * x2v(: ) + + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do - basis_vector(:,i) = unit_vec(:,i) end do basis_index(1,:) = lx(1:ndof_cell) basis_index(2,:) = ly(1:ndof_cell) basis_index(3,:) = lz(1:ndof_cell) - case (W2Htrace) - !--------------------------------------------------------------------------- + !------------------------------------------------------------------------- ! Section for test/trial functions of W2Htrace space - !--------------------------------------------------------------------------- - poly_order = k + 1 + !------------------------------------------------------------------------- do idx = 1, ndof_cell do i = 1, 3 - unit_vec(i,idx) = 0.0_r_def + unit_vec(i, idx) = 0.0_r_def end do end do @@ -1446,15 +1631,16 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & ! dofs on faces !============================================ do i = 1, number_faces - 2 - do j1 = 1, k+1 - do j2 = 1, k+1 + ! No vertical faces considered so one horizontal and one vertical loop + do j1 = 1, k_h + 1 + do j2 = 1, k_v + 1 j(1) = j1 j(2) = j2 j(3) = face_idx(i) - lx(idx) = j(j2l_face(i,1)) - ly(idx) = j(j2l_face(i,2)) - lz(idx) = j(j2l_face(i,3)) - call reference_element%get_normal_to_face( i, unit_vec(:,idx) ) + lx(idx) = j(j2l_face(i, 1)) + ly(idx) = j(j2l_face(i, 2)) + lz(idx) = j(j2l_face(i, 3)) + call reference_element%get_normal_to_face(i, unit_vec(:, idx)) ! Label horizontal face degrees of freedom entity_dofs(idx) = reference_element%get_face_entity(i) idx = idx + 1 @@ -1463,47 +1649,55 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do do i = 1, ndof_cell - nodal_coords(1,i) = abs(unit_vec(1,i))*x1(lx(i)) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(lx(i)) + nodal_coords(1, i) = abs(unit_vec(1, i)) * x1h(lx(i)) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(lx(i)) + + nodal_coords(2, i) = abs(unit_vec(2, i)) * x1h(ly(i)) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(ly(i)) + + nodal_coords(3, i) = abs(unit_vec(3, i)) * x1v(lz(i)) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(lz(i)) - nodal_coords(2,i) = abs(unit_vec(2,i))*x1(ly(i)) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(ly(i)) + basis_order(1, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(1, i)), i_def) - nodal_coords(3,i) = abs(unit_vec(3,i))*x1(lz(i)) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(lz(i)) + basis_order(2, i) = (k_h + 1) - int(1.0_r_def & + - abs(unit_vec(2, i)), i_def) - basis_order(1,i) = poly_order - int(1.0_r_def - abs(unit_vec(1,i)), i_def) - basis_order(2,i) = poly_order - int(1.0_r_def - abs(unit_vec(2,i)), i_def) - basis_order(3,i) = poly_order - int(1.0_r_def - abs(unit_vec(3,i)), i_def) + basis_order(3, i) = (k_v + 1) - int(1.0_r_def & + - abs(unit_vec(3, i)), i_def) - basis_x(:,1,i) = abs(unit_vec(1,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(1,i)))*x2(:) + basis_x(:, 1, i) = abs(unit_vec(1, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(1, i))) * x2h(:) - basis_x(:,2,i) = abs(unit_vec(2,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(2,i)))*x2(:) - basis_x(:,3,i) = abs(unit_vec(3,i))*x1(:) & - + (1.0_r_def - abs(unit_vec(3,i)))*x2(:) + basis_x(:, 2, i) = abs(unit_vec(2, i)) * x1h(:) & + + (1.0_r_def - abs(unit_vec(2, i))) * x2h(:) + + basis_z(:, i) = abs(unit_vec(3, i)) * x1v(:) & + + (1.0_r_def - abs(unit_vec(3, i))) * x2v(:) + + do j1 = 1, size(basis_vector, 1) + basis_vector(j1, i) = unit_vec(j1, i) + end do - basis_vector(:,i) = unit_vec(:,i) end do basis_index(1,:) = lx(1:ndof_cell) basis_index(2,:) = ly(1:ndof_cell) basis_index(3,:) = lz(1:ndof_cell) - case(WCHI) - !--------------------------------------------------------------------------- + case(WCHI) + !------------------------------------------------------------------------- ! Section for test/trial functions of DG spaces - !--------------------------------------------------------------------------- - poly_order = k + !------------------------------------------------------------------------- ! compute indices of functions idx = 1 ! dofs in volume - do jz=1, k+1 - do jy=1,k+1 - do jx=1,k+1 + do jz = 1, k_v + 1 + do jy = 1, k_h + 1 + do jx = 1, k_h + 1 lx(idx) = jx ly(idx) = jy lz(idx) = jz @@ -1514,35 +1708,36 @@ subroutine basis_setup( element_order, gungho_fs, ndof_vert, ndof_cell, & end do end do - do i=1, ndof_cell - nodal_coords(1,i) = x2(lx(i)) - nodal_coords(2,i) = x2(ly(i)) - nodal_coords(3,i) = x2(lz(i)) - basis_x(:,1,i) = x2 - basis_x(:,2,i) = x2 - basis_x(:,3,i) = x2 + do i = 1, ndof_cell + nodal_coords(1, i) = x2h(lx(i)) + nodal_coords(2, i) = x2h(ly(i)) + nodal_coords(3, i) = x2v(lz(i)) + basis_x(:, 1, i) = x2h(:) + basis_x(:, 2, i) = x2h(:) + basis_z(:, i) = x2v(:) end do - basis_index(1,:) = lx(1:ndof_cell) - basis_index(2,:) = ly(1:ndof_cell) - basis_index(3,:) = lz(1:ndof_cell) + basis_index(1,:) = lx(1:ndof_cell) + basis_index(2,:) = ly(1:ndof_cell) + basis_index(3,:) = lz(1:ndof_cell) basis_vector(1,:) = 1.0_r_def - basis_order(:,:) = poly_order + basis_order(1,:) = k_h + basis_order(2,:) = k_h + basis_order(3,:) = k_v end select - deallocate( lx ) - deallocate( ly ) - deallocate( lz ) + deallocate(lx) + deallocate(ly) + deallocate(lz) ! Allocate arrays to allow on the fly evaluation of basis functions select case (gungho_fs) - case (W1, W2, W2H, W2V, W2broken, W2trace, W2Vtrace, W2Htrace) - deallocate( unit_vec ) + case (W1, W2, W2H, W2V, W2broken, W2Hbroken, W2trace, W2Vtrace, W2Htrace) + deallocate(unit_vec) end select - return end subroutine basis_setup !----------------------------------------------------------------------------- @@ -1555,13 +1750,20 @@ end subroutine basis_setup !> !> @param[in] mesh Mesh to define the function space on. !> @param[in] gungho_fs Enumeration of the function space. - !> @param[in] element_order Polynomial order of the function space. + !> @param[in] element_order_h Polynomial order of the function space in + !> horizontal direction. + !> @param[in] element_order_v Polynomial order of the function space in + !> vertical direction. !> @param[in] ndata The number of data values to be held !> at each dof location + !> @param[in] ndata_first Flag for ndata or nlayer first data + !> layout !> @param[in] ncells_2d_with_ghost Number of 2d cells with ghost cells. !> @param[in] ndof_vert Number of dofs on vertices. - !> @param[in] ndof_edge Number of dofs on edges. - !> @param[in] ndof_face Number of dofs on faces. + !> @param[in] ndof_edge_h Number of dofs on horizontal edges. + !> @param[in] ndof_edge_v Number of dofs on vertical edges. + !> @param[in] ndof_face_h Number of dofs on horizontal faces. + !> @param[in] ndof_face_v Number of dofs on vertical faces. !> @param[in] ndof_vol Number of dofs in volumes. !> @param[in] ndof_cell Number of dofs associated with a cell. !> @param[out] last_dof_owned Index of last owned dof for the @@ -1579,50 +1781,82 @@ end subroutine basis_setup !> horizontal domain !> @param[out] global_vert_dof_id_2d Global id of vertex dofs on the 2D !> horizontal domain - !> - subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & - ncells_2d_with_ghost, & - ndof_vert, ndof_edge, ndof_face, & - ndof_vol, ndof_cell, last_dof_owned, & - last_dof_annexed, last_dof_halo, dofmap, & - global_dof_id, & - global_cell_dof_id_2d, & - global_edge_dof_id_2d, & - global_vert_dof_id_2d ) + ! + ! .+---B--+ In the following an edge is called vertical if it is + ! .' | .'| normal to the horizontal plane (such as edge A), and + ! +---+--+' A horizontal if it is parallel to it (such as edge B). + ! | P | | | + ! | ,+--+---+ A face will be called horizontal if it is normal to + ! |.' Q | .' the horizontal plane (such as face P) and vertical if it + ! +------+' is parallel to it (such as face Q). + ! + ! These are chosen to agree with the naming of W2H and + ! W2V. + + subroutine dofmap_setup( mesh, gungho_fs, element_order_h, element_order_v, & + ndata, ndata_first, ncells_2d_with_ghost, ndof_vert,& + ndof_edge_h, ndof_edge_v, ndof_face_h, ndof_face_v, & + ndof_vol, ndof_cell, last_dof_owned, & + last_dof_annexed, last_dof_halo, dofmap, & + global_dof_id, global_cell_dof_id_2d, & + global_edge_dof_id_2d, global_vert_dof_id_2d ) implicit none + ! Input type(mesh_type), intent(in), pointer :: mesh integer(i_def), intent(in) :: gungho_fs - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h + integer(i_def), intent(in) :: element_order_v integer(i_def), intent(in) :: ndata + + logical(l_def), intent(in) :: ndata_first + integer(i_def), intent(in) :: ncells_2d_with_ghost integer(i_def), intent(in) :: ndof_vert - integer(i_def), intent(in) :: ndof_edge - integer(i_def), intent(in) :: ndof_face + integer(i_def), intent(in) :: ndof_edge_h + integer(i_def), intent(in) :: ndof_edge_v + integer(i_def), intent(in) :: ndof_face_h + integer(i_def), intent(in) :: ndof_face_v integer(i_def), intent(in) :: ndof_vol integer(i_def), intent(in) :: ndof_cell + + ! Output integer(i_def), intent(out) :: last_dof_owned integer(i_def), intent(out) :: last_dof_annexed - integer(i_def), intent(out) :: last_dof_halo(:) - integer(i_def), intent(out) :: dofmap(ndof_cell,0:ncells_2d_with_ghost) + integer(i_def), intent(out) :: last_dof_halo(0:) + + integer(i_def), intent(out) :: dofmap(ndof_cell, 0:ncells_2d_with_ghost) integer(i_halo_index), intent(out) :: global_dof_id(:) - integer(i_def), intent(out) :: global_cell_dof_id_2d(:) - integer(i_def), intent(out) :: global_edge_dof_id_2d(:) - integer(i_def), intent(out) :: global_vert_dof_id_2d(:) + + integer(i_def), intent(out) :: global_cell_dof_id_2d(:) + integer(i_def), intent(out) :: global_edge_dof_id_2d(:) + integer(i_def), intent(out) :: global_vert_dof_id_2d(:) + + ! Local variables class(reference_element_type), pointer :: reference_element => null() - integer(i_def) :: number_horizontal_faces, & - number_horizontal_edges, & - number_horizontal_vertices - integer(i_def) :: number_faces, number_edges, number_vertices + integer(i_def) :: number_faces ! Number of faces per cell + integer(i_def) :: number_edges ! Number of edges per cell + integer(i_def) :: number_vertices ! Number of vertices per cell - integer(i_def) :: ncells + integer(i_def) :: number_horizontal_faces ! Number of horizontal faces per + ! cell + integer(i_def) :: number_horizontal_edges ! Number of horizontal edges per + ! cell + integer(i_def) :: number_2d_vertices ! Number of vertices of 2d cell + ! entity + + + integer(i_def) :: ncells ! Number of cells in the rank (including ghosts) ! Loop counters integer(i_def) :: icell, iface, iedge, ivert, idof, idepth, k, m + ! Loop upper bound for ndof loops on vertical or horizontal edges + integer(i_def) :: ndof_stop + ! Number of layers integer(i_def) :: nlayers @@ -1636,7 +1870,7 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & integer(i_def) :: nvert_layer, nedge_layer, nface_layer ! Start and end points of the cell indices to loop over - integer(i_def) :: start,finish + integer(i_def) :: start, finish ! Entity dofmaps integer(i_def), allocatable :: dofmap_d0(:,:), & @@ -1678,31 +1912,46 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & integer(i_halo_index) :: num_layers, num_dofs, num_ndata - !========================================================= + integer(i_def) :: ndata_offset + + !=========================================================================== reference_element => mesh%get_reference_element() - number_faces = reference_element%get_number_faces() - number_edges = reference_element%get_number_edges() - number_vertices = reference_element%get_number_vertices() - number_horizontal_faces = reference_element%get_number_horizontal_faces() - number_horizontal_edges = reference_element%get_number_2d_edges() - number_horizontal_vertices = reference_element%get_number_2d_vertices() + + number_faces = reference_element%get_number_faces() + number_edges = reference_element%get_number_edges() + number_vertices = reference_element%get_number_vertices() + + number_horizontal_faces = reference_element%get_number_horizontal_faces() + number_horizontal_edges = reference_element%get_number_2d_edges() + number_2d_vertices = reference_element%get_number_2d_vertices() ncells = ncells_2d_with_ghost + ! Offset for multidata fields with continuous vertical components + ! If ndata_first we need to add ndata to the dof value + ! => dof on top entity (face, edge, vert) = dof on bottom entity + ndata + ! If nlayer_first we need to add 1 to the dof value + ! => dof on top entity (face, edge, vert) = dof on bottom entity + 1 + if ( ndata_first ) then + ndata_offset = ndata + else + ndata_offset = 1 + end if + ! dofmaps for a 3D horizontal layer - nlayers = mesh % get_nlayers() - nvert_layer = 2 * mesh % get_nverts_2d() - nedge_layer = 2 * mesh % get_nedges_2d() & - + mesh % get_nverts_2d() - nface_layer = mesh % get_nedges_2d() & + nlayers = mesh%get_nlayers() + nvert_layer = 2 * mesh%get_nverts_2d() + nedge_layer = 2 * mesh%get_nedges_2d() & + + mesh%get_nverts_2d() + nface_layer = mesh%get_nedges_2d() & + 2 * ncells dofmap_size(:) = 1 - dofmap_size(0) = max( dofmap_size(0), ndof_vert ) - dofmap_size(1) = max( dofmap_size(1), ndof_edge ) - dofmap_size(2) = max( dofmap_size(2), ndof_face ) - dofmap_size(3) = max( dofmap_size(3), ndof_vol ) + dofmap_size(0) = max(dofmap_size(0), ndof_vert) + dofmap_size(1) = max(dofmap_size(1), ndof_edge_h, ndof_edge_v) + dofmap_size(2) = max(dofmap_size(2), ndof_face_h, ndof_face_v) + dofmap_size(3) = max(dofmap_size(3), ndof_vol) allocate( dof_column_height (ndof_cell, 0:ncells)) allocate( dof_cell_owner (ndof_cell, 0:ncells)) @@ -1752,13 +2001,12 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & dof_cell_owner_d3 (:,:) = 0 ! Sum the number of cells in all the inner halos - tot_num_inner=0 - do idepth=1,mesh%get_inner_depth() + tot_num_inner = 0 + do idepth = 1, mesh%get_inner_depth() tot_num_inner = tot_num_inner + & - mesh%get_num_cells_inner(idepth) + mesh%get_num_cells_inner(idepth) end do - ! Assume we have all possible global connectivity information ! in practice this requires connectivity ! (3,2) -> faces on cells @@ -1766,101 +2014,102 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! (3,0) -> vertices on cells id_owned = 1 - id_halo = -1 + id_halo = -1 ! loop over 3 entities (cells) starting with core + inner halos + edge ! + first depth halo then proceding with further halo depths as required - start=1 - finish=tot_num_inner + & - mesh%get_num_cells_edge() + & - mesh%get_num_cells_halo(1) + start = 1 + finish = tot_num_inner & + + mesh%get_num_cells_edge() & + + mesh%get_num_cells_halo(1) select case (gungho_fs) case(W0, W1, W2, W2broken, W2trace, W3, WCHI) select_entity => select_entity_all case(WTHETA) select_entity => select_entity_theta - case(W2H, W2Htrace) + case(W2H, W2Htrace, W2Hbroken) select_entity => select_entity_w2h case(W2V, W2Vtrace) select_entity => select_entity_w2v end select - halo_loop: do idepth = 1, mesh % get_halo_depth()+1 - cell_loop: do icell = start, finish + halo_loop : do idepth = 1, mesh%get_halo_depth() + 1 + cell_loop : do icell = start, finish ! Assign dofs for connectivity (3,3) (dofs in cell) !--------------------------------------------------------- - if (mesh % is_cell_owned(icell)) then - do idof=1, ndof_vol - dofmap_d3 (idof,icell) = id_owned - dof_column_height_d3 (idof,icell) = nlayers - dof_cell_owner_d3 (idof,icell) = icell + if (mesh%is_cell_owned(icell)) then + do idof = 1, ndof_vol + dofmap_d3 (idof, icell) = id_owned + dof_column_height_d3 (idof, icell) = nlayers + dof_cell_owner_d3 (idof, icell) = icell id_owned = id_owned + (ndata * nlayers) end do else - do idof=1, ndof_vol - dofmap_d3 (idof,icell) = id_halo - dof_column_height_d3 (idof,icell) = nlayers - dof_cell_owner_d3 (idof,icell) = icell + do idof = 1, ndof_vol + dofmap_d3 (idof, icell) = id_halo + dof_column_height_d3 (idof, icell) = nlayers + dof_cell_owner_d3 (idof, icell) = icell id_halo = id_halo - (ndata * nlayers) end do end if ! Assign dofs for connectivity (3,2) (dofs on faces) !--------------------------------------------------------- - do iface=1, number_horizontal_faces - if (any(select_entity % faces==iface)) then - face_id = mesh%get_face_on_cell(iface,icell) - - if (mesh%is_edge_owned(iface,icell)) then - - if ( dofmap_d2(1,face_id) == 0 ) then - do idof=1, ndof_face - dofmap_d2(idof,face_id) = id_owned - dof_column_height_d2(idof,face_id) = nlayers - dof_cell_owner_d2(idof,face_id) = & - mesh%get_edge_cell_owner(iface,icell) + + ! Horizontal faces + do iface = 1, number_horizontal_faces + if (any(select_entity%faces == iface)) then + face_id = mesh%get_face_on_cell(iface, icell) + if (mesh%is_edge_owned(iface, icell)) then + if (dofmap_d2(1, face_id) == 0) then + do idof = 1, ndof_face_h + dofmap_d2(idof, face_id) = id_owned + dof_column_height_d2(idof, face_id) = nlayers + dof_cell_owner_d2(idof, face_id) = & + mesh%get_edge_cell_owner(iface, icell) + id_owned = id_owned + (ndata * nlayers) end do end if else - if ( dofmap_d2(1,face_id) == 0 ) then - do idof=1, ndof_face - dofmap_d2(idof,face_id) = id_halo - dof_column_height_d2(idof,face_id) = nlayers - dof_cell_owner_d2(idof,face_id) = & - mesh%get_edge_cell_owner(iface,icell) + if (dofmap_d2(1, face_id) == 0) then + do idof = 1, ndof_face_h + dofmap_d2(idof, face_id) = id_halo + dof_column_height_d2(idof, face_id) = nlayers + dof_cell_owner_d2(idof, face_id) = & + mesh%get_edge_cell_owner(iface, icell) + id_halo = id_halo - (ndata * nlayers) end do end if end if end if ! select_entity end do - - if (mesh % is_cell_owned(icell)) then + ! Vertical faces + if (mesh%is_cell_owned(icell)) then id0 = id_owned do iface = number_horizontal_faces + 1, number_faces - if (any(select_entity % faces==iface)) then - face_id = mesh % get_face_on_cell(iface,icell) - - if ( dofmap_d2(1,face_id) == 0 ) then - do idof=1, ndof_face - dofmap_d2(idof,face_id) = id_owned + if (any(select_entity%faces==iface)) then + face_id = mesh%get_face_on_cell(iface, icell) + if (dofmap_d2(1, face_id) == 0) then + do idof = 1, ndof_face_v + dofmap_d2(idof, face_id) = id_owned if (iface == number_horizontal_faces + 1) then - dof_column_height_d2(idof,face_id) = nlayers + 1 + dof_column_height_d2(idof, face_id) = nlayers + 1 else - dof_column_height_d2(idof,face_id) = 0 + dof_column_height_d2(idof, face_id) = 0 end if - dof_cell_owner_d2(idof,face_id) = icell - id_owned = id_owned + (ndata * ( nlayers + 1) ) + dof_cell_owner_d2(idof, face_id) = icell + id_owned = id_owned + (ndata * (nlayers + 1)) end do end if if (iface == number_horizontal_faces + 1) then - id_owned = id0 + ndata + id_owned = id0 + ndata_offset else - id_owned = id_owned - ndata + id_owned = id_owned - ndata_offset end if end if ! select_entity @@ -1868,89 +2117,97 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & else id0 = id_halo do iface = number_horizontal_faces + 1, number_faces - if (any(select_entity % faces==iface)) then - face_id = mesh % get_face_on_cell(iface,icell) - if ( dofmap_d2(1,face_id) == 0 ) then - do idof=1, ndof_face - dofmap_d2(idof,face_id) = id_halo - if ( iface == number_horizontal_faces + 1 ) then - dof_column_height_d2(idof,face_id) = nlayers + 1 + if (any(select_entity%faces == iface)) then + face_id = mesh%get_face_on_cell(iface, icell) + if (dofmap_d2(1, face_id) == 0) then + do idof = 1, ndof_face_v + dofmap_d2(idof, face_id) = id_halo + if (iface == number_horizontal_faces + 1) then + dof_column_height_d2(idof, face_id) = nlayers + 1 else - dof_column_height_d2(idof,face_id) = 0 + dof_column_height_d2(idof, face_id) = 0 end if - dof_cell_owner_d2(idof,face_id) = icell - id_halo = id_halo - (ndata * ( nlayers + 1) ) + dof_cell_owner_d2(idof, face_id) = icell + id_halo = id_halo - (ndata * (nlayers + 1)) end do end if if (iface == number_horizontal_faces + 1) then - id_halo = id0 - ndata + id_halo = id0 - ndata_offset else - id_halo = id_halo + ndata + id_halo = id_halo + ndata_offset end if end if ! select_entity end do end if ! is cell owned ! assign dofs for connectivity (3,1) (dofs on edges) + + ! Horizontal edges do iedge = 1, number_horizontal_edges - bottom_edge_id = mesh%get_edge_on_cell( iedge, icell ) - top_edge_id = mesh%get_edge_on_cell( iedge + number_edges & - - number_horizontal_edges, & - icell ) - if (mesh%is_edge_owned(iedge,icell)) then - if ( dofmap_d1(1,bottom_edge_id) == 0 ) then - do idof=1,ndof_edge - dofmap_d1(idof,bottom_edge_id) = id_owned - dofmap_d1(idof,top_edge_id) = id_owned + ndata - dof_column_height_d1(idof,bottom_edge_id) = nlayers + 1 - dof_column_height_d1(idof,top_edge_id ) = 0 - dof_cell_owner_d1(idof,bottom_edge_id) = & - mesh%get_edge_cell_owner(iedge,icell) - dof_cell_owner_d1(idof,top_edge_id ) = & - mesh%get_edge_cell_owner(iedge,icell) - id_owned = id_owned + (ndata * ( nlayers + 1) ) + bottom_edge_id = mesh%get_edge_on_cell(iedge, icell) + top_edge_id = mesh%get_edge_on_cell(iedge + number_edges & + - number_horizontal_edges, & + icell) + if (mesh%is_edge_owned(iedge, icell)) then + if (dofmap_d1(1, bottom_edge_id) == 0) then + do idof = 1, ndof_edge_h + dofmap_d1(idof, bottom_edge_id) = id_owned + dofmap_d1(idof, top_edge_id) = id_owned + ndata_offset + dof_column_height_d1(idof, bottom_edge_id) = nlayers + 1 + dof_column_height_d1(idof, top_edge_id) = 0 + dof_cell_owner_d1(idof, bottom_edge_id) = & + mesh%get_edge_cell_owner(iedge, icell) + + dof_cell_owner_d1(idof, top_edge_id) = & + mesh%get_edge_cell_owner(iedge, icell) + + id_owned = id_owned + (ndata * (nlayers + 1)) end do end if else - if ( dofmap_d1(1,bottom_edge_id) == 0 ) then - do idof=1,ndof_edge - dofmap_d1(idof,bottom_edge_id) = id_halo - dofmap_d1(idof,top_edge_id) = id_halo - ndata - dof_column_height_d1(idof,bottom_edge_id) = nlayers + 1 - dof_column_height_d1(idof,top_edge_id ) = 0 - dof_cell_owner_d1(idof,bottom_edge_id) = & - mesh%get_edge_cell_owner(iedge,icell) - dof_cell_owner_d1(idof,top_edge_id ) = & - mesh%get_edge_cell_owner(iedge,icell) - id_halo = id_halo - (ndata * ( nlayers + 1) ) + if (dofmap_d1(1, bottom_edge_id) == 0) then + do idof = 1, ndof_edge_h + dofmap_d1(idof, bottom_edge_id) = id_halo + dofmap_d1(idof, top_edge_id) = id_halo - ndata_offset + dof_column_height_d1(idof, bottom_edge_id) = nlayers + 1 + dof_column_height_d1(idof, top_edge_id) = 0 + dof_cell_owner_d1(idof, bottom_edge_id) = & + mesh%get_edge_cell_owner(iedge, icell) + + dof_cell_owner_d1(idof, top_edge_id) = & + mesh%get_edge_cell_owner(iedge, icell) + + id_halo = id_halo - (ndata * (nlayers + 1)) end do end if end if end do - do iedge = number_horizontal_edges + 1, & - number_edges - number_horizontal_edges - side_edge_id = mesh%get_edge_on_cell(iedge,icell) - if (mesh%is_vertex_owned( iedge - number_horizontal_edges, & - icell )) then - if ( dofmap_d1(1,side_edge_id) == 0 ) then - do idof=1,ndof_edge - dofmap_d1(idof,side_edge_id) = id_owned - dof_column_height_d1(idof,side_edge_id) = nlayers - dof_cell_owner_d1(idof,side_edge_id) & - = mesh%get_vertex_cell_owner( iedge - number_horizontal_edges, & - icell) - id_owned = id_owned + ( nlayers * ndata ) + ! Vertical edges + do iedge = number_horizontal_edges + 1, number_edges & + - number_horizontal_edges + side_edge_id = mesh%get_edge_on_cell(iedge, icell) + if (mesh%is_vertex_owned(iedge - number_horizontal_edges, icell)) then + if (dofmap_d1(1, side_edge_id) == 0) then + do idof = 1, ndof_edge_v + dofmap_d1(idof, side_edge_id) = id_owned + dof_column_height_d1(idof, side_edge_id) = nlayers + dof_cell_owner_d1(idof, side_edge_id) = & + mesh%get_vertex_cell_owner(iedge - number_horizontal_edges, & + icell) + + id_owned = id_owned + (nlayers * ndata) end do end if else - if ( dofmap_d1(1,side_edge_id) == 0 ) then - do idof=1,ndof_edge - dofmap_d1(idof,side_edge_id) = id_halo - dof_column_height_d1(idof,side_edge_id) = nlayers - dof_cell_owner_d1(idof,side_edge_id) & - = mesh%get_vertex_cell_owner( iedge - number_horizontal_edges, & - icell) - id_halo = id_halo - ( nlayers * ndata ) + if (dofmap_d1(1, side_edge_id) == 0) then + do idof = 1, ndof_edge_v + dofmap_d1(idof, side_edge_id) = id_halo + dof_column_height_d1(idof, side_edge_id) = nlayers + dof_cell_owner_d1(idof, side_edge_id) = & + mesh%get_vertex_cell_owner(iedge - number_horizontal_edges, & + icell) + + id_halo = id_halo - (nlayers * ndata) end do end if end if @@ -1959,86 +2216,90 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! Assign dofs for connectivity (3,0) (dofs on verts) !--------------------------------------------------------- - do ivert=1, number_horizontal_vertices - bottom_vert_id = mesh % get_vert_on_cell(ivert,icell) - top_vert_id & - = mesh % get_vert_on_cell( ivert + number_horizontal_vertices, & - icell ) - - if (mesh % is_vertex_owned(ivert,icell)) then - - if ( dofmap_d0(1,bottom_vert_id) == 0 ) then - do idof=1, ndof_vert - dofmap_d0(idof,bottom_vert_id) = id_owned - dofmap_d0(idof,top_vert_id) = id_owned + ndata - dof_column_height_d0(idof,bottom_vert_id) = nlayers + 1 - dof_column_height_d0(idof,top_vert_id ) = 0 - dof_cell_owner_d0(idof,bottom_vert_id) = & - mesh % get_vertex_cell_owner(ivert,icell) - dof_cell_owner_d0(idof,top_vert_id ) = & - mesh % get_vertex_cell_owner(ivert,icell) - id_owned = id_owned + (ndata * ( nlayers + 1) ) + do ivert = 1, number_2d_vertices + bottom_vert_id = mesh%get_vert_on_cell(ivert, icell) + top_vert_id = mesh%get_vert_on_cell(ivert + number_2d_vertices, icell) + if (mesh%is_vertex_owned(ivert, icell)) then + if (dofmap_d0(1, bottom_vert_id) == 0) then + do idof = 1, ndof_vert + dofmap_d0(idof, bottom_vert_id) = id_owned + dofmap_d0(idof, top_vert_id) = id_owned + ndata_offset + dof_column_height_d0(idof, bottom_vert_id) = nlayers + 1 + dof_column_height_d0(idof, top_vert_id) = 0 + dof_cell_owner_d0(idof, bottom_vert_id) = & + mesh%get_vertex_cell_owner(ivert, icell) + + dof_cell_owner_d0(idof, top_vert_id) = & + mesh%get_vertex_cell_owner(ivert, icell) + + id_owned = id_owned + (ndata * (nlayers + 1)) end do end if else - if ( dofmap_d0(1,bottom_vert_id) == 0 ) then - do idof=1, ndof_vert - dofmap_d0(idof,bottom_vert_id) = id_halo - dofmap_d0(idof,top_vert_id) = id_halo - ndata - dof_column_height_d0(idof,bottom_vert_id) = nlayers + 1 - dof_column_height_d0(idof,top_vert_id ) = 0 - dof_cell_owner_d0(idof,bottom_vert_id) = & - mesh%get_vertex_cell_owner(ivert,icell) - dof_cell_owner_d0(idof,top_vert_id ) = & - mesh%get_vertex_cell_owner(ivert,icell) - id_halo = id_halo - (ndata * ( nlayers + 1) ) + if (dofmap_d0(1, bottom_vert_id) == 0) then + do idof = 1, ndof_vert + dofmap_d0(idof, bottom_vert_id) = id_halo + dofmap_d0(idof, top_vert_id) = id_halo - ndata_offset + dof_column_height_d0(idof, bottom_vert_id) = nlayers + 1 + dof_column_height_d0(idof, top_vert_id) = 0 + dof_cell_owner_d0(idof, bottom_vert_id) = & + mesh%get_vertex_cell_owner(ivert, icell) + + dof_cell_owner_d0(idof, top_vert_id) = & + mesh%get_vertex_cell_owner(ivert, icell) + + id_halo = id_halo - (ndata * (nlayers + 1)) end do end if end if end do - if(icell == tot_num_inner + mesh%get_num_cells_edge())then + if (icell == tot_num_inner + mesh%get_num_cells_edge()) then last_dof_owned = id_owned - 1 last_dof_annexed = id_owned - id_halo - 2 end if end do cell_loop - if (idepth <= mesh%get_halo_depth()) & - last_dof_halo(idepth) = id_owned - id_halo - 2 + if (idepth <= mesh%get_halo_depth()) then + last_dof_halo(idepth) = id_owned - id_halo - 2 + end if - start = finish+1 + start = finish + 1 if (idepth < mesh%get_halo_depth()) then - finish = start + mesh % get_num_cells_halo(idepth+1)-1 + finish = start + mesh%get_num_cells_halo(idepth + 1) - 1 else - finish = start + mesh % get_num_cells_ghost()-1 + finish = start + mesh%get_num_cells_ghost() - 1 end if end do halo_loop + ! The zeroth depth halo contains no dofs, so set the last dof to be the + ! same as the last dof before it in memory - i.e. the last annexed dof + last_dof_halo(0) = last_dof_annexed ! Copy from the dofmap_dn arrays into one dofmap array dof_column_height(:,:) = -999 - dof_cell_owner(:,:) = -999 - dofmap(:,:) = -999 + dof_cell_owner(:,:) = -999 + dofmap(:,:) = -999 - do icell=1, ncells + do icell = 1, ncells dof_idx = 1 ! dofs in volumes !---------------------------------------- - do idof=1, ndof_vol - if ( dofmap_d3(idof,icell) /= 0 ) then + do idof = 1, ndof_vol + if (dofmap_d3(idof, icell) /= 0) then - if ( dofmap_d3(idof,icell) > 0 ) then - dofmap(dof_idx,icell) = dofmap_d3(idof,icell) - else if ( dofmap_d3(idof,icell) < 0 ) then - dofmap(dof_idx,icell) = id_owned - (dofmap_d3(idof,icell) + 1) + if (dofmap_d3(idof, icell) > 0) then + dofmap(dof_idx, icell) = dofmap_d3(idof, icell) + else if (dofmap_d3(idof, icell) < 0) then + dofmap(dof_idx, icell) = id_owned - (dofmap_d3(idof, icell) + 1) end if - dof_column_height(dof_idx,icell) = dof_column_height_d3(idof,icell) - dof_cell_owner(dof_idx,icell) = dof_cell_owner_d3(idof,icell) + dof_column_height(dof_idx, icell) = dof_column_height_d3(idof, icell) + dof_cell_owner(dof_idx, icell) = dof_cell_owner_d3(idof, icell) dof_idx = dof_idx + 1 end if @@ -2046,18 +2307,25 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! dofs on faces !---------------------------------------- - do iface=1, number_faces - face_id = mesh % get_face_on_cell(iface,icell) - do idof=1, ndof_face - if ( dofmap_d2(idof,face_id) /= 0 ) then - if ( dofmap_d2(idof,face_id) > 0 ) then - dofmap(dof_idx,icell) = dofmap_d2(idof,face_id) - else if ( dofmap_d2(idof,face_id) < 0 ) then - dofmap(dof_idx,icell) = id_owned - (dofmap_d2(idof,face_id) + 1) + do iface = 1, number_faces + face_id = mesh%get_face_on_cell(iface, icell) + if (iface <= number_horizontal_faces) then + ndof_stop = ndof_face_h ! Horizontal faces + else + ndof_stop = ndof_face_v ! Vertical faces + end if + + do idof = 1, ndof_stop + if (dofmap_d2(idof, face_id) /= 0) then + if (dofmap_d2(idof, face_id) > 0) then + dofmap(dof_idx, icell) = dofmap_d2(idof, face_id) + else if (dofmap_d2(idof, face_id) < 0) then + dofmap(dof_idx, icell) = id_owned - (dofmap_d2(idof, face_id) + 1) end if - dof_column_height(dof_idx,icell) = dof_column_height_d2(idof,face_id) - dof_cell_owner(dof_idx,icell) = dof_cell_owner_d2(idof,face_id) + dof_column_height(dof_idx, icell) = dof_column_height_d2(idof, & + face_id) + dof_cell_owner(dof_idx, icell) = dof_cell_owner_d2(idof, face_id) dof_idx = dof_idx + 1 end if @@ -2066,17 +2334,26 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! dofs on edges !---------------------------------------- - do iedge=1, number_edges - edge_id = mesh % get_edge_on_cell(iedge,icell) - do idof=1, ndof_edge - if ( dofmap_d1(idof,edge_id) /= 0 ) then - if ( dofmap_d1(idof,edge_id) > 0 ) then - dofmap(dof_idx,icell) = dofmap_d1(idof,edge_id) - else if ( dofmap_d1(idof,edge_id) < 0 ) then - dofmap(dof_idx,icell) = id_owned - (dofmap_d1(idof,edge_id) + 1) + do iedge = 1, number_edges + edge_id = mesh%get_edge_on_cell(iedge, icell) + if ((iedge <= number_horizontal_edges) .or. & + (iedge > number_edges - number_horizontal_edges)) then + ndof_stop = ndof_edge_h ! Horizontal edges + else + ndof_stop = ndof_edge_v ! Vertical edges + end if + + do idof = 1, ndof_stop + if (dofmap_d1(idof, edge_id) /= 0) then + if (dofmap_d1(idof, edge_id) > 0) then + dofmap(dof_idx, icell) = dofmap_d1(idof, edge_id) + else if (dofmap_d1(idof, edge_id) < 0) then + dofmap(dof_idx, icell) = id_owned - (dofmap_d1(idof, edge_id) + 1) end if - dof_column_height(dof_idx,icell) = dof_column_height_d1(idof,edge_id) - dof_cell_owner(dof_idx,icell) = dof_cell_owner_d1(idof,edge_id) + + dof_column_height(dof_idx, icell) = dof_column_height_d1(idof, & + edge_id) + dof_cell_owner(dof_idx, icell) = dof_cell_owner_d1(idof, edge_id) dof_idx = dof_idx + 1 end if end do @@ -2084,17 +2361,19 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! dofs on vertices !---------------------------------------- - do ivert=1, number_vertices - vert_id = mesh % get_vert_on_cell(ivert,icell) - do idof=1, ndof_vert - if ( dofmap_d0(idof,vert_id) /= 0 ) then - if ( dofmap_d0(idof,vert_id) > 0 ) then - dofmap(dof_idx,icell) = dofmap_d0(idof,vert_id) - else if ( dofmap_d0(idof,vert_id) < 0 ) then - dofmap(dof_idx,icell) = id_owned - (dofmap_d0(idof,vert_id) + 1) + do ivert = 1, number_vertices + vert_id = mesh%get_vert_on_cell(ivert, icell) + do idof = 1, ndof_vert + if (dofmap_d0(idof, vert_id) /= 0) then + if (dofmap_d0(idof, vert_id) > 0) then + dofmap(dof_idx, icell) = dofmap_d0(idof, vert_id) + else if (dofmap_d0(idof, vert_id) < 0) then + dofmap(dof_idx, icell) = id_owned - (dofmap_d0(idof, vert_id) + 1) end if - dof_column_height(dof_idx,icell) = dof_column_height_d0(idof,vert_id) - dof_cell_owner(dof_idx,icell) = dof_cell_owner_d0(idof,vert_id) + + dof_column_height(dof_idx, icell) = dof_column_height_d0(idof, & + vert_id) + dof_cell_owner(dof_idx, icell) = dof_cell_owner_d0(idof, vert_id) dof_idx = dof_idx + 1 end if end do @@ -2102,52 +2381,58 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & end do - dofmap(:,0) = 0 + dofmap(:, 0) = 0 - if (allocated( dofmap_d0 )) deallocate( dofmap_d0 ) - if (allocated( dofmap_d1 )) deallocate( dofmap_d1 ) - if (allocated( dofmap_d2 )) deallocate( dofmap_d2 ) - if (allocated( dofmap_d3 )) deallocate( dofmap_d3 ) + if (allocated(dofmap_d0)) deallocate(dofmap_d0) + if (allocated(dofmap_d1)) deallocate(dofmap_d1) + if (allocated(dofmap_d2)) deallocate(dofmap_d2) + if (allocated(dofmap_d3)) deallocate(dofmap_d3) - if (allocated( dof_column_height_d0 )) deallocate( dof_column_height_d0 ) - if (allocated( dof_column_height_d1 )) deallocate( dof_column_height_d1 ) - if (allocated( dof_column_height_d2 )) deallocate( dof_column_height_d2 ) - if (allocated( dof_column_height_d3 )) deallocate( dof_column_height_d3 ) + if (allocated(dof_column_height_d0)) deallocate(dof_column_height_d0) + if (allocated(dof_column_height_d1)) deallocate(dof_column_height_d1) + if (allocated(dof_column_height_d2)) deallocate(dof_column_height_d2) + if (allocated(dof_column_height_d3)) deallocate(dof_column_height_d3) - if (allocated( dof_cell_owner_d0 )) deallocate( dof_cell_owner_d0 ) - if (allocated( dof_cell_owner_d1 )) deallocate( dof_cell_owner_d1 ) - if (allocated( dof_cell_owner_d2 )) deallocate( dof_cell_owner_d2 ) - if (allocated( dof_cell_owner_d3 )) deallocate( dof_cell_owner_d3 ) + if (allocated(dof_cell_owner_d0)) deallocate(dof_cell_owner_d0) + if (allocated(dof_cell_owner_d1)) deallocate(dof_cell_owner_d1) + if (allocated(dof_cell_owner_d2)) deallocate(dof_cell_owner_d2) + if (allocated(dof_cell_owner_d3)) deallocate(dof_cell_owner_d3) ! Special cases for lowest order w3 and wtheta. These allow global_dof_id ! to have an index space with no gaps in it for these specific funct spaces - num_layers=int(nlayers,i_halo_index)+1_i_halo_index - if(element_order==0.and.gungho_fs==W3)num_layers=int(nlayers,i_halo_index) - num_dofs=int(ndof_cell,i_halo_index) - if(element_order==0.and.gungho_fs==WTHETA)num_dofs=1_i_halo_index - num_ndata=int(ndata,i_halo_index) + num_layers = int(nlayers, i_halo_index) + 1_i_halo_index + num_dofs = int(ndof_cell, i_halo_index) + num_ndata = int(ndata, i_halo_index) + if( element_order_h == 0 .and. element_order_v == 0 ) then + if (gungho_fs == W3) then + num_layers = int(nlayers, i_halo_index) + else if( gungho_fs == WTHETA ) then + num_dofs = 1_i_halo_index + end if + end if ! Calculate a globally unique id for each dof, such that each partition ! that needs access to that dof will calculate the same id global_dof_id(:) = 0_i_halo_index - do icell=1, ncells - global_cell_id = mesh % get_gid_from_lid(icell) - do idof=1, ndof_cell - if (icell == dof_cell_owner(idof,icell)) then - do k=1, dof_column_height(idof, icell) - do m=1, ndata + do icell = 1, ncells + global_cell_id = mesh%get_gid_from_lid(icell) + do idof = 1, ndof_cell + if (icell == dof_cell_owner(idof, icell)) then + do k = 1, dof_column_height(idof, icell) + do m = 1, ndata ! The following line is very confused by the casting that is ! required, but it is actually calculating the global id as being: - ! (global_cell_id-1) * num_dofs*ndata*num_layers + - ! (idof-1) * ndata*num_layers + - ! (k - 1)* ndata + - ! (m - 1) - global_dof_id( dofmap(idof,icell)+(k-1)+(m-1) ) = & - (int(global_cell_id,i_halo_index)-1_i_halo_index)* & - num_dofs*num_ndata*num_layers + & - (int(idof,i_halo_index)-1_i_halo_index)* num_ndata*num_layers + & - (int(k,i_halo_index) - 1_i_halo_index)* num_ndata + & - int(m,i_halo_index) - 1_i_halo_index + ! (global_cell_id-1) * num_dofs * ndata * num_layers + ! + (idof-1) * ndata*num_layers + ! + (k - 1) * ndata + ! + (m - 1) + global_dof_id(dofmap(idof, icell) + (k - 1) * ndata + (m - 1)) = & + (int(global_cell_id, i_halo_index) - 1_i_halo_index) & + * num_dofs * num_ndata * num_layers & + + (int(idof, i_halo_index) - 1_i_halo_index) & + * num_ndata * num_layers & + + (int(k, i_halo_index) - 1_i_halo_index) * num_ndata & + + (int(m, i_halo_index) - 1_i_halo_index) end do end do end if @@ -2159,75 +2444,32 @@ subroutine dofmap_setup( mesh, gungho_fs, element_order, ndata, & ! will work for all function spaces - even if they don't have cell vol dofs ! loop over local cells - do icell=1, mesh%get_last_edge_cell() - global_cell_id = mesh % get_gid_from_lid(icell) - do m=1, ndata + do icell = 1, mesh%get_last_edge_cell() + global_cell_id = mesh%get_gid_from_lid(icell) + do m = 1, ndata ! The global ids must be 0 based - global_cell_dof_id_2d( (icell-1)*ndata + m ) = & - (global_cell_id - 1)*ndata + m - 1 + global_cell_dof_id_2d((icell - 1) * ndata + m) = (global_cell_id - 1) & + * ndata & + + m - 1 end do end do - ! Calculate a globally unique id for the dofs on the edges of each cell - ! in the 2D horizontal part of the local domain - only possible for - ! function spaces that (appear to) have 2d edge dofs - ! (for the moment, using W2H as an example of such a function space - ! - the 2d layer at the half levels appears to have edge dofs). - if(element_order==0 .and. gungho_fs==W2H)then - ! loop over local cells - do icell=1, mesh%get_last_edge_cell() - ! loop over 2d edges within a cell - do iedge=1, mesh%get_nedges_per_cell_2d() - if(mesh%is_edge_owned(iedge,icell))then - do m=1, ndata - global_edge_dof_id_2d(((dofmap(iedge,icell)-1)/(nlayers*ndata))+1) = & - (mesh%get_edge_gid_on_cell(iedge,icell) - 1)*ndata + m - 1 - end do - endif - end do - end do - else - global_edge_dof_id_2d(:) = -1 - end if - - ! Calculate a globally unique id for the dofs on the vertices of each cell - ! in the 2D horizontal part of the local domain - only possible for - ! function spaces that have vertex dofs. - ! (for the moment, using W0 as an example of such a function space). - if(element_order==0 .and. gungho_fs==W0)then - ! loop over local cells - do icell=1, mesh%get_last_edge_cell() - ! loop over 2d vertices within a cell - do ivert=1, mesh%get_nverts_per_cell_2d() - if(mesh%is_vertex_owned(ivert,icell))then - do m=1, ndata - global_vert_dof_id_2d(((dofmap(ivert,icell)-1)/((nlayers+1)*ndata))+1) = & - (mesh%get_vert_gid_on_cell(ivert,icell) - 1)*ndata + m - 1 - end do - endif - end do - end do - else - global_vert_dof_id_2d(:) = -1 - end if + if (allocated(dof_column_height)) deallocate(dof_column_height) + if (allocated(dof_cell_owner)) deallocate(dof_cell_owner) + + if (allocated(select_entity_all%faces)) deallocate(select_entity_all%faces) + if (allocated(select_entity_all%edges)) deallocate(select_entity_all%edges) + if (allocated(select_entity_all%verts)) deallocate(select_entity_all%verts) + if (allocated(select_entity_theta%faces)) deallocate(select_entity_theta%faces) + if (allocated(select_entity_theta%edges)) deallocate(select_entity_theta%edges) + if (allocated(select_entity_theta%verts)) deallocate(select_entity_theta%verts) + if (allocated(select_entity_w2v%faces)) deallocate(select_entity_w2v%faces) + if (allocated(select_entity_w2v%edges)) deallocate(select_entity_w2v%edges) + if (allocated(select_entity_w2v%verts)) deallocate(select_entity_w2v%verts) + if (allocated(select_entity_w2h%faces)) deallocate(select_entity_w2h%faces) + if (allocated(select_entity_w2h%edges)) deallocate(select_entity_w2h%edges) + if (allocated(select_entity_w2h%verts)) deallocate(select_entity_w2h%verts) - if (allocated(dof_column_height)) deallocate( dof_column_height ) - if (allocated(dof_cell_owner)) deallocate( dof_cell_owner ) - - if (allocated( select_entity_all % faces )) deallocate( select_entity_all % faces ) - if (allocated( select_entity_all % edges )) deallocate( select_entity_all % edges ) - if (allocated( select_entity_all % verts )) deallocate( select_entity_all % verts ) - if (allocated( select_entity_theta % faces )) deallocate( select_entity_theta % faces ) - if (allocated( select_entity_theta % edges )) deallocate( select_entity_theta % edges ) - if (allocated( select_entity_theta % verts )) deallocate( select_entity_theta % verts ) - if (allocated( select_entity_w2v % faces )) deallocate( select_entity_w2v % faces ) - if (allocated( select_entity_w2v % edges )) deallocate( select_entity_w2v % edges ) - if (allocated( select_entity_w2v % verts )) deallocate( select_entity_w2v % verts ) - if (allocated( select_entity_w2h % faces )) deallocate( select_entity_w2h % faces ) - if (allocated( select_entity_w2h % edges )) deallocate( select_entity_w2h % edges ) - if (allocated( select_entity_w2h % verts )) deallocate( select_entity_w2h % verts ) - - return end subroutine dofmap_setup !----------------------------------------------------------------------------- @@ -2240,36 +2482,38 @@ end subroutine dofmap_setup !> @param[in] fs Integer enumeration of the function space. !> @param[out] levels Array of fractional levels. !> - subroutine levels_setup( mesh, nlayers, fs, levels ) + subroutine levels_setup(mesh, nlayers, fs, levels) implicit none - type(mesh_type), intent(in) :: mesh - integer(i_def), intent(in) :: nlayers - integer(i_def), intent(in) :: fs - real(r_def), intent(out), allocatable :: levels(:) + type(mesh_type), intent(in) :: mesh + + integer(i_def), intent(in) :: nlayers + integer(i_def), intent(in) :: fs - class(reference_element_type), pointer :: reference_element => null() + real(r_def), intent(out), allocatable :: levels(:) + + class(reference_element_type), pointer :: reference_element => null() real(r_def), allocatable :: vert_coords(:,:) real(r_def), allocatable :: edge_coords(:,:) real(r_def), allocatable :: face_coords(:,:) real(r_def), allocatable :: volume_coords(:,:) ! Variable to hold the number of levels we found - integer(i_def) :: idx + integer(i_def) :: idx ! working array to hold fractional levels real(r_def), allocatable :: tmp_levs(:) - type(select_data_entity_type) :: select_data_entity_all, & - select_data_entity_theta, & - select_data_entity_w2h, & - select_data_entity_w2v + type(select_data_entity_type) :: select_data_entity_all, & + select_data_entity_theta, & + select_data_entity_w2h, & + select_data_entity_w2v reference_element => mesh%get_reference_element() - call reference_element%get_vertex_coordinates( vert_coords ) - call reference_element%get_edge_centre_coordinates( edge_coords ) - call reference_element%get_face_centre_coordinates( face_coords ) - call reference_element%get_volume_centre_coordinates( volume_coords ) + call reference_element%get_vertex_coordinates(vert_coords) + call reference_element%get_edge_centre_coordinates(edge_coords) + call reference_element%get_face_centre_coordinates(face_coords) + call reference_element%get_volume_centre_coordinates(volume_coords) call setup_select_data_entities( mesh, & select_data_entity_all, & @@ -2279,7 +2523,6 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) select case (fs) - case (W0) ! W0 locates data on vertices @@ -2307,7 +2550,6 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) tmp_levs, & idx ) - case (W3) ! W3 locates data on cell volume @@ -2317,7 +2559,6 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) tmp_levs, & idx ) - case (WTHETA) ! WTheta locates data on selected faces ! (top and bottom) @@ -2328,8 +2569,7 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) tmp_levs, & idx ) - - case (W2H) + case (W2H, W2Hbroken) ! W2H locates data on selected faces ! (top and bottom) @@ -2339,7 +2579,6 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) tmp_levs, & idx ) - case (W2V) ! W2V locates data on selected faces ! (W, S, E, N) @@ -2361,10 +2600,10 @@ subroutine levels_setup( mesh, nlayers, fs, levels ) ! Allocate the out array to be the size of the number of levels we found ! and copy in the data from the temp array - allocate( levels( size(tmp_levs(1:(idx-1))) ) ) - levels=tmp_levs(1:(idx-1)) + allocate(levels(size(tmp_levs(1:(idx - 1))))) + levels = tmp_levs(1:(idx - 1)) - nullify( reference_element ) + nullify(reference_element) if (allocated(vert_coords)) deallocate(vert_coords) if (allocated(edge_coords)) deallocate(edge_coords) if (allocated(face_coords)) deallocate(face_coords) @@ -2403,20 +2642,20 @@ subroutine compute_levels( nlayers, & ! Local variables for computation real(r_def) :: l - integer(i_def) :: ilayer, idof + integer(i_def) :: ilayer, idof ! Allocate temp levels array to be the maximum possible size - allocate(tmp_levs(size(entity_array)*nlayers)) - tmp_levs = 999.0 - idx=1 + allocate(tmp_levs(size(entity_array) * nlayers)) + tmp_levs = 999.0_r_def + idx = 1 - do ilayer=0, (nlayers - 1) + do ilayer = 0, (nlayers - 1) do idof = 1, size(entity_array) ! Check this mesh entity is not marked as missing for this function ! space if (entity_array(idof) /= IMDI) then - l = ilayer + coords_array(entity_array(idof),3) - if ( .not.(any(tmp_levs == l)) ) then + l = ilayer + coords_array(entity_array(idof), 3) + if (.not.(any(tmp_levs == l))) then tmp_levs(idx) = l ! keep track of how many items we added idx = idx + 1 @@ -2427,4 +2666,47 @@ subroutine compute_levels( nlayers, & end subroutine compute_levels + !> @brief Generate a unique integer id for a function space + !> @param[in] lfric_fs Function space continuity flag + !> @param[in] element_order_h Polynomial order of the space in the horizontal + !> @param[in] element_order_v Polynomial order of the space in the vertical + !> @param[in] mesh_id Id of the mesh to build the function space on + !> @param[in] ndata Number of multidata points + !> @param[in] ndata_first ndata of layer first layout of multidata array + !> @result fs_id Unique id for the function space + function generate_fs_id(lfric_fs, element_order_h, element_order_v, mesh_id, & + ndata, ndata_first) result(fs_id) + + implicit none + + integer(i_def), intent(in) :: lfric_fs + integer(i_def), intent(in) :: element_order_h + integer(i_def), intent(in) :: element_order_v + integer(i_def), intent(in) :: mesh_id + integer(i_def), intent(in) :: ndata + logical(l_def), intent(in) :: ndata_first + + integer(i_def) :: fs_id + integer(i_def) :: ndata_first_int + + if ( ndata_first ) then + ndata_first_int = 1 + else + ndata_first_int = 2 + end if + + ! Temporary clause for #4443, will be removed when split element orders are + ! fully enabled in #4462 + if ( element_order_h /= element_order_v ) then + call log_event( & + 'Current infrastructure requires element orders to match', & + LOG_LEVEL_ERROR) + else + fs_id = ndata + 1000_i_def*element_order_h + 10000_i_def*element_order_v & + + 100000_i_def*lfric_fs + 10000000_i_def*mesh_id & + + 1000000000_i_def*ndata_first_int + end if + + end function generate_fs_id + end module function_space_constructor_helper_functions_mod diff --git a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_mod.F90 b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_mod.F90 index 1ceaad1835..8cb3adf04f 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_mod.F90 +++ b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_mod.F90 @@ -38,1423 +38,1582 @@ ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Modified by J. Henrichs, Bureau of Meteorology +! J. Dendy, Met Office !> !> @brief Holds information about the function space. !> !> @details A container which holds type definition of the function space and -!> has holds a number of static copies of the function spaces require +!> holds a number of static copies of the function spaces required !> by the model. It provides accessor functions (getters) to various !> information held in the type. ! module function_space_mod + use constants_mod, only : i_def, i_halo_index, l_def, r_def + use mesh_mod, only : mesh_type + use master_dofmap_mod, only : master_dofmap_type + use stencil_dofmap_helper_functions_mod, & + only : generate_stencil_dofmap_id + use log_mod, only : log_event, log_scratch_space, & + LOG_LEVEL_DEBUG, LOG_LEVEL_ERROR, & + LOG_LEVEL_INFO + use fs_continuity_mod, only : W0, W1, W2, W3, Wtheta, W2broken, W2trace, & + W2Htrace, W2Vtrace, W2V, W2H, Wchi, & + W2Hbroken + use function_space_constructor_helper_functions_mod, & + only : ndof_setup, basis_setup, dofmap_setup, & + levels_setup, generate_fs_id + use linked_list_data_mod, only : linked_list_data_type + use linked_list_mod, only : linked_list_type, linked_list_item_type -use constants_mod, only: i_def, i_native, i_halo_index, l_def, r_def -use mesh_mod, only: mesh_type -use master_dofmap_mod, only: master_dofmap_type -use stencil_dofmap_helper_functions_mod, & - only: generate_stencil_dofmap_id -use log_mod, only: log_event, log_scratch_space & - , LOG_LEVEL_DEBUG, LOG_LEVEL_ERROR & - , LOG_LEVEL_INFO -use reference_element_mod, only: reference_element_type -use fs_continuity_mod, only: W0, W1, W2, W3, Wtheta, & - W2broken, W2trace, & - W2Htrace, W2Vtrace, & - W2V, W2H, Wchi -use function_space_constructor_helper_functions_mod, & - only: ndof_setup, basis_setup, & - dofmap_setup, levels_setup + implicit none -use linked_list_data_mod, only : linked_list_data_type -use linked_list_mod, only : linked_list_type, & - linked_list_item_type + private -implicit none + integer(i_def), public, parameter :: BASIS = 100 + integer(i_def), public, parameter :: DIFF_BASIS = 101 -private + !----------------------------------------------------------------------------- + ! Public types + !----------------------------------------------------------------------------- -public :: W0, W1, W2, W2broken, W2trace, W2Vtrace, W2Htrace, W3, Wtheta, W2V, W2H, Wchi + type, extends(linked_list_data_type), public :: function_space_type -integer(i_def), public, parameter :: BASIS = 100 -integer(i_def), public, parameter :: DIFF_BASIS = 101 + private + !> Number of degrees of freedom associated with each cell + integer(i_def) :: ndof_cell -!------------------------------------------------------------------------------- -! Public types -!------------------------------------------------------------------------------- - -type, extends(linked_list_data_type), public :: function_space_type - - private + !> Number of unique degrees of freedom located on + !> the 3D mesh associated with this function space. + integer(i_def) :: ndof_glob - !> Number of degrees of freedom associated with each cell - integer(i_def) :: ndof_cell + !> Number of degrees of freedom associated with each cell + integer(i_def) :: ndof_interior - !> Number of unique degrees of freedom located on - !> the 3D mesh associated with this function space. - integer(i_def) :: ndof_glob + !> Number of degrees of freedom associated with each cell + integer(i_def) :: ndof_exterior - !> Number of degrees of freedom associated with each cell - integer(i_def) :: ndof_interior + !> Number of degrees of freedom located on cell vertex entities. + integer(i_def) :: ndof_vert - !> Number of degrees of freedom associated with each cell - integer(i_def) :: ndof_exterior + !> Number of degrees of freedom located on horizontal cell edge entities + !> (edges which lie in a plane of constant z). + integer(i_def) :: ndof_edge_h - !> Number of degrees of freedom located on cell vertex entities. - integer(i_def) :: ndof_vert + !> Number of degrees of freedom located on vertical cell edge entities + !> (edges which lie in a plane of contant x or y). + integer(i_def) :: ndof_edge_v - !> Number of degrees of freedom located on cell edge entities. - integer(i_def) :: ndof_edge + !> Number of degrees of freedom located on horizontal cell face entities + !> (faces whose normal vectors have 0 z-component). + integer(i_def) :: ndof_face_h - !> Number of degrees of freedom located on cell face entities. - integer(i_def) :: ndof_face + !> Number of degrees of freedom located on vertical cell face entities + !> (faces whose normal vectors have 0 x and y components). + integer(i_def) :: ndof_face_v - !> Number of degrees of freedom located on cell volume entities. - integer(i_def) :: ndof_vol + !> Number of degrees of freedom located on cell volume entities. + integer(i_def) :: ndof_vol - !> Integer value for Gungho functions spaces, e.g. W0 would be 1 - integer(i_def) :: fs + !> Integer value for Gungho functions spaces, e.g. W0 would be 1 + integer(i_def) :: fs - !> Element base-order of Gungho function space - integer(i_def) :: element_order + !> Element base-order of Gungho function space in horizontal direction + integer(i_def) :: element_order_h - ! Function space polynomial order? dynamics is still to provide us - ! with a name for this, same as element order except for W0 - ! where is it equal to element_order+1 - integer(i_def) :: fs_order + !> Element base-order of Gungho function space in vertical direction + integer(i_def) :: element_order_v - !> The number of data values to be held at each dof location - integer(i_def) :: ndata + ! Function space polynomial order? dynamics is still to provide us + ! with a name for this, same as element order except for W0 + ! where is it equal to element_order_h/v+1, in either horizontal or vertical + integer(i_def) :: fs_order_h + integer(i_def) :: fs_order_v - !> Number of dimensions in this function space - integer(i_def) :: dim_space + !> The number of data values to be held at each dof location + integer(i_def) :: ndata - !> Number of dimensions in this function space when differentiated - integer(i_def) :: dim_space_diff + !> Flag describes order of data. False=layer first, true=multi-data first + logical(l_def) :: ndata_first - !> A two dimensional, allocatable array which holds the indirection map - !> or dofmap for the whole function space over the bottom level of the domain. - type(master_dofmap_type) :: master_dofmap + !> Number of dimensions in this function space + integer(i_def) :: dim_space - !> Mesh object used to create this function space. This is a - !> pointer to a mesh in a linked list of mesh objects - type(mesh_type), pointer :: mesh => null() + !> Number of dimensions in this function space when differentiated + integer(i_def) :: dim_space_diff - !> A two dimensional, allocatable array of reals which holds the coordinates - !> of the function_space degrees of freedom - real(r_def), allocatable :: nodal_coords(:,:) + !> A two dimensional, allocatable array which holds the indirection map or + !> dofmap for the whole function space over the bottom level of the domain. + type(master_dofmap_type) :: master_dofmap - !> A two dimensional, allocatable, integer array which specifies which - !> dofs are on vertex boundarys - integer(i_def), allocatable :: dof_on_vert_boundary(:,:) + !> Mesh object used to create this function space. This is a + !> pointer to a mesh in a linked list of mesh objects + type(mesh_type), pointer :: mesh => null() - !> An allocatable array of labels (integers) which maps degree of freedom - !> index to the geometric entity (V - Volume, W - West face, T - Top face, etc.) - integer(i_def), allocatable :: entity_dofs(:) + !> A two dimensional, allocatable array of reals which holds the coordinates + !> of the function_space degrees of freedom + real(r_def), allocatable :: nodal_coords(:,:) - !> An array to hold an ordered, unique list of levels for output - !> of fields on this function space - real(r_def), allocatable :: fractional_levels(:) + !> A two dimensional, allocatable, integer array which specifies which + !> dofs are on vertex boundarys + integer(i_def), allocatable :: dof_on_vert_boundary(:,:) - !> @} - !> @name Arrays needed for on the fly basis evaluations - integer(i_def), allocatable :: basis_order(:,:) - integer(i_def), allocatable :: basis_index(:,:) - real(r_def), allocatable :: basis_vector(:,:) - real(r_def), allocatable :: basis_x(:,:,:) - !> @} + !> An allocatable array of labels (integers) which maps degree of freedom + !> index to the geometric entity + !> (V - Volume, W - West face, T - Top face, etc.) + integer(i_def), allocatable :: entity_dofs(:) - !> A one dimensional, allocatable array which holds a unique global index for - !> every dof in the local domain - integer(i_halo_index), allocatable :: global_dof_id(:) + !> An array to hold an ordered, unique list of levels for output + !> of fields on this function space + real(r_def), allocatable :: fractional_levels(:) - !> A one dimensional, allocatable array which holds a unique global index for - !> cell dofs in the 2D horizontal portion of the local domain - integer(i_def), allocatable :: global_cell_dof_id_2d(:) + !> @} + !> @name Arrays needed for on the fly basis evaluations + integer(i_def), allocatable :: basis_order(:,:) + integer(i_def), allocatable :: basis_index(:,:) + real(r_def), allocatable :: basis_vector(:,:) + real(r_def), allocatable :: basis_x(:,:,:) + real(r_def), allocatable :: basis_z(:,:) + !> @} - !> A one dimensional, allocatable array which holds a unique global index for - !> edge dofs in the 2D horizontal portion of the local domain - integer(i_def), allocatable :: global_edge_dof_id_2d(:) + !> A one dimensional, allocatable array which holds a unique global index + !> for every dof in the local domain + integer(i_halo_index), allocatable :: global_dof_id(:) - !> A one dimensional, allocatable array which holds a unique global index for - !> vertex dofs in the 2D horizontal portion of the local domain - integer(i_def), allocatable :: global_vert_dof_id_2d(:) + !> A one dimensional, allocatable array which holds a unique global index + !> for cell dofs in the 2D horizontal portion of the local domain + integer(i_def), allocatable :: global_cell_dof_id_2d(:) + + !> A one dimensional, allocatable array which holds a unique global index + !> for edge dofs in the 2D horizontal portion of the local domain + integer(i_def), allocatable :: global_edge_dof_id_2d(:) + + !> A one dimensional, allocatable array which holds a unique global index + !> for vertex dofs in the 2D horizontal portion of the local domain + integer(i_def), allocatable :: global_vert_dof_id_2d(:) + + !> The index within the dofmap of the last "owned" dof + integer(i_def) :: last_dof_owned + + !> The index within the dofmap of the last "annexed" dof + !> ("Annexed" dofs that those that are not owned, but are on owned cells) + integer(i_def) :: last_dof_annexed + + !> A one dimensional, allocatable array which holds the index in the dofmap + !> of the last of the halo dofs (from the various depths of halo) + integer(i_def), allocatable :: last_dof_halo(:) + + !> A linked list of stencil dofmaps + type(linked_list_type) :: dofmap_list + + !> Flag holds whether fields on this function space will be readonly + logical(l_def) :: readonly + + contains + + !> @brief Gets the total number of unique degrees of freedom for this space, + !> @return Integer Total number of unique degrees of freedom + procedure, public :: get_undf + + !> @brief Gets the total number of unique degrees of freedom located on + !> the 3D mesh associated with this function space. + !> @return Integer Total number of unique degrees of freedom + procedure, public :: get_ndof_glob + + !> @brief Returns the number of cells in a horizontal 2D layer + !> in the function space + !> @return Integer, Number of cells in 2D layer + procedure, public :: get_ncell + + !> @brief Returns the number of layers in the function space + !> @return Integer, Number of layers + procedure, public :: get_nlayers + + !> @brief Returns a pointer to the dofmap for the cell + !> @param[in] cell Which cell + !> @return The pointer which points to a slice of the dofmap + procedure, public :: get_cell_dofmap + + !> @brief Returns a pointer to the dofmap for all cells + !> @return The pointer which points to the cell-ordered dofmap + procedure, public :: get_whole_dofmap + + !> @brief Returns a pointer to the fractional levels in a column + !> for the function space + !> @return The pointer which points to the fractional levels array + procedure, public :: get_levels + + !> @brief Obtains the number of dofs per cell + !> @return Integer, the number of dofs per cell + procedure, public :: get_ndf + + !> @brief Obtains the number of interior dofs + !> @return Integer, the number of dofs associated with the interior of + !> each cell + procedure, public :: get_ndof_interior + + !> @brief Obtains the number of face dofs on each horizontal face + !> @return Integer, the number of dofs associated with the faces of + !> each cell + procedure, public :: get_ndof_face_h + + !> @brief Obtains the number of face dofs on each vertical face + !> @return Integer, the number of dofs associated with the faces of + !> each cell + procedure, public :: get_ndof_face_v + + !> Gets the coordinates of the function space + !> @return A pointer to the two dimensional array of nodal_coords, (xyz,ndf) + procedure, public :: get_nodes + + !> @brief Returns the enumerated integer for the functions_space which + !! is this function_space + !> @return Integer, The enumerated integer for the functions space + procedure, public :: which + + !> @brief Gets the flag (0) for dofs on bottom and top faces of element + !> @return A pointer to boundary_dofs(ndf,2) the flag for bottom (:,1) + !> and top (:,2) boundaries + procedure, public :: get_boundary_dofs + + !> @brief Calls an available function at a point + !> @param[in] function_to_call The function to call + !> @param[in] df The dof to compute the basis function of + !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function + procedure, public :: call_function + + !> @brief Evaluates the basis function at a point + !> @param[in] df The dof to compute the basis function of + !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function + procedure, private :: evaluate_basis + + !> @brief Evaluates the differential of a basis function + !> @param[in] df The dof to compute the basis function of + !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function + procedure, private :: evaluate_diff_basis + + !> @brief Evaluates the basis function for a given quadrature. + !>@deprecated has been moved to the new evaluater_type and once that is + !supported, this can be removed + !> @param[in] ndf integer number of dofs + !> @param[in] qp_h integer number of quadrature points in the horizontal + !> @param[in] qp_v integer number of quadrature points in the vertical + !> @param[in] x_qp real two dimensional array holding the x's horizontal + !> @param[in] z_qp real two dimensional array holding the x's vertical + !> @param[out] basis real 3 dimensional array holding the evaluated basis + !! functions + procedure, public :: compute_basis_function + + !> @brief Evaluates the differential basis function for a given quadrature + !>@deprecated has been moved to the new evaluater_type and once that is + !supported, this can be removed + !> @param[in] ndf integer number of dofs + !> @param[in] qp_h integer number of quadrature points in the horizontal + !> @param[in] qp_v integer number of quadrature points in the vertical + !> @param[in] x_qp real two dimensional array holding the x's horizontal + !> @param[in] z_qp real two dimensional array holding the x's vertical + !> @param[out] dbasis real 3 dimensional array holding the evaluated basis + !> functions + procedure, public :: compute_diff_basis_function + + !> @brief Gets the size of the space + !!(1 is scalar 3 is vector). Returns dim + !> @return dim The size of the space + procedure, public :: get_dim_space + + !> @brief Gets the size of the differential space + !! (1 is scalar 3 is vector). Returns dim + !> @return dim The size of the differential space + procedure, public :: get_dim_space_diff + + !> @brief Access the mesh object used to create this function space + !> @return mesh Mesh object + procedure, public :: get_mesh + + !> @brief Gets the id of the mesh object for this space + !> @return mesh_id ID of the mesh object + procedure, public :: get_mesh_id + + !> @brief Returns the horizontal element order of a function space + procedure, public :: get_element_order_h + + !> @brief Returns the vertical element order of a function space + procedure, public :: get_element_order_v + + !> @brief Returns the horizontal order of a function space + procedure, public :: get_fs_order_h + + !> @brief Returns the vertical order of a function space + procedure, public :: get_fs_order_v + + !> @brief Returns the number of data values held at each dof + procedure, public :: get_ndata + + !> Returns if the ordering of data is multi-data quickest + !> @return True if the data is ordered multi-data quickest + procedure, public :: is_ndata_first + + !> @brief Gets mapping from degree of freedom to reference element entity. + !> @return Integer array mapping degree of freedom index to geometric entity + !> on the reference element. + procedure, public :: get_entity_dofs + + !> Gets the array that holds the global indices of all dofs + procedure get_global_dof_id + + !> Gets the array that holds the global indices of all cell dofs + !> in 2D horizontal domain + procedure get_global_cell_dof_id_2d + + !> Gets the array that holds the global indices of all edge dofs + !> in 2D horizontal domain + procedure get_global_edge_dof_id_2d + + !> Gets the array that holds the global indices of all vertex dofs + !> in 2D horizontal domain + procedure get_global_vert_dof_id_2d + + !> Gets the index within the dofmap of the last "owned" dof + procedure get_last_dof_owned + + !> Gets the index within the dofmap of the last "annexed" dof + procedure get_last_dof_annexed + + !> Gets the index in the dofmap of the last dof in any depth of halo + procedure get_last_dof_halo_any - !> The index within the dofmap of the last "owned" dof - integer(i_def) :: last_dof_owned + !> Gets the index in the dofmap of the last dof in the deepest depth of halo + procedure get_last_dof_halo_deepest - !> The index within the dofmap of the last "annexed" dof - !> ("Annexed" dofs that those that are not owned, but are on owned cells) - integer(i_def) :: last_dof_annexed + generic :: get_last_dof_halo => get_last_dof_halo_any, & + get_last_dof_halo_deepest + + !> Returns whether fields on this function space are readonly + procedure, public :: is_readonly - !> A one dimensional, allocatable array which holds the index in the dofmap - !> of the last of the halo dofs (from the various depths of halo) - integer(i_def), allocatable :: last_dof_halo(:) + !> Returns whether fields on this function space can be written to + procedure, public :: is_writable - !> A linked list of stencil dofmaps - type(linked_list_type) :: dofmap_list + !> Get the instance of a stencil dofmap for a given id + procedure, public :: get_stencil_dofmap - !> Flag holds whether fields on this function space will be readonly - logical(l_def) :: readonly + !> Get the instance of a 2D stencil dofmap for a given id + procedure, public :: get_stencil_2D_dofmap -contains + ! Mesh colouring wrapper methods + !> @brief Populates args with colouring info from member mesh. + !> + !> @param[out] ncolours Number of colours used to colour member mesh. + !> @param[out] ncells_per_colour Count of cells in each colour. + !> @param[out] colour_map Indices of cells in each colour. + procedure, public :: get_colours - !> @brief Gets the total number of unique degrees of freedom for this space, - !> @return Integer Total number of unique degrees of freedom - procedure, public :: get_undf - - !> @brief Gets the total number of unique degrees of freedom located on - !> the 3D mesh associated with this function space. - !> @return Integer Total number of unique degrees of freedom - - procedure, public :: get_ndof_glob - - !> @brief Returns the number of cells in a horizontal 2D layer - !> in the function space - !> @return Integer, Number of cells in 2D layer - procedure, public :: get_ncell - - !> @brief Returns the number of layers in the function space - !> @return Integer, Number of layers - procedure, public :: get_nlayers - - !> @brief Returns a pointer to the dofmap for the cell - !> @param[in] cell Which cell - !> @return The pointer which points to a slice of the dofmap - procedure, public :: get_cell_dofmap - - !> @brief Returns a pointer to the dofmap for all cells - !> @return The pointer which points to the cell-ordered dofmap - procedure, public :: get_whole_dofmap - - !> @brief Returns a pointer to the fractional levels in a column - !> for the function space - !> @return The pointer which points to the fractional levels array - procedure, public :: get_levels - - !> @brief Obtains the number of dofs per cell - !> @return Integer, the number of dofs per cell - procedure, public :: get_ndf - !> @brief Obtains the number of interior dofs - !> @return Integer, the number of dofs associated with the interior of - !> each cell - procedure, public :: get_ndof_interior - - !> @brief Obtains the number of face dofs - !> @return Integer, the number of dofs associated with the faces of - !> each cell - procedure, public :: get_ndof_face - !> Gets the coordinates of the function space - !> @return A pointer to the two dimensional array of nodal_coords, (xyz,ndf) - procedure, public :: get_nodes - - !> @brief Returns the enumerated integer for the functions_space which - !! is this function_space - !> @return Integer, The enumerated integer for the functions space - procedure, public :: which - - !> @brief Gets the flag (0) for dofs on bottom and top faces of element - !> @return A pointer to boundary_dofs(ndf,2) the flag for bottom (:,1) - !> and top (:,2) boundaries - procedure, public :: get_boundary_dofs - - !> @brief Calls an available function at a point - !> @param[in] function_to_call The function to call - !> @param[in] df The dof to compute the basis function of - !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function - procedure, public :: call_function - - !> @brief Evaluates the basis function at a point - !> @param[in] df The dof to compute the basis function of - !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function - !> @TODO once the new quadrature object is implemented via call_function then - !> this function could be made private as its accessed from - !> call_function - procedure, public :: evaluate_basis - - !> @brief Evaluates the differential of a basis function - !> @param[in] df The dof to compute the basis function of - !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function - !> @TODO once the new quadrature object is implemented via call_function then - !> this function could be made private as its accessed from - !> call_function - procedure, public :: evaluate_diff_basis - - !> @brief Evaluates the basis function for a given quadrature. - !>@deprecated has been moved to the new evaluater_type and once that is - !supported, this can be removed - !> @param[in] ndf integer number of dofs - !> @param[in] qp_h integer number of quadrature points in the horizontal - !> @param[in] qp_v integer number of quadrature points in the vertical - !> @param[in] x_qp real two dimensional array holding the x's horizontal - !> @param[in] z_qp real two dimensional array holding the x's vertical - !> @param[out] basis real 3 dimensional array holding the evaluated basis - !! functions - procedure, public :: compute_basis_function - - !> @brief Evaluates the differential basis function for a given quadrature - !>@deprecated has been moved to the new evaluater_type and once that is - !supported, this can be removed - !> @param[in] ndf integer number of dofs - !> @param[in] qp_h integer number of quadrature points in the horizontal - !> @param[in] qp_v integer number of quadrature points in the vertical - !> @param[in] x_qp real two dimensional array holding the x's horizontal - !> @param[in] z_qp real two dimensional array holding the x's vertical - !> @param[out] dbasis real 3 dimensional array holding the evaluated basis - !> functions - procedure, public :: compute_diff_basis_function - - !> @brief Gets the size of the space - !!(1 is scalar 3 is vector). Returns dim - !> @return dim The size of the space - procedure, public :: get_dim_space - - !> @brief Gets the size of the differential space - !! (1 is scalar 3 is vector). Returns dim - !> @return dim The size of the differential space - procedure, public :: get_dim_space_diff - - !> @brief Access the mesh object used to create this function space - !> @return mesh Mesh object - procedure, public :: get_mesh - procedure, public :: get_mesh_id - - !> @brief Returns the element order of a function space - procedure, public :: get_element_order - - !> @brief Returns the order of a function space - procedure, public :: get_fs_order - - !> @brief Returns the number of data values held at each dof - procedure, public :: get_ndata - - !> @brief Gets mapping from degree of freedom to reference element entity. - !> @return Integer array mapping degree of freedom index to geometric entity - !> on the reference element. - procedure, public :: get_entity_dofs - - !> Gets the array that holds the global indices of all dofs - procedure get_global_dof_id - - !> Gets the array that holds the global indices of all cell dofs - !> in 2D horizontal domain - procedure get_global_cell_dof_id_2d - - !> Gets the array that holds the global indices of all edge dofs - !> in 2D horizontal domain - procedure get_global_edge_dof_id_2d - - !> Gets the array that holds the global indices of all vertex dofs - !> in 2D horizontal domain - procedure get_global_vert_dof_id_2d - - !> Gets the index within the dofmap of the last "owned" dof - procedure get_last_dof_owned - - !> Gets the index within the dofmap of the last "annexed" dof - procedure get_last_dof_annexed - - !> Gets the index in the dofmap of the last dof in any depth of halo - procedure get_last_dof_halo_any - - !> Gets the index in the dofmap of the last dof in the deepest depth of halo - procedure get_last_dof_halo_deepest - - generic :: get_last_dof_halo => get_last_dof_halo_any, & - get_last_dof_halo_deepest - - !> Returns whether fields on this function space are readonly - procedure, public :: is_readonly - - !> Returns whether fields on this function space can be written to - procedure, public :: is_writable - - !> Get the instance of a stencil dofmap with for a given id - procedure, public :: get_stencil_dofmap - - !> Get the instance of a 2D stencil dofmap with for a given id - procedure, public :: get_stencil_2D_dofmap - - ! Mesh colouring wrapper methods - !> @brief Populates args with colouring info from member mesh. - !> - !> @param[out] ncolours Number of colours used to colour member mesh. - !> @param[out] ncells_per_colour Count of cells in each colour. - !> @param[out] colour_map Indices of cells in each colour. - procedure, public :: get_colours + !> @brief Returns count of colours used in colouring member mesh. + !> @return Number of colours used to colour this mesh. + procedure, public :: get_ncolours - !> @brief Returns count of colours used in colouring member mesh. - !> @return Number of colours used to colour this mesh. - procedure, public :: get_ncolours + !> @brief Returns the halo depth of the function space + !> @return Halo depth + procedure, public :: get_halo_depth - procedure, public :: clear + procedure, public :: clear - procedure, public :: get_cell_orientation + !> Routine to destroy function_space_type + final :: function_space_destructor - !> Routine to destroy function_space_type - final :: function_space_destructor -end type function_space_type + end type function_space_type -interface function_space_type - module procedure fs_constructor -end interface + interface function_space_type + module procedure fs_constructor + end interface !------------------------------------------------------------------------------- ! Contained functions/subroutines !------------------------------------------------------------------------------- contains -!------------------------------------------------------------------------------- -! Returns a pointer to a function space object -!------------------------------------------------------------------------------- -!> @brief Stucture-Constructor for function_space_type object. -!> @details This constructor function returns a pointer to an instantiated -!> function space. The pointer is to a function space singleton, -!> i.e. the function space is only created on the initial call, -!> all other calls just return a pointer to the function space. -!> @param[in] mesh The mesh upon which to base this function space -!> @param[in] element_order The element order for this function space, 0 being -!> the lowest element order for function spaces defined -!> for Gungho. -!> @b Note: This is not necessarily the same as the -!> order of the function space -!> @param[in] lfric_fs The integer number indicating which of the function -!> spaces predefined for lfric to base the -!> instantiated function space on. Recognised integers -!> are assigned to the function spaces "handles" in the -!> fs_handles_mod module. -!> @param[in] ndata The number of data values to be held at each dof -!> location -!> @return A pointer to the function space held in this module -function fs_constructor(mesh, & - element_order, & - lfric_fs, & - ndata) result(instance) - - implicit none + !----------------------------------------------------------------------------- + ! Returns a pointer to a function space object + !----------------------------------------------------------------------------- + !> @brief Stucture-Constructor for function_space_type object. + !> @details This constructor function returns a pointer to an instantiated + !> function space. The pointer is to a function space singleton, + !> i.e. the function space is only created on the initial call, + !> all other calls just return a pointer to the function space. + !> @param[in] mesh The mesh upon which to base this function space + !> @param[in] element_order_h The element order for this function space in + !> the horizontal direction, 0 being the lowest + !> element order for function spaces defined for + !> Gungho. + !> @b Note: This is not necessarily the same as + !> the order of the function space + !> @param[in] element_order_v The element order for this function space in + !> the vertical direction, 0 being the lowest + !> element order for function spaces defined for + !> Gungho. + !> @b Note: This is not necessarily the same as the + !> order of the function space + !> @param[in] lfric_fs The integer number indicating which of the + !> function spaces predefined for lfric to base the + !> instantiated function space on. Recognised + !> integers are assigned to the function spaces + !> "handles" in the fs_handles_mod module. + !> @param[in] ndata The number of data values to be held at each dof + !> location + !> @param[in] ndata_first Flag to set data to be layer first (false) or + !! ndata first (true) + !> @return A pointer to the function space held in this module + function fs_constructor( mesh, & + element_order_h, & + element_order_v, & + lfric_fs, & + ndata, & + ndata_first ) result(instance) + + implicit none + + class(mesh_type), target, intent(in) :: mesh + integer(i_def), intent(in) :: element_order_h + integer(i_def), intent(in) :: element_order_v + integer(i_def), intent(in) :: lfric_fs + integer(i_def), optional, intent(in) :: ndata + logical(l_def), optional, intent(in) :: ndata_first + + type(function_space_type) :: instance + + integer(i_def) :: id + + if ( present(ndata_first) ) then + instance%ndata_first = ndata_first + else + instance%ndata_first = .false. + end if - class(mesh_type), intent(in), target :: mesh - integer(i_def), intent(in) :: element_order - integer(i_native), intent(in) :: lfric_fs - integer(i_def), optional, intent(in) :: ndata + if (present(ndata)) then + instance%ndata = ndata + else + instance%ndata = 1 + end if - type(function_space_type) :: instance + instance%mesh => mesh + instance%fs = lfric_fs + instance%element_order_h = element_order_h + instance%element_order_v = element_order_v - integer(i_def) :: ndata_sz + ! Generate unique id with mesh_id=0 since mesh_collection_mod is not used + ! in this modified example + id = generate_fs_id(lfric_fs, element_order_h, element_order_v, 0, & + instance%ndata, instance%ndata_first) + call instance%set_id(id) - if (present(ndata)) then - ndata_sz = ndata + if (lfric_fs == W0) then + instance%fs_order_h = element_order_h + 1 + instance%fs_order_v = element_order_v + 1 else - ndata_sz = 1 + instance%fs_order_h = element_order_h + instance%fs_order_v = element_order_v end if + call init_function_space(instance) - instance%mesh => mesh - instance%fs = lfric_fs - instance%element_order = element_order - instance%ndata = ndata_sz + end function fs_constructor - if (lfric_fs == W0) then - instance%fs_order = element_order + 1 - else - instance%fs_order = element_order - end if - call init_function_space( instance ) - return -end function fs_constructor + subroutine init_function_space(self) + implicit none -subroutine init_function_space( self ) + type(function_space_type), intent(inout) :: self - implicit none + integer(i_def) :: ncells_2d + integer(i_def) :: ncells_2d_with_ghost - type(function_space_type), intent(inout) :: self + integer(i_def), allocatable :: dofmap(:,:) - integer(i_def) :: ncells_2d - integer(i_def) :: ncells_2d_with_ghost + ncells_2d = self%mesh % get_ncells_2d() + ncells_2d_with_ghost = self%mesh % get_ncells_2d_with_ghost() - integer(i_def), allocatable :: dofmap(:,:) + select case (self%fs) + case (W0, WTHETA, WCHI) + self%dim_space = 1 ! Scalar field + self%dim_space_diff = 3 ! Vector field - ncells_2d = self%mesh % get_ncells_2d() - ncells_2d_with_ghost = self%mesh % get_ncells_2d_with_ghost() + case (W1) + self%dim_space = 3 ! Vector field + self%dim_space_diff = 3 ! Vector field - select case (self%fs) - case (W0, WTHETA, WCHI) - self%dim_space = 1 ! Scalar field - self%dim_space_diff = 3 ! Vector field + case (W2, W2broken, W2V, W2H, W2Hbroken) + self%dim_space = 3 ! Vector field + self%dim_space_diff = 1 ! Scalar field - case (W1) - self%dim_space = 3 ! Vector field - self%dim_space_diff = 3 ! Vector field + case (W2trace, W2Vtrace, W2Htrace, W3) + self%dim_space = 1 ! Scalar field + self%dim_space_diff = 3 ! Vector field - case (W2, W2broken, W2V, W2H) - self%dim_space = 3 ! Vector field - self%dim_space_diff = 1 ! Scalar field + case default + call log_event(& + 'Attempt to initialise unknown function space', & + LOG_LEVEL_ERROR) + + end select + + call ndof_setup ( self%mesh, & + self%element_order_h, self%element_order_v, & + self%fs, & + self%ndof_vert, & + self%ndof_edge_h, self%ndof_edge_v, & + self%ndof_face_h, self%ndof_face_v, & + self%ndof_vol, & + self%ndof_cell, & + self%ndof_glob, & + self%ndof_interior, self%ndof_exterior ) + + if (allocated(self%basis_index)) deallocate(self%basis_index) + if (allocated(self%basis_order)) deallocate(self%basis_order) + if (allocated(self%basis_vector)) deallocate(self%basis_vector) + if (allocated(self%basis_x)) deallocate(self%basis_x) + if (allocated(self%basis_z)) deallocate(self%basis_z) + if (allocated(self%nodal_coords)) deallocate(self%nodal_coords) + if (allocated(self%dof_on_vert_boundary)) & + deallocate(self%dof_on_vert_boundary) + if (allocated(self%entity_dofs)) deallocate(self%entity_dofs) + + allocate(self%basis_index( 3, self%ndof_cell )) + allocate(self%basis_order( 3, self%ndof_cell )) + allocate(self%basis_vector( self%dim_space, self%ndof_cell )) + + allocate(self%basis_x( self%element_order_h + 2, 2, self%ndof_cell )) + allocate(self%basis_z( self%element_order_v + 2, self%ndof_cell )) + allocate(self%nodal_coords( 3, self%ndof_cell )) + allocate(self%dof_on_vert_boundary ( self%ndof_cell, 2 )) + allocate(self%entity_dofs(self%ndof_cell)) + + call basis_setup( self%element_order_h, & + self%element_order_v, & + self%fs, & + self%ndof_vert, self%ndof_cell, & + self%mesh%get_reference_element(), & + self%basis_index, self%basis_order, & + self%basis_vector, self%basis_x, & + self%basis_z, & + self%nodal_coords, & + self%dof_on_vert_boundary, & + self%entity_dofs) + + ncells_2d_with_ghost = self%mesh % get_ncells_2d_with_ghost() + + allocate(dofmap( self%ndof_cell, 0:ncells_2d_with_ghost )) + + allocate(self%global_dof_id (self%ndof_glob * self%ndata)) + allocate(& + self%global_cell_dof_id_2d(self%mesh%get_last_edge_cell() * self%ndata)) + + allocate(& + self%global_edge_dof_id_2d(self%mesh%get_num_edges_owned_2d() * self%ndata)) + + allocate(& + self%global_vert_dof_id_2d(self%mesh%get_num_verts_owned_2d() * self%ndata)) + + allocate(self%last_dof_halo (0 : self%mesh % get_halo_depth())) + + call dofmap_setup ( self%mesh, & + self%fs, & + self%element_order_h, self%element_order_v, & + self%ndata, & + self%ndata_first, & + ncells_2d_with_ghost, & + self%ndof_vert, & + self%ndof_edge_h, self%ndof_edge_v, & + self%ndof_face_h, self%ndof_face_v, & + self%ndof_vol, & + self%ndof_cell, & + self%last_dof_owned, & + self%last_dof_annexed, & + self%last_dof_halo, & + dofmap, & + self%global_dof_id, & + self%global_cell_dof_id_2d, & + self%global_edge_dof_id_2d, & + self%global_vert_dof_id_2d ) + + self%master_dofmap = master_dofmap_type(dofmap) + + + ! create the linked list + self%dofmap_list = linked_list_type() + + ! Set the readonly flag for WCHI. This means routing tables don't need to be + ! set up for this function space + if(self%fs == WCHI) then + self%readonly = .true. + else + self%readonly = .false. + end if - case (W2trace, W2Vtrace, W2Htrace, W3) - self%dim_space = 1 ! Scalar field - self%dim_space_diff = 3 ! Vector field + ! Set up the fractional levels (for diagnostic output) for this fs - end select + call levels_setup( self%mesh, self%get_nlayers(), & + self%fs, self%fractional_levels ) - call ndof_setup ( self%mesh, self%element_order, self%fs & - , self%ndof_vert, self%ndof_edge, self%ndof_face & - , self%ndof_vol, self%ndof_cell, self%ndof_glob & - , self%ndof_interior, self%ndof_exterior ) + if (allocated(dofmap)) deallocate (dofmap) - if (allocated( self%basis_index )) deallocate( self%basis_index ) - if (allocated( self%basis_order )) deallocate( self%basis_order ) - if (allocated( self%basis_vector )) deallocate( self%basis_vector) - if (allocated( self%basis_x )) deallocate( self%basis_x ) - if (allocated( self%nodal_coords )) deallocate( self%nodal_coords ) - if (allocated( self%dof_on_vert_boundary )) & - deallocate(self%dof_on_vert_boundary ) - if (allocated( self%entity_dofs )) deallocate( self%entity_dofs ) + end subroutine init_function_space - allocate( self%basis_index ( 3, self%ndof_cell) ) - allocate( self%basis_order ( 3, self%ndof_cell) ) - allocate( self%basis_vector (self%dim_space, self%ndof_cell) ) - allocate( self%basis_x (self%element_order+2,3, self%ndof_cell) ) - allocate( self%nodal_coords ( 3, self%ndof_cell) ) - allocate( self%dof_on_vert_boundary (self%ndof_cell,2) ) - allocate( self%entity_dofs(self%ndof_cell) ) + !----------------------------------------------------------------------------- + ! Gets total local unique dofs for this space + !----------------------------------------------------------------------------- + integer function get_undf(self) - call basis_setup( self%element_order, self%fs, & - self%ndof_vert, self%ndof_cell, & - self%mesh%get_reference_element(), & - self%basis_index, self%basis_order, & - self%basis_vector, self%basis_x, & - self%nodal_coords, & - self%dof_on_vert_boundary, & - self%entity_dofs ) + implicit none - ncells_2d_with_ghost = self%mesh % get_ncells_2d_with_ghost() + class(function_space_type), intent(in) :: self - allocate( dofmap ( self%ndof_cell & - , 0:ncells_2d_with_ghost ) ) + get_undf = self%last_dof_halo(ubound(self%last_dof_halo,1)) - allocate( self%global_dof_id ( self%ndof_glob*self%ndata ) ) - allocate( & - self%global_cell_dof_id_2d( self%mesh%get_last_edge_cell()*self%ndata ) ) + end function get_undf - allocate( & - self%global_edge_dof_id_2d( self%mesh%get_num_edges_owned_2d()*self%ndata ) ) + !----------------------------------------------------------------------------- + ! Gets the total number of unique degrees of freedom located on + ! the 3D mesh associated with this function space. + !----------------------------------------------------------------------------- + integer function get_ndof_glob(self) - allocate( & - self%global_vert_dof_id_2d( self%mesh%get_num_verts_owned_2d()*self%ndata ) ) + implicit none - allocate( self%last_dof_halo ( self%mesh % get_halo_depth()) ) + class(function_space_type), intent(in) :: self - call dofmap_setup ( self%mesh, self%fs, self%element_order, self%ndata, & - ncells_2d_with_ghost, & - self%ndof_vert, self%ndof_edge, self%ndof_face, & - self%ndof_vol, self%ndof_cell, self%last_dof_owned, & - self%last_dof_annexed, self%last_dof_halo, dofmap, & - self%global_dof_id, & - self%global_cell_dof_id_2d, & - self%global_edge_dof_id_2d, & - self%global_vert_dof_id_2d ) + get_ndof_glob = self%ndof_glob - self%master_dofmap = master_dofmap_type( dofmap ) + end function get_ndof_glob + !----------------------------------------------------------------------------- + ! Gets the number of cells for this function space + !----------------------------------------------------------------------------- + function get_ncell(self) result(ncells_2d) - ! create the linked list - self%dofmap_list = linked_list_type() + implicit none - ! Set the readonly flag for WCHI. This means routing tables don't need to be - ! set up for this function space - if( self%fs == WCHI ) then - self%readonly=.true. - else - self%readonly=.false. - end if + class(function_space_type), intent(in) :: self + integer(i_def) :: ncells_2d - ! Set up the fractional levels (for diagnostic output) for this fs + ncells_2d = self%mesh%get_ncells_2d() - call levels_setup( self%mesh, self%get_nlayers(), & - self%fs, self%fractional_levels ) + end function get_ncell - if (allocated(dofmap)) deallocate (dofmap) - - return -end subroutine init_function_space + !----------------------------------------------------------------------------- + ! Gets the number of layers for this functions space + !----------------------------------------------------------------------------- + function get_nlayers(self) result(nlayers) -!----------------------------------------------------------------------------- -! Gets total local unique dofs for this space -!----------------------------------------------------------------------------- -integer function get_undf(self) - implicit none + implicit none - class(function_space_type), intent(in) :: self + class(function_space_type), intent(in) :: self + integer(i_def) :: nlayers - get_undf = self%last_dof_halo(size(self%last_dof_halo)) + nlayers = self%mesh%get_nlayers() - return -end function get_undf + end function get_nlayers -!----------------------------------------------------------------------------- -! Gets the total number of unique degrees of freedom located on -! the 3D mesh associated with this function space. -!----------------------------------------------------------------------------- -integer function get_ndof_glob(self) - implicit none + !----------------------------------------------------------------------------- + ! Gets the number of dofs for a single cell + !----------------------------------------------------------------------------- + function get_ndf(self) result(ndof_cell) - class(function_space_type), intent(in) :: self + implicit none - get_ndof_glob = self%ndof_glob + class(function_space_type), intent(in) :: self + integer(i_def) :: ndof_cell - return -end function get_ndof_glob + ndof_cell = self%ndof_cell -!----------------------------------------------------------------------------- -! Gets the number of cells for this function space -!----------------------------------------------------------------------------- -function get_ncell(self) result(ncells_2d) + end function get_ndf + !----------------------------------------------------------------------------- + ! Gets the number of interior dofs for a single cell + !----------------------------------------------------------------------------- + function get_ndof_interior(self) result(ndof_interior) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ncells_2d + implicit none - ncells_2d = self%mesh%get_ncells_2d() + class(function_space_type), intent(in) :: self + integer(i_def) :: ndof_interior - return -end function get_ncell + ndof_interior = self%ndof_interior -!----------------------------------------------------------------------------- -! Gets the number of layers for this functions space -!----------------------------------------------------------------------------- -function get_nlayers(self) result(nlayers) + end function get_ndof_interior - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: nlayers + !----------------------------------------------------------------------------- + ! Gets the number of horizontal face dofs for a single cell + !----------------------------------------------------------------------------- + function get_ndof_face_h(self) result(ndof_face_h) - nlayers = self%mesh%get_nlayers() + implicit none - return -end function get_nlayers + class(function_space_type), intent(in) :: self + integer(i_def) :: ndof_face_h -!----------------------------------------------------------------------------- -! Gets the number of dofs for a single cell -!----------------------------------------------------------------------------- -function get_ndf(self) result(ndof_cell) + ndof_face_h = self%ndof_face_h - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ndof_cell + end function get_ndof_face_h - ndof_cell= self%ndof_cell + !----------------------------------------------------------------------------- + ! Gets the number of vertical face dofs for a single cell + !----------------------------------------------------------------------------- + function get_ndof_face_v(self) result(ndof_face_v) - return -end function get_ndf -!----------------------------------------------------------------------------- -! Gets the number of interior dofs for a single cell -!----------------------------------------------------------------------------- -function get_ndof_interior(self) result(ndof_interior) + implicit none - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ndof_interior + class(function_space_type), intent(in) :: self + integer(i_def) :: ndof_face_v - ndof_interior = self%ndof_interior + ndof_face_v = self%ndof_face_v - return -end function get_ndof_interior + end function get_ndof_face_v -!----------------------------------------------------------------------------- -! Gets the number of face dofs for a single cell -!----------------------------------------------------------------------------- -function get_ndof_face(self) result(ndof_face) + !----------------------------------------------------------------------------- + ! Gets the dofmap for a single cell + !----------------------------------------------------------------------------- + function get_cell_dofmap(self, cell_lid) result(map) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ndof_face + implicit none - ndof_face = self%ndof_face + class(function_space_type), target, intent(in) :: self + integer(i_def), intent(in) :: cell_lid + integer(i_def), pointer :: map(:) - return -end function get_ndof_face + map => self%master_dofmap%get_master_dofmap(cell_lid) -!----------------------------------------------------------------------------- -! Gets the dofmap for a single cell -!----------------------------------------------------------------------------- -function get_cell_dofmap(self,cell_lid) result(map) + end function get_cell_dofmap - implicit none - class(function_space_type), target, intent(in) :: self - integer(i_def), intent(in) :: cell_lid - integer(i_def), pointer :: map(:) + !----------------------------------------------------------------------------- + ! Gets the dofmap for the whole domain + !----------------------------------------------------------------------------- + function get_whole_dofmap(self) result(map) - map => self%master_dofmap%get_master_dofmap(cell_lid) - return -end function get_cell_dofmap + implicit none -!----------------------------------------------------------------------------- -! Gets the dofmap for the whole domain -!----------------------------------------------------------------------------- -function get_whole_dofmap(self) result(map) + class(function_space_type), target, intent(in) :: self + integer(i_def), pointer :: map(:,:) - implicit none - class(function_space_type), target, intent(in) :: self - integer(i_def), pointer :: map(:,:) + map => self%master_dofmap%get_whole_master_dofmap() - map => self%master_dofmap%get_whole_master_dofmap() - return -end function get_whole_dofmap + end function get_whole_dofmap -!----------------------------------------------------------------------------- -! Gets the fractional levels for a column in this function space -!----------------------------------------------------------------------------- -function get_levels(self) result(levels) + !----------------------------------------------------------------------------- + ! Gets the fractional levels for a column in this function space + !----------------------------------------------------------------------------- + function get_levels(self) result(levels) - implicit none - class(function_space_type), target, intent(in) :: self - real(r_def), pointer :: levels(:) + implicit none - levels => self%fractional_levels - return -end function get_levels + class(function_space_type), target, intent(in) :: self + real(r_def), pointer :: levels(:) -!----------------------------------------------------------------------------- -! Gets the nodal coordinates of the function_space -!----------------------------------------------------------------------------- -function get_nodes(self) result(nodal_coords) + levels => self%fractional_levels - implicit none - class(function_space_type), target, intent(in) :: self + end function get_levels - real(r_def), pointer :: nodal_coords(:,:) + !----------------------------------------------------------------------------- + ! Gets the nodal coordinates of the function_space + !----------------------------------------------------------------------------- + function get_nodes(self) result(nodal_coords) - nodal_coords => self%nodal_coords + implicit none - return -end function get_nodes + class(function_space_type), target, intent(in) :: self -!----------------------------------------------------------------------------- -! Gets a flag for dofs on vertical boundaries -!----------------------------------------------------------------------------- -function get_boundary_dofs(self) result(boundary_dofs) + real(r_def), pointer :: nodal_coords(:,:) - implicit none - class(function_space_type), target, intent(in) :: self + nodal_coords => self%nodal_coords - integer(i_def), pointer :: boundary_dofs(:,:) + end function get_nodes - boundary_dofs => self%dof_on_vert_boundary(:,:) + !----------------------------------------------------------------------------- + ! Gets a flag for dofs on vertical boundaries + !----------------------------------------------------------------------------- + function get_boundary_dofs(self) result(boundary_dofs) - return -end function get_boundary_dofs + implicit none -!----------------------------------------------------------------------------- -! Gets enumerated integer for the function space -!----------------------------------------------------------------------------- -function which(self) result(fs) + class(function_space_type), target, intent(in) :: self - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: fs + integer(i_def), pointer :: boundary_dofs(:,:) - fs = self%fs + boundary_dofs => self%dof_on_vert_boundary(:,:) - return -end function which + end function get_boundary_dofs -!----------------------------------------------------------------------------- -! Gets the size of the function space -!----------------------------------------------------------------------------- -function get_dim_space(self) result(dim) + !----------------------------------------------------------------------------- + ! Gets enumerated integer for the function space + !----------------------------------------------------------------------------- + function which(self) result(fs) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: dim + implicit none - dim = self%dim_space + class(function_space_type), intent(in) :: self + integer(i_def) :: fs - return -end function get_dim_space + fs = self%fs -!----------------------------------------------------------------------------- -! Gets the size of the differential function space -!----------------------------------------------------------------------------- -function get_dim_space_diff(self) result(dim) + end function which - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: dim + !----------------------------------------------------------------------------- + ! Gets the size of the function space + !----------------------------------------------------------------------------- + function get_dim_space(self) result(dim) - dim = self%dim_space_diff + implicit none - return -end function get_dim_space_diff + class(function_space_type), intent(in) :: self + integer(i_def) :: dim -!----------------------------------------------------------------------------- -! Evaluates one of the listed (function_to_call) functions -!----------------------------------------------------------------------------- -function call_function(self, function_to_call, df, xi) result(evaluate) + dim = self%dim_space - implicit none + end function get_dim_space - class(function_space_type) :: self - integer(i_def), intent(in) :: function_to_call - integer(i_def), intent(in) :: df - real(r_def), intent(in) :: xi(3) - real(r_def), allocatable :: evaluate(:) + !----------------------------------------------------------------------------- + ! Gets the size of the diferential function space + !----------------------------------------------------------------------------- + function get_dim_space_diff(self) result(dim) - select case ( function_to_call ) + implicit none - case( BASIS ) - allocate( evaluate(self%dim_space) ) + class(function_space_type), intent(in) :: self + integer(i_def) :: dim + + dim = self%dim_space_diff + + end function get_dim_space_diff + + !----------------------------------------------------------------------------- + ! Evaluates one of the listed (function_to_call) functions + !----------------------------------------------------------------------------- + function call_function(self, function_to_call, df, xi) result(evaluate) + + implicit none + + class(function_space_type) :: self + integer(i_def), intent(in) :: function_to_call + integer(i_def), intent(in) :: df + real(r_def), intent(in) :: xi(3) + real(r_def), allocatable :: evaluate(:) + + select case (function_to_call) + case(BASIS) + allocate(evaluate(self%dim_space)) evaluate = evaluate_basis(self, df, xi) - case( DIFF_BASIS ) - allocate( evaluate(self%dim_space_diff) ) + case(DIFF_BASIS) + allocate(evaluate(self%dim_space_diff)) evaluate = evaluate_diff_basis(self, df, xi) case default - call log_event( & + call log_event(& 'function_to_call does not match the available enumerators', & - LOG_LEVEL_ERROR ) + LOG_LEVEL_ERROR) - end select + end select -end function call_function + end function call_function -!----------------------------------------------------------------------------- -! Evaluates a basis function at a point -!----------------------------------------------------------------------------- -function evaluate_basis(self, df, xi) result(p) + !----------------------------------------------------------------------------- + ! Evaluates a basis function at a point + !----------------------------------------------------------------------------- + function evaluate_basis(self, df, xi) result(p) - use polynomial_mod, only: poly1d + use polynomial_mod, only : poly1d - implicit none + implicit none - class(function_space_type), intent(in) :: self + class(function_space_type), intent(in) :: self - integer(i_def), intent(in) :: df - real(r_def), intent(in) :: xi(3) - real(r_def) :: p(self%dim_space) + integer(i_def), intent(in) :: df + real(r_def), intent(in) :: xi(3) + real(r_def) :: p(self%dim_space) - p(:) = poly1d( self%basis_order(1,df), xi(1), self%basis_x(:,1,df), self%basis_index(1,df)) & - * poly1d( self%basis_order(2,df), xi(2), self%basis_x(:,2,df), self%basis_index(2,df)) & - * poly1d( self%basis_order(3,df), xi(3), self%basis_x(:,3,df), self%basis_index(3,df)) & - * self%basis_vector(:,df) + p(:) = poly1d(self%basis_order(1, df), xi(1), self%basis_x(:, 1, df), self%basis_index(1, df)) & + * poly1d(self%basis_order(2, df), xi(2), self%basis_x(:, 2, df), self%basis_index(2, df)) & + * poly1d(self%basis_order(3, df), xi(3), self%basis_z(:, df), self%basis_index(3, df)) & + * self%basis_vector(:, df) -end function evaluate_basis + end function evaluate_basis -!----------------------------------------------------------------------------- -! Evaluates the differential of a basis function at a point -!----------------------------------------------------------------------------- -pure function evaluate_diff_basis(self, df, xi) result(evaluate) + !----------------------------------------------------------------------------- + ! Evaluates the differential of a basis function at a point + !----------------------------------------------------------------------------- + pure function evaluate_diff_basis(self, df, xi) result(evaluate) - use polynomial_mod, only: poly1d, poly1d_deriv + use polynomial_mod, only : poly1d, poly1d_deriv - implicit none + implicit none - class(function_space_type), intent(in) :: self - - integer(i_def), intent(in) :: df - real(r_def), intent(in) :: xi(3) - real(r_def) :: evaluate(self%dim_space_diff) - real(r_def) :: dpdx(3) - - dpdx(1) = poly1d_deriv( self%basis_order(1,df), xi(1) & - , self%basis_x(:,1,df), self%basis_index(1,df)) & - * poly1d ( self%basis_order(2,df), xi(2) & - , self%basis_x(:,2,df), self%basis_index(2,df)) & - * poly1d ( self%basis_order(3,df), xi(3) & - , self%basis_x(:,3,df), self%basis_index(3,df)) - - dpdx(2) = poly1d ( self%basis_order(1,df), xi(1) & - , self%basis_x(:,1,df), self%basis_index(1,df)) & - * poly1d_deriv( self%basis_order(2,df), xi(2) & - , self%basis_x(:,2,df), self%basis_index(2,df)) & - * poly1d ( self%basis_order(3,df), xi(3) & - , self%basis_x(:,3,df), self%basis_index(3,df)) - - dpdx(3) = poly1d ( self%basis_order(1,df), xi(1) & - , self%basis_x(:,1,df), self%basis_index(1,df)) & - * poly1d ( self%basis_order(2,df), xi(2) & - , self%basis_x(:,2,df), self%basis_index(2,df)) & - * poly1d_deriv( self%basis_order(3,df), xi(3) & - , self%basis_x(:,3,df), self%basis_index(3,df)) - - - if ( self%dim_space == 1 .and. self%dim_space_diff == 3 ) then - ! grad(p) - evaluate(1) = dpdx(1) - evaluate(2) = dpdx(2) - evaluate(3) = dpdx(3) - else if ( self%dim_space == 3 .and. self%dim_space_diff == 3 ) then - ! curl(p) - evaluate(1) = dpdx(2)*self%basis_vector(3,df) - dpdx(3)*self%basis_vector(2,df) - evaluate(2) = dpdx(3)*self%basis_vector(1,df) - dpdx(1)*self%basis_vector(3,df) - evaluate(3) = dpdx(1)*self%basis_vector(2,df) - dpdx(2)*self%basis_vector(1,df) - else if ( self%dim_space == 3 .and. self%dim_space_diff == 1 ) then - ! div(p) - evaluate(1) = dpdx(1)*self%basis_vector(1,df) + dpdx(2)*self%basis_vector(2,df) & - + dpdx(3)*self%basis_vector(3,df) - else if ( self%dim_space == 1 .and. self%dim_space_diff == 1 ) then - ! dp/dz - evaluate(1) = dpdx(3) - else - evaluate(:) = 0.0_r_def - end if - -end function evaluate_diff_basis + class(function_space_type), intent(in) :: self -!----------------------------------------------------------------------------- -! Evaluates the basis function for a given quadrature -!----------------------------------------------------------------------------- -subroutine compute_basis_function(self, basis, ndf, qp_h, qp_v, x_qp, z_qp) + integer(i_def), intent(in) :: df + real(r_def), intent(in) :: xi(3) + real(r_def) :: evaluate(self%dim_space_diff) + real(r_def) :: dpdx(3) - implicit none + dpdx(1) = poly1d_deriv(self%basis_order(1, df), xi(1), self%basis_x(:, 1, df), self%basis_index(1, df)) & + * poly1d (self%basis_order(2, df), xi(2), self%basis_x(:, 2, df), self%basis_index(2, df)) & + * poly1d (self%basis_order(3, df), xi(3), self%basis_z(:, df), self%basis_index(3, df)) + + dpdx(2) = poly1d (self%basis_order(1, df), xi(1), self%basis_x(:, 1, df), self%basis_index(1, df)) & + * poly1d_deriv(self%basis_order(2, df), xi(2), self%basis_x(:, 2, df), self%basis_index(2, df)) & + * poly1d (self%basis_order(3, df), xi(3), self%basis_z(:, df), self%basis_index(3, df)) + + dpdx(3) = poly1d (self%basis_order(1, df), xi(1), self%basis_x(:, 1, df), self%basis_index(1, df)) & + * poly1d (self%basis_order(2, df), xi(2), self%basis_x(:, 2, df), self%basis_index(2, df)) & + * poly1d_deriv(self%basis_order(3, df), xi(3), self%basis_z(:, df), self%basis_index(3, df)) + + if (self%dim_space == 1 .and. self%dim_space_diff == 3) then + ! grad(p) + evaluate(1) = dpdx(1) + evaluate(2) = dpdx(2) + evaluate(3) = dpdx(3) + else if (self%dim_space == 3 .and. self%dim_space_diff == 3) then + ! curl(p) + evaluate(1) = dpdx(2) * self%basis_vector(3, df) & + - dpdx(3) * self%basis_vector(2, df) + evaluate(2) = dpdx(3) * self%basis_vector(1, df) & + - dpdx(1) * self%basis_vector(3, df) - class(function_space_type), intent(in) :: self + evaluate(3) = dpdx(1) * self%basis_vector(2, df) & + - dpdx(2) * self%basis_vector(1, df) - integer(i_def), intent(in) :: ndf - integer(i_def), intent(in) :: qp_h - integer(i_def), intent(in) :: qp_v + else if (self%dim_space == 3 .and. self%dim_space_diff == 1) then + ! div(p) + evaluate(1) = dpdx(1) * self%basis_vector(1, df) & + + dpdx(2) * self%basis_vector(2, df) & + + dpdx(3) * self%basis_vector(3, df) + + else if (self%dim_space == 1 .and. self%dim_space_diff == 1) then + ! dp/dz + evaluate(1) = dpdx(3) + else + evaluate(:) = 0.0_r_def + end if - real(r_def), intent(in) :: x_qp (qp_h,2) - real(r_def), intent(in) :: z_qp (qp_v) + end function evaluate_diff_basis - real(r_def), intent(out) :: basis(self%dim_space,ndf,qp_h,qp_v) + !----------------------------------------------------------------------------- + ! Evaluates the basis function for a given quadrature + !----------------------------------------------------------------------------- + subroutine compute_basis_function(self, basis, ndf, qp_h, qp_v, x_qp, z_qp) - ! Local variables - loop counters - integer(i_def) :: df - integer(i_def) :: qp1 - integer(i_def) :: qp2 - real(r_def) :: xyz(3) + implicit none - do qp2=1, qp_v - xyz(3) = z_qp(qp2) - do qp1=1, qp_h - xyz(1) = x_qp(qp1,1) - xyz(2) = x_qp(qp1,2) - do df=1, ndf - basis(:,df,qp1,qp2) = self%evaluate_basis(df,xyz) + class(function_space_type), intent(in) :: self + + integer(i_def), intent(in) :: ndf + integer(i_def), intent(in) :: qp_h + integer(i_def), intent(in) :: qp_v + + real(r_def), intent(in) :: x_qp (qp_h, 2) + real(r_def), intent(in) :: z_qp (qp_v) + + real(r_def), intent(out) :: basis( self%dim_space, ndf, qp_h, qp_v ) + + ! Local variables - loop counters + integer(i_def) :: df + integer(i_def) :: qp1 + integer(i_def) :: qp2 + real(r_def) :: xyz(3) + + do qp2 = 1, qp_v + xyz(3) = z_qp(qp2) + do qp1 = 1, qp_h + xyz(1) = x_qp( qp1, 1 ) + xyz(2) = x_qp( qp1, 2 ) + do df = 1, ndf + basis(:, df, qp1, qp2) = self%evaluate_basis( df, xyz ) + end do + end do + end do + + end subroutine compute_basis_function + + !----------------------------------------------------------------------------- + ! Evaluates the differential basis function for a given quadrature + !----------------------------------------------------------------------------- + subroutine compute_diff_basis_function( self, & + dbasis, & + ndf, & + qp_h, & + qp_v, & + x_qp, & + z_qp ) + + implicit none + + class(function_space_type), intent(in) :: self + + integer(i_def), intent(in) :: ndf + integer(i_def), intent(in) :: qp_h + integer(i_def), intent(in) :: qp_v + + real(r_def), intent(in) :: x_qp(qp_h, 2) + real(r_def), intent(in) :: z_qp(qp_v) + + real(r_def), intent(out) :: dbasis( self%dim_space_diff, ndf, qp_h, qp_v ) + + ! local variables - loop counters + integer(i_def) :: df + integer(i_def) :: qp1 + integer(i_def) :: qp2 + real(r_def) :: xyz(3) + + do qp2 = 1, qp_v + xyz(3) = z_qp(qp2) + do qp1 = 1, qp_h + xyz(1) = x_qp( qp1, 1 ) + xyz(2) = x_qp( qp1, 2 ) + do df = 1, ndf + dbasis( :, df, qp1, qp2 ) = self%evaluate_diff_basis( df, xyz ) end do - end do - end do + end do + end do -end subroutine compute_basis_function + end subroutine compute_diff_basis_function -!----------------------------------------------------------------------------- -! Evaluates the differential basis function for a given quadrature -!----------------------------------------------------------------------------- -subroutine compute_diff_basis_function(self, & - dbasis, & - ndf, & - qp_h, & - qp_v, & - x_qp, & - z_qp) + !----------------------------------------------------------------------------- + ! Gets order for this space in the horizontal direction + !----------------------------------------------------------------------------- + !> @brief Gets the polynomial order for this space, returns an integer + !> @param[in] self the calling function space + !----------------------------------------------------------------------------- + function get_element_order_h(self) result (element_order_h) + implicit none - implicit none + class(function_space_type), intent(in) :: self + integer(i_def) :: element_order_h - class(function_space_type), intent(in) :: self + element_order_h = self%element_order_h - integer(i_def), intent(in) :: ndf - integer(i_def), intent(in) :: qp_h - integer(i_def), intent(in) :: qp_v + end function get_element_order_h - real(r_def), intent(in) :: x_qp(qp_h,2) - real(r_def), intent(in) :: z_qp(qp_v) + !----------------------------------------------------------------------------- + ! Gets order for this space in the vertical direction + !----------------------------------------------------------------------------- + !> @brief Gets the polynomial order for this space, returns an integer + !> @param[in] self the calling function space + !----------------------------------------------------------------------------- + function get_element_order_v(self) result (element_order_v) - real(r_def), intent(out) :: dbasis(self%dim_space_diff, ndf, qp_h, qp_v) + implicit none - ! local variables - loop counters - integer(i_def) :: df - integer(i_def) :: qp1 - integer(i_def) :: qp2 - real(r_def) :: xyz(3) + class(function_space_type), intent(in) :: self + integer(i_def) :: element_order_v - do qp2=1, qp_v - xyz(3) = z_qp(qp2) - do qp1=1, qp_h - xyz(1) = x_qp(qp1,1) - xyz(2) = x_qp(qp1,2) - do df=1, ndf - dbasis(:,df,qp1,qp2) = self%evaluate_diff_basis(df,xyz) - end do - end do - end do + element_order_v = self%element_order_v -end subroutine compute_diff_basis_function + end function get_element_order_v -!----------------------------------------------------------------------------- -! Gets order for this space -!----------------------------------------------------------------------------- -!> @brief Gets the polynomial order for this space, returns an integer -!> @param[in] self the calling function space -!----------------------------------------------------------------------------- -function get_element_order(self) result (element_order) + !----------------------------------------------------------------------------- + !> @details Gets the order for this function space in the horizontal direction + !> @return The order of the function space + function get_fs_order_h(self) result (fs_order_h) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: element_order + implicit none - element_order = self%element_order + class(function_space_type), intent(in) :: self + integer(i_def) :: fs_order_h - return -end function get_element_order + fs_order_h = self%fs_order_h -!----------------------------------------------------------------------------- -!> @details Gets the order for this function space -!> @return The order of the function space -function get_fs_order(self) result (fs_order) + end function get_fs_order_h - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: fs_order + !----------------------------------------------------------------------------- + !> @details Gets the order for this function space in the vertical direction + !> @return The order of the function space + function get_fs_order_v(self) result (fs_order_v) - fs_order = self%fs_order + implicit none - return -end function get_fs_order + class(function_space_type), intent(in) :: self + integer(i_def) :: fs_order_v -!----------------------------------------------------------------------------- -!> @details Gets the number of data values held at each dof -!> @return The number of data values held at each dof -function get_ndata(self) result (ndata) + fs_order_v = self%fs_order_v - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ndata + end function get_fs_order_v - ndata = self%ndata + !----------------------------------------------------------------------------- + !> @details Gets the number of data values held at each dof + !> @return The number of data values held at each dof + function get_ndata(self) result (ndata) - return -end function get_ndata + implicit none -!----------------------------------------------------------------------------- -! Gets the mapping from degrees of freedom to reference -! element entity. -!----------------------------------------------------------------------------- -function get_entity_dofs(self) result (entity_dofs) + class(function_space_type), intent(in) :: self + integer(i_def) :: ndata - implicit none + ndata = self%ndata - class(function_space_type), target, intent(in) :: self - integer(i_def), pointer :: entity_dofs(:) + end function get_ndata - entity_dofs => self%entity_dofs(:) + !> Returns whether the field data is ordered multi-data first + !> + !> @return Flag for if field data order is multi-data first + function is_ndata_first(self) result(flag) - return -end function get_entity_dofs + implicit none -!----------------------------------------------------------------------------- -! Gets mesh object for this space -!----------------------------------------------------------------------------- -!> @brief Gets the mesh object for this space -!> @param[in] self the calling function space -!> @return mesh Mesh Object -!----------------------------------------------------------------------------- -function get_mesh(self) result (mesh) + class(function_space_type), intent(in) :: self + logical(l_def) :: flag - implicit none + flag = self%ndata_first - class(function_space_type), intent(in) :: self - type(mesh_type), pointer :: mesh + end function is_ndata_first - mesh => self%mesh + !----------------------------------------------------------------------------- + ! Gets the mapping from degrees of freedom to reference + ! element entity. + !----------------------------------------------------------------------------- + function get_entity_dofs(self) result (entity_dofs) -end function get_mesh + implicit none -!----------------------------------------------------------------------------- -! Get id of mesh object for this space -!----------------------------------------------------------------------------- -!> @brief Gets the id of the mesh object for this space -!> @param[in] self the calling function space -!> @return mesh_id -!----------------------------------------------------------------------------- -function get_mesh_id(self) result (mesh_id) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: mesh_id + class(function_space_type), target, intent(in) :: self + integer(i_def), pointer :: entity_dofs(:) - mesh_id = self%mesh%get_id() + entity_dofs => self%entity_dofs(:) - return -end function get_mesh_id + end function get_entity_dofs -!----------------------------------------------------------------------------- -! Gets the array that holds the global indices of all dofs -!----------------------------------------------------------------------------- -subroutine get_global_dof_id(self, global_dof_id) + !----------------------------------------------------------------------------- + ! Gets mesh object for this space + !----------------------------------------------------------------------------- + !> @brief Gets the mesh object for this space + !> @param[in] self the calling function space + !> @return mesh Mesh Object + !----------------------------------------------------------------------------- + function get_mesh(self) result (mesh) - implicit none - class(function_space_type) :: self + implicit none - integer(i_halo_index) :: global_dof_id(:) + class(function_space_type), intent(in) :: self + type(mesh_type), pointer :: mesh - global_dof_id(:) = self%global_dof_id(:) + if ( associated (self%mesh) ) then + mesh => self%mesh + else + call log_event('Function space has null pointer to mesh!!!', log_level_error) + end if - return -end subroutine get_global_dof_id + end function get_mesh -!----------------------------------------------------------------------------- -! Gets the array that holds the global indices of cell dofs in 2D -! Horizontal domain -!----------------------------------------------------------------------------- -subroutine get_global_cell_dof_id_2d(self, global_cell_dof_id_2d) + !----------------------------------------------------------------------------- + ! Get id of mesh object for this space + !----------------------------------------------------------------------------- + !> @brief Gets the id of the mesh object for this space + !> @param[in] self the calling function space + !> @return mesh_id + !----------------------------------------------------------------------------- + function get_mesh_id(self) result (mesh_id) - implicit none - class(function_space_type), intent(in) :: self + implicit none - integer(i_def), intent(out) :: global_cell_dof_id_2d(:) + class(function_space_type), intent(in) :: self + integer(i_def) :: mesh_id - global_cell_dof_id_2d(:) = self%global_cell_dof_id_2d(:) + mesh_id = self%mesh%get_id() - return -end subroutine get_global_cell_dof_id_2d + end function get_mesh_id -!----------------------------------------------------------------------------- -! Gets the array that holds the global indices of edge dofs in 2D -! Horizontal domain -!----------------------------------------------------------------------------- -subroutine get_global_edge_dof_id_2d(self, global_edge_dof_id_2d) + !----------------------------------------------------------------------------- + ! Gets the array that holds the global indices of all dofs + !----------------------------------------------------------------------------- + function get_global_dof_id(self) result(global_dof_id) - implicit none - class(function_space_type), intent(in) :: self + implicit none - integer(i_def), intent(out) :: global_edge_dof_id_2d(:) + class(function_space_type), target, intent(in) :: self - global_edge_dof_id_2d(:) = self%global_edge_dof_id_2d(:) + integer(i_halo_index), pointer :: global_dof_id(:) - return -end subroutine get_global_edge_dof_id_2d + global_dof_id => self%global_dof_id(:) -!----------------------------------------------------------------------------- -! Gets the array that holds the global indices of vertex dofs in 2D -! Horizontal domain -!----------------------------------------------------------------------------- -subroutine get_global_vert_dof_id_2d(self, global_vert_dof_id_2d) + end function get_global_dof_id - implicit none - class(function_space_type), intent(in) :: self + !----------------------------------------------------------------------------- + ! Gets the array that holds the global indices of cell dofs in 2D + ! Horizontal domain + !----------------------------------------------------------------------------- + subroutine get_global_cell_dof_id_2d(self, global_cell_dof_id_2d) - integer(i_def), intent(out) :: global_vert_dof_id_2d(:) + implicit none - global_vert_dof_id_2d(:) = self%global_vert_dof_id_2d(:) + class(function_space_type), intent(in) :: self - return -end subroutine get_global_vert_dof_id_2d + integer(i_def), intent(out) :: global_cell_dof_id_2d(:) -!----------------------------------------------------------------------------- -! Gets the index within the dofmap of the last "owned" dof -!----------------------------------------------------------------------------- -function get_last_dof_owned(self) result (last_dof_owned) + global_cell_dof_id_2d(:) = self%global_cell_dof_id_2d(:) - implicit none - class(function_space_type) :: self + end subroutine get_global_cell_dof_id_2d - integer(i_def) :: last_dof_owned + !----------------------------------------------------------------------------- + ! Gets the array that holds the global indices of edge dofs in 2D + ! Horizontal domain + !----------------------------------------------------------------------------- + subroutine get_global_edge_dof_id_2d(self, global_edge_dof_id_2d) - last_dof_owned = self%last_dof_owned + implicit none - return -end function get_last_dof_owned + class(function_space_type), intent(in) :: self -!----------------------------------------------------------------------------- -! Gets the index within the dofmap of the last "annexed" dof -!----------------------------------------------------------------------------- -function get_last_dof_annexed(self) result (last_dof_annexed) + integer(i_def), intent(out) :: global_edge_dof_id_2d(:) - implicit none - class(function_space_type) :: self + global_edge_dof_id_2d(:) = self%global_edge_dof_id_2d(:) - integer(i_def) :: last_dof_annexed + end subroutine get_global_edge_dof_id_2d - last_dof_annexed = self%last_dof_annexed + !----------------------------------------------------------------------------- + ! Gets the array that holds the global indices of vertex dofs in 2D + ! Horizontal domain + !----------------------------------------------------------------------------- + subroutine get_global_vert_dof_id_2d(self, global_vert_dof_id_2d) - return -end function get_last_dof_annexed + implicit none -!----------------------------------------------------------------------------- -! Gets the index within the dofmap of the last dof in the specified halo -!----------------------------------------------------------------------------- -function get_last_dof_halo_any(self, depth) result (last_dof_halo) + class(function_space_type), intent(in) :: self - implicit none - class(function_space_type) :: self - integer(i_def), intent(in) :: depth + integer(i_def), intent(out) :: global_vert_dof_id_2d(:) - integer(i_def) :: last_dof_halo + global_vert_dof_id_2d(:) = self%global_vert_dof_id_2d(:) - last_dof_halo = self%last_dof_halo(depth) + end subroutine get_global_vert_dof_id_2d - return -end function get_last_dof_halo_any + !----------------------------------------------------------------------------- + ! Gets the index within the dofmap of the last "owned" dof + !----------------------------------------------------------------------------- + function get_last_dof_owned(self) result (last_dof_owned) -!----------------------------------------------------------------------------- -! Gets the index within the dofmap of the last dof in the deepest halo -!----------------------------------------------------------------------------- -function get_last_dof_halo_deepest(self) result (last_dof_halo) - implicit none - class(function_space_type) :: self + implicit none - integer(i_def) :: last_dof_halo + class(function_space_type) :: self - last_dof_halo = self%last_dof_halo(size(self%last_dof_halo)) + integer(i_def) :: last_dof_owned - return -end function get_last_dof_halo_deepest + last_dof_owned = self%last_dof_owned + end function get_last_dof_owned -!> @brief Returns whether fields on this function space are readonly -!> @return return_readonly Flag describes if fields on this function space -!> will be readonly -function is_readonly(self) result(return_readonly) - implicit none + !----------------------------------------------------------------------------- + ! Gets the index within the dofmap of the last "annexed" dof + !----------------------------------------------------------------------------- + function get_last_dof_annexed(self) result (last_dof_annexed) - class(function_space_type), intent(in) :: self - logical(l_def) :: return_readonly + implicit none - return_readonly = self%readonly + class(function_space_type) :: self -end function is_readonly + integer(i_def) :: last_dof_annexed + last_dof_annexed = self%last_dof_annexed -!> @brief Returns whether fields on this function space can be written to -!> @return return_writable Flag describes if fields on this function space -!> can be written to -function is_writable(self) result(return_writable) - implicit none + end function get_last_dof_annexed - class(function_space_type), intent(in) :: self - logical(l_def) :: return_writable + !----------------------------------------------------------------------------- + ! Gets the index within the dofmap of the last dof in the specified halo + !----------------------------------------------------------------------------- + function get_last_dof_halo_any(self, depth) result (last_dof_halo) - return_writable = .not.self%readonly + implicit none -end function is_writable + class(function_space_type) :: self + integer(i_def), intent(in) :: depth -!> @brief Get the instance of a stencil dofmap for a given shape and size -!> @param[in] stencil_shape The shape identifier for the stencil dofmap to create -!> @param[in] stencil_extent The extent of the stencil excluding the centre cell -!> @return map the stencil_dofmap object to return -function get_stencil_dofmap(self, stencil_shape, stencil_extent) result(map) - use stencil_dofmap_mod, only: stencil_dofmap_type + integer(i_def) :: last_dof_halo - implicit none + last_dof_halo = self%last_dof_halo(depth) - class(function_space_type), intent(inout) :: self - integer(i_def), intent(in) :: stencil_shape - integer(i_def), intent(in) :: stencil_extent - type(stencil_dofmap_type), pointer :: map ! return value + end function get_last_dof_halo_any - type(linked_list_item_type), pointer :: loop => null() + !----------------------------------------------------------------------------- + ! Gets the index within the dofmap of the last dof in the deepest halo + !----------------------------------------------------------------------------- + function get_last_dof_halo_deepest(self) result (last_dof_halo) - integer(i_def) :: id + implicit none - map => null() + class(function_space_type) :: self - ! Calculate id of the stencil_dofmap we want - id = generate_stencil_dofmap_id( stencil_shape, stencil_extent ) + integer(i_def) :: last_dof_halo + last_dof_halo = self%last_dof_halo(ubound(self%last_dof_halo,1)) - ! point at the head of the stencil_dofmap linked list - loop => self%dofmap_list%get_head() + end function get_last_dof_halo_deepest - ! loop through list - do - if ( .not. associated(loop) ) then - ! At the end of list and we didn't find it - ! create stencil dofmap and add it - call self%dofmap_list%insert_item(stencil_dofmap_type(stencil_shape, & - stencil_extent, & - self%ndof_cell, & - self%mesh, & + !> @brief Returns whether fields on this function space are readonly + !> @return return_readonly Flag describes if fields on this function space + !> will be readonly + function is_readonly(self) result(return_readonly) + + implicit none + + class(function_space_type), intent(in) :: self + logical(l_def) :: return_readonly + + return_readonly = self%readonly + + end function is_readonly + + + !> @brief Returns whether fields on this function space can be written to + !> @return return_writable Flag describes if fields on this function space + !> can be written to + function is_writable(self) result(return_writable) + + implicit none + + class(function_space_type), intent(in) :: self + logical(l_def) :: return_writable + + return_writable = .not.self%readonly + + end function is_writable + + !> @brief Get the instance of a stencil dofmap for a given shape and size + !> @param[in] stencil_shape The shape identifier for the stencil dofmap to create + !> @param[in] stencil_extent The extent of the stencil excluding the centre cell + !> @return map the stencil_dofmap object to return + function get_stencil_dofmap(self, stencil_shape, stencil_extent) result(map) + + use stencil_dofmap_mod, only : stencil_dofmap_type + + implicit none + + class(function_space_type), intent(inout) :: self + integer(i_def), intent(in) :: stencil_shape + integer(i_def), intent(in) :: stencil_extent + + type(stencil_dofmap_type), pointer :: map ! return value + type(linked_list_item_type), pointer :: loop => null() + + integer(i_def) :: id + + map => null() + + ! Calculate id of the stencil_dofmap we want + id = generate_stencil_dofmap_id(stencil_shape, stencil_extent) + + + ! point at the head of the stencil_dofmap linked list + loop => self%dofmap_list%get_head() + + ! loop through list + do + if (.not. associated(loop)) then + ! At the end of list and we didn't find it + ! create stencil dofmap and add it + + call self%dofmap_list%insert_item(stencil_dofmap_type(stencil_shape, & + stencil_extent, & + self%ndof_cell, & + self%mesh, & self%master_dofmap)) - ! At this point the desired stencil dofmap is the tail of the list - ! so just retrieve it and exit loop + ! At this point the desired stencil dofmap is the tail of the list + ! so just retrieve it and exit loop - loop => self%dofmap_list%get_tail() + loop => self%dofmap_list%get_tail() - ! 'cast' to the stencil_dofmap_type - select type(v => loop%payload) + ! 'cast' to the stencil_dofmap_type + select type(v => loop%payload) type is (stencil_dofmap_type) map => v - end select - exit - - end if - ! otherwise search list for the id we want - if ( id == loop%payload%get_id() ) then - ! 'cast' to the stencil_dofmap_type - select type(v => loop%payload) + end select + exit + + end if + ! otherwise search list for the id we want + if (id == loop%payload%get_id()) then + ! 'cast' to the stencil_dofmap_type + select type(v => loop%payload) type is (stencil_dofmap_type) map => v - end select - exit - end if - loop => loop%next - end do -end function get_stencil_dofmap + end select + exit + end if + loop => loop%next + end do -!> @brief Get the instance of a 2D stencil dofmap for a given shape and size -!> @param[in] stencil_shape The shape identifier for the stencil dofmap to create -!> @param[in] stencil_extent The extent of the stencil excluding the centre cell -!> @return map The stencil_dofmap object to return -function get_stencil_2D_dofmap(self, stencil_shape, stencil_extent) result(map) + end function get_stencil_dofmap - use stencil_2d_dofmap_mod, only: stencil_2D_dofmap_type + !> @brief Get the instance of a 2D stencil dofmap for a given shape and size + !> @param[in] stencil_shape The shape identifier for the stencil dofmap to create + !> @param[in] stencil_extent The extent of the stencil excluding the centre cell + !> @return map The stencil_dofmap object to return + function get_stencil_2D_dofmap(self, stencil_shape, stencil_extent) result(map) - implicit none + use stencil_2D_dofmap_mod, only : stencil_2D_dofmap_type - class(function_space_type), intent(inout) :: self - integer(i_def), intent(in) :: stencil_shape - integer(i_def), intent(in) :: stencil_extent - type(stencil_2D_dofmap_type), pointer :: map ! return value + implicit none - type(linked_list_item_type), pointer :: loop => null() + class(function_space_type), intent(inout) :: self + integer(i_def), intent(in) :: stencil_shape + integer(i_def), intent(in) :: stencil_extent + type(stencil_2D_dofmap_type), pointer :: map ! return value - integer(i_def) :: id + type(linked_list_item_type), pointer :: loop => null() - map => null() + integer(i_def) :: id - ! Calculate id of the stencil_dofmap we want - id = generate_stencil_dofmap_id( stencil_shape, stencil_extent ) + map => null() + ! Calculate id of the stencil_dofmap we want + id = generate_stencil_dofmap_id(stencil_shape, stencil_extent) - ! point at the head of the stencil_dofmap linked list - loop => self%dofmap_list%get_head() + ! point at the head of the stencil_dofmap linked list + loop => self%dofmap_list%get_head() - ! loop through list - do - if ( .not. associated(loop) ) then - ! At the end of list and we didn't find it - ! create stencil dofmap and add it + ! loop through list + do + if (.not. associated(loop)) then + ! At the end of list and we didn't find it + ! create stencil dofmap and add it - call self%dofmap_list%insert_item(stencil_2D_dofmap_type(stencil_shape, & + call self%dofmap_list%insert_item(stencil_2D_dofmap_type( & + stencil_shape, & stencil_extent, & self%ndof_cell, & self%mesh, & self%master_dofmap)) - ! At this point the desired stencil dofmap is the tail of the list - ! so just retrieve it and exit loop + ! At this point the desired stencil dofmap is the tail of the list + ! so just retrieve it and exit loop - loop => self%dofmap_list%get_tail() + loop => self%dofmap_list%get_tail() - ! 'cast' to the stencil_dofmap_type - select type(v => loop%payload) + ! 'cast' to the stencil_dofmap_type + select type(v => loop%payload) type is (stencil_2D_dofmap_type) map => v - end select - exit - - end if - ! otherwise search list for the id we want - if ( id == loop%payload%get_id() ) then - ! 'cast' to the stencil_dofmap_type - select type(v => loop%payload) + end select + exit + + end if + ! otherwise search list for the id we want + if (id == loop%payload%get_id()) then + ! 'cast' to the stencil_dofmap_type + select type(v => loop%payload) type is (stencil_2D_dofmap_type) map => v - end select - exit - end if - loop => loop%next - end do -end function get_stencil_2D_dofmap + end select + exit + end if + loop => loop%next + end do -!---------------------------------------------------------------------------- -!> @brief Returns count of colours used in colouring member mesh. -!> -!> @return Number of colours used to colour this mesh. -!---------------------------------------------------------------------------- -function get_ncolours(self) result(ncolours) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ncolours + end function get_stencil_2D_dofmap - ncolours = self%mesh%get_ncolours() + !----------------------------------------------------------------------------- + !> @brief Returns count of colours used in colouring member mesh. + !> + !> @return Number of colours used to colour this mesh. + !----------------------------------------------------------------------------- + function get_ncolours(self) result(ncolours) -end function get_ncolours + implicit none -!============================================================================ -!> @brief Populates args with colouring info from member mesh. -!> -!> @param[out] ncolours Number of colours used to colour member mesh. -!> @param[out] ncells_per_colour Count of cells in each colour. -!> @param[out] colour_map Indices of cells in each colour. -!============================================================================ -subroutine get_colours(self, ncolours, ncells_per_colour, colour_map) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def), intent(out) :: ncolours - integer(i_def), pointer, intent(out) :: ncells_per_colour(:) - integer(i_def), pointer, intent(out) :: colour_map(:,:) + class(function_space_type), intent(in) :: self + integer(i_def) :: ncolours + ncolours = self%mesh%get_ncolours() - call self%mesh%get_colours(ncolours, ncells_per_colour, colour_map) + end function get_ncolours -end subroutine get_colours + !============================================================================= + !> @brief Populates args with colouring info from member mesh. + !> + !> @param[out] ncolours Number of colours used to colour member mesh. + !> @param[out] ncells_per_colour Count of cells in each colour. + !> @param[out] colour_map Indices of cells in each colour. + !============================================================================= + subroutine get_colours(self, ncolours, ncells_per_colour, colour_map) -!----------------------------------------------------------------------------- -! Function to clear up objects - called by destructor -!----------------------------------------------------------------------------- -!> @details Explcitly deallocates any allocatable arrays in the function space -!> to avoid memory leaks -!> @return Error status variable -subroutine clear(self) + implicit none - implicit none + class(function_space_type), intent(in) :: self + integer(i_def), intent(out) :: ncolours + integer(i_def), pointer, intent(out) :: ncells_per_colour(:) + integer(i_def), pointer, intent(out) :: colour_map(:,:) - class (function_space_type), intent(inout) :: self - - if (allocated(self%entity_dofs)) deallocate( self%entity_dofs ) - if (allocated(self%nodal_coords)) deallocate( self%nodal_coords ) - if (allocated(self%basis_order)) deallocate( self%basis_order ) - if (allocated(self%basis_index)) deallocate( self%basis_index ) - if (allocated(self%basis_vector)) deallocate( self%basis_vector ) - if (allocated(self%basis_x)) deallocate( self%basis_x ) - if (allocated(self%global_dof_id)) deallocate( self%global_dof_id ) - if (allocated(self%global_cell_dof_id_2d)) & - deallocate( self%global_cell_dof_id_2d ) - if (allocated(self%global_edge_dof_id_2d)) & - deallocate( self%global_edge_dof_id_2d ) - if (allocated(self%global_vert_dof_id_2d)) & - deallocate( self%global_vert_dof_id_2d ) - if (allocated(self%last_dof_halo)) deallocate( self%last_dof_halo ) - if (allocated(self%fractional_levels))deallocate( self%fractional_levels ) - if (allocated(self%dof_on_vert_boundary)) & - deallocate( self%dof_on_vert_boundary ) - call self%master_dofmap%clear() - call self%dofmap_list%clear() - - nullify(self%mesh) - -end subroutine clear - -function get_cell_orientation(self, cell) result(orientation) - implicit none - class(function_space_type) :: self - integer, intent(in) :: cell - integer, dimension(:), pointer :: orientation - orientation => null() -end function get_cell_orientation + call self%mesh%get_colours(ncolours, ncells_per_colour, colour_map) -!----------------------------------------------------------------------------- -! Function space destructor -!----------------------------------------------------------------------------- + end subroutine get_colours -subroutine function_space_destructor(self) + !----------------------------------------------------------------------------- + !> @brief Returns the halo depth of the function space + !> + !> @return Depth of the halo + !----------------------------------------------------------------------------- + function get_halo_depth(self) result(halo_depth) - implicit none + implicit none + + class(function_space_type), intent(in) :: self + integer(i_def) :: halo_depth + + halo_depth = self%mesh%get_halo_depth() + + end function get_halo_depth + + !----------------------------------------------------------------------------- + ! Function to clear up objects - called by destructor + !----------------------------------------------------------------------------- + !> @details Explcitly deallocates any allocatable arrays in the function space + !> to avoid memory leaks + !> @return Error status variable + subroutine clear(self) + + implicit none + + class (function_space_type), intent(inout) :: self + + if (allocated(self%entity_dofs)) deallocate(self%entity_dofs) + if (allocated(self%nodal_coords)) deallocate(self%nodal_coords) + if (allocated(self%basis_order)) deallocate(self%basis_order) + if (allocated(self%basis_index)) deallocate(self%basis_index) + if (allocated(self%basis_vector)) deallocate(self%basis_vector) + if (allocated(self%basis_x)) deallocate(self%basis_x) + if (allocated(self%basis_z)) deallocate(self%basis_z) + if (allocated(self%global_dof_id)) deallocate(self%global_dof_id) + if (allocated(self%global_cell_dof_id_2d)) & + deallocate(self%global_cell_dof_id_2d) + if (allocated(self%global_edge_dof_id_2d)) & + deallocate(self%global_edge_dof_id_2d) + if (allocated(self%global_vert_dof_id_2d)) & + deallocate(self%global_vert_dof_id_2d) + if (allocated(self%last_dof_halo)) deallocate(self%last_dof_halo) + if (allocated(self%fractional_levels))deallocate(self%fractional_levels) + if (allocated(self%dof_on_vert_boundary)) & + deallocate(self%dof_on_vert_boundary) + + call self%master_dofmap%clear() + call self%dofmap_list%clear() + + nullify(self%mesh) + + end subroutine clear + + !----------------------------------------------------------------------------- + ! Function space destructor + !----------------------------------------------------------------------------- + + subroutine function_space_destructor(self) + + implicit none - type (function_space_type), intent(inout) :: self + type (function_space_type), intent(inout) :: self - call self%clear() + call self%clear() -end subroutine function_space_destructor + end subroutine function_space_destructor end module function_space_mod diff --git a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_mod.f90 b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_mod.f90 index 2c0b81c08f..03c5a12e33 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_mod.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/function_space/function_space_mod.f90 @@ -40,1423 +40,1582 @@ ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Modified by J. Henrichs, Bureau of Meteorology +! J. Dendy, Met Office !> !> @brief Holds information about the function space. !> !> @details A container which holds type definition of the function space and -!> has holds a number of static copies of the function spaces require +!> holds a number of static copies of the function spaces required !> by the model. It provides accessor functions (getters) to various !> information held in the type. ! module function_space_mod + use constants_mod, only : i_def, i_halo_index, l_def, r_def + use mesh_mod, only : mesh_type + use master_dofmap_mod, only : master_dofmap_type + use stencil_dofmap_helper_functions_mod, & + only : generate_stencil_dofmap_id + use log_mod, only : log_event, log_scratch_space, & + LOG_LEVEL_DEBUG, LOG_LEVEL_ERROR, & + LOG_LEVEL_INFO + use fs_continuity_mod, only : W0, W1, W2, W3, Wtheta, W2broken, W2trace, & + W2Htrace, W2Vtrace, W2V, W2H, Wchi, & + W2Hbroken + use function_space_constructor_helper_functions_mod, & + only : ndof_setup, basis_setup, dofmap_setup, & + levels_setup, generate_fs_id + use linked_list_data_mod, only : linked_list_data_type + use linked_list_mod, only : linked_list_type, linked_list_item_type -use constants_mod, only: i_def, i_native, i_halo_index, l_def, r_def -use mesh_mod, only: mesh_type -use master_dofmap_mod, only: master_dofmap_type -use stencil_dofmap_helper_functions_mod, & - only: generate_stencil_dofmap_id -use log_mod, only: log_event, log_scratch_space & - , LOG_LEVEL_DEBUG, LOG_LEVEL_ERROR & - , LOG_LEVEL_INFO -use reference_element_mod, only: reference_element_type -use fs_continuity_mod, only: W0, W1, W2, W3, Wtheta, & - W2broken, W2trace, & - W2Htrace, W2Vtrace, & - W2V, W2H, Wchi -use function_space_constructor_helper_functions_mod, & - only: ndof_setup, basis_setup, & - dofmap_setup, levels_setup + implicit none -use linked_list_data_mod, only : linked_list_data_type -use linked_list_mod, only : linked_list_type, & - linked_list_item_type + private -implicit none + integer(i_def), public, parameter :: BASIS = 100 + integer(i_def), public, parameter :: DIFF_BASIS = 101 -private + !----------------------------------------------------------------------------- + ! Public types + !----------------------------------------------------------------------------- -public :: W0, W1, W2, W2broken, W2trace, W2Vtrace, W2Htrace, W3, Wtheta, W2V, W2H, Wchi + type, extends(linked_list_data_type), public :: function_space_type -integer(i_def), public, parameter :: BASIS = 100 -integer(i_def), public, parameter :: DIFF_BASIS = 101 + private + !> Number of degrees of freedom associated with each cell + integer(i_def) :: ndof_cell -!------------------------------------------------------------------------------- -! Public types -!------------------------------------------------------------------------------- - -type, extends(linked_list_data_type), public :: function_space_type - - private + !> Number of unique degrees of freedom located on + !> the 3D mesh associated with this function space. + integer(i_def) :: ndof_glob - !> Number of degrees of freedom associated with each cell - integer(i_def) :: ndof_cell + !> Number of degrees of freedom associated with each cell + integer(i_def) :: ndof_interior - !> Number of unique degrees of freedom located on - !> the 3D mesh associated with this function space. - integer(i_def) :: ndof_glob + !> Number of degrees of freedom associated with each cell + integer(i_def) :: ndof_exterior - !> Number of degrees of freedom associated with each cell - integer(i_def) :: ndof_interior + !> Number of degrees of freedom located on cell vertex entities. + integer(i_def) :: ndof_vert - !> Number of degrees of freedom associated with each cell - integer(i_def) :: ndof_exterior + !> Number of degrees of freedom located on horizontal cell edge entities + !> (edges which lie in a plane of constant z). + integer(i_def) :: ndof_edge_h - !> Number of degrees of freedom located on cell vertex entities. - integer(i_def) :: ndof_vert + !> Number of degrees of freedom located on vertical cell edge entities + !> (edges which lie in a plane of contant x or y). + integer(i_def) :: ndof_edge_v - !> Number of degrees of freedom located on cell edge entities. - integer(i_def) :: ndof_edge + !> Number of degrees of freedom located on horizontal cell face entities + !> (faces whose normal vectors have 0 z-component). + integer(i_def) :: ndof_face_h - !> Number of degrees of freedom located on cell face entities. - integer(i_def) :: ndof_face + !> Number of degrees of freedom located on vertical cell face entities + !> (faces whose normal vectors have 0 x and y components). + integer(i_def) :: ndof_face_v - !> Number of degrees of freedom located on cell volume entities. - integer(i_def) :: ndof_vol + !> Number of degrees of freedom located on cell volume entities. + integer(i_def) :: ndof_vol - !> Integer value for Gungho functions spaces, e.g. W0 would be 1 - integer(i_def) :: fs + !> Integer value for Gungho functions spaces, e.g. W0 would be 1 + integer(i_def) :: fs - !> Element base-order of Gungho function space - integer(i_def) :: element_order + !> Element base-order of Gungho function space in horizontal direction + integer(i_def) :: element_order_h - ! Function space polynomial order? dynamics is still to provide us - ! with a name for this, same as element order except for W0 - ! where is it equal to element_order+1 - integer(i_def) :: fs_order + !> Element base-order of Gungho function space in vertical direction + integer(i_def) :: element_order_v - !> The number of data values to be held at each dof location - integer(i_def) :: ndata + ! Function space polynomial order? dynamics is still to provide us + ! with a name for this, same as element order except for W0 + ! where is it equal to element_order_h/v+1, in either horizontal or vertical + integer(i_def) :: fs_order_h + integer(i_def) :: fs_order_v - !> Number of dimensions in this function space - integer(i_def) :: dim_space + !> The number of data values to be held at each dof location + integer(i_def) :: ndata - !> Number of dimensions in this function space when differentiated - integer(i_def) :: dim_space_diff + !> Flag describes order of data. False=layer first, true=multi-data first + logical(l_def) :: ndata_first - !> A two dimensional, allocatable array which holds the indirection map - !> or dofmap for the whole function space over the bottom level of the domain. - type(master_dofmap_type) :: master_dofmap + !> Number of dimensions in this function space + integer(i_def) :: dim_space - !> Mesh object used to create this function space. This is a - !> pointer to a mesh in a linked list of mesh objects - type(mesh_type), pointer :: mesh => null() + !> Number of dimensions in this function space when differentiated + integer(i_def) :: dim_space_diff - !> A two dimensional, allocatable array of reals which holds the coordinates - !> of the function_space degrees of freedom - real(r_def), allocatable :: nodal_coords(:,:) + !> A two dimensional, allocatable array which holds the indirection map or + !> dofmap for the whole function space over the bottom level of the domain. + type(master_dofmap_type) :: master_dofmap - !> A two dimensional, allocatable, integer array which specifies which - !> dofs are on vertex boundarys - integer(i_def), allocatable :: dof_on_vert_boundary(:,:) + !> Mesh object used to create this function space. This is a + !> pointer to a mesh in a linked list of mesh objects + type(mesh_type), pointer :: mesh => null() - !> An allocatable array of labels (integers) which maps degree of freedom - !> index to the geometric entity (V - Volume, W - West face, T - Top face, etc.) - integer(i_def), allocatable :: entity_dofs(:) + !> A two dimensional, allocatable array of reals which holds the coordinates + !> of the function_space degrees of freedom + real(r_def), allocatable :: nodal_coords(:,:) - !> An array to hold an ordered, unique list of levels for output - !> of fields on this function space - real(r_def), allocatable :: fractional_levels(:) + !> A two dimensional, allocatable, integer array which specifies which + !> dofs are on vertex boundarys + integer(i_def), allocatable :: dof_on_vert_boundary(:,:) - !> @} - !> @name Arrays needed for on the fly basis evaluations - integer(i_def), allocatable :: basis_order(:,:) - integer(i_def), allocatable :: basis_index(:,:) - real(r_def), allocatable :: basis_vector(:,:) - real(r_def), allocatable :: basis_x(:,:,:) - !> @} + !> An allocatable array of labels (integers) which maps degree of freedom + !> index to the geometric entity + !> (V - Volume, W - West face, T - Top face, etc.) + integer(i_def), allocatable :: entity_dofs(:) - !> A one dimensional, allocatable array which holds a unique global index for - !> every dof in the local domain - integer(i_halo_index), allocatable :: global_dof_id(:) + !> An array to hold an ordered, unique list of levels for output + !> of fields on this function space + real(r_def), allocatable :: fractional_levels(:) - !> A one dimensional, allocatable array which holds a unique global index for - !> cell dofs in the 2D horizontal portion of the local domain - integer(i_def), allocatable :: global_cell_dof_id_2d(:) + !> @} + !> @name Arrays needed for on the fly basis evaluations + integer(i_def), allocatable :: basis_order(:,:) + integer(i_def), allocatable :: basis_index(:,:) + real(r_def), allocatable :: basis_vector(:,:) + real(r_def), allocatable :: basis_x(:,:,:) + real(r_def), allocatable :: basis_z(:,:) + !> @} - !> A one dimensional, allocatable array which holds a unique global index for - !> edge dofs in the 2D horizontal portion of the local domain - integer(i_def), allocatable :: global_edge_dof_id_2d(:) + !> A one dimensional, allocatable array which holds a unique global index + !> for every dof in the local domain + integer(i_halo_index), allocatable :: global_dof_id(:) - !> A one dimensional, allocatable array which holds a unique global index for - !> vertex dofs in the 2D horizontal portion of the local domain - integer(i_def), allocatable :: global_vert_dof_id_2d(:) + !> A one dimensional, allocatable array which holds a unique global index + !> for cell dofs in the 2D horizontal portion of the local domain + integer(i_def), allocatable :: global_cell_dof_id_2d(:) + + !> A one dimensional, allocatable array which holds a unique global index + !> for edge dofs in the 2D horizontal portion of the local domain + integer(i_def), allocatable :: global_edge_dof_id_2d(:) + + !> A one dimensional, allocatable array which holds a unique global index + !> for vertex dofs in the 2D horizontal portion of the local domain + integer(i_def), allocatable :: global_vert_dof_id_2d(:) + + !> The index within the dofmap of the last "owned" dof + integer(i_def) :: last_dof_owned + + !> The index within the dofmap of the last "annexed" dof + !> ("Annexed" dofs that those that are not owned, but are on owned cells) + integer(i_def) :: last_dof_annexed + + !> A one dimensional, allocatable array which holds the index in the dofmap + !> of the last of the halo dofs (from the various depths of halo) + integer(i_def), allocatable :: last_dof_halo(:) + + !> A linked list of stencil dofmaps + type(linked_list_type) :: dofmap_list + + !> Flag holds whether fields on this function space will be readonly + logical(l_def) :: readonly + + contains + + !> @brief Gets the total number of unique degrees of freedom for this space, + !> @return Integer Total number of unique degrees of freedom + procedure, public :: get_undf + + !> @brief Gets the total number of unique degrees of freedom located on + !> the 3D mesh associated with this function space. + !> @return Integer Total number of unique degrees of freedom + procedure, public :: get_ndof_glob + + !> @brief Returns the number of cells in a horizontal 2D layer + !> in the function space + !> @return Integer, Number of cells in 2D layer + procedure, public :: get_ncell + + !> @brief Returns the number of layers in the function space + !> @return Integer, Number of layers + procedure, public :: get_nlayers + + !> @brief Returns a pointer to the dofmap for the cell + !> @param[in] cell Which cell + !> @return The pointer which points to a slice of the dofmap + procedure, public :: get_cell_dofmap + + !> @brief Returns a pointer to the dofmap for all cells + !> @return The pointer which points to the cell-ordered dofmap + procedure, public :: get_whole_dofmap + + !> @brief Returns a pointer to the fractional levels in a column + !> for the function space + !> @return The pointer which points to the fractional levels array + procedure, public :: get_levels + + !> @brief Obtains the number of dofs per cell + !> @return Integer, the number of dofs per cell + procedure, public :: get_ndf + + !> @brief Obtains the number of interior dofs + !> @return Integer, the number of dofs associated with the interior of + !> each cell + procedure, public :: get_ndof_interior + + !> @brief Obtains the number of face dofs on each horizontal face + !> @return Integer, the number of dofs associated with the faces of + !> each cell + procedure, public :: get_ndof_face_h + + !> @brief Obtains the number of face dofs on each vertical face + !> @return Integer, the number of dofs associated with the faces of + !> each cell + procedure, public :: get_ndof_face_v + + !> Gets the coordinates of the function space + !> @return A pointer to the two dimensional array of nodal_coords, (xyz,ndf) + procedure, public :: get_nodes + + !> @brief Returns the enumerated integer for the functions_space which + !! is this function_space + !> @return Integer, The enumerated integer for the functions space + procedure, public :: which + + !> @brief Gets the flag (0) for dofs on bottom and top faces of element + !> @return A pointer to boundary_dofs(ndf,2) the flag for bottom (:,1) + !> and top (:,2) boundaries + procedure, public :: get_boundary_dofs + + !> @brief Calls an available function at a point + !> @param[in] function_to_call The function to call + !> @param[in] df The dof to compute the basis function of + !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function + procedure, public :: call_function + + !> @brief Evaluates the basis function at a point + !> @param[in] df The dof to compute the basis function of + !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function + procedure, private :: evaluate_basis + + !> @brief Evaluates the differential of a basis function + !> @param[in] df The dof to compute the basis function of + !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function + procedure, private :: evaluate_diff_basis + + !> @brief Evaluates the basis function for a given quadrature. + !>@deprecated has been moved to the new evaluater_type and once that is + !supported, this can be removed + !> @param[in] ndf integer number of dofs + !> @param[in] qp_h integer number of quadrature points in the horizontal + !> @param[in] qp_v integer number of quadrature points in the vertical + !> @param[in] x_qp real two dimensional array holding the x's horizontal + !> @param[in] z_qp real two dimensional array holding the x's vertical + !> @param[out] basis real 3 dimensional array holding the evaluated basis + !! functions + procedure, public :: compute_basis_function + + !> @brief Evaluates the differential basis function for a given quadrature + !>@deprecated has been moved to the new evaluater_type and once that is + !supported, this can be removed + !> @param[in] ndf integer number of dofs + !> @param[in] qp_h integer number of quadrature points in the horizontal + !> @param[in] qp_v integer number of quadrature points in the vertical + !> @param[in] x_qp real two dimensional array holding the x's horizontal + !> @param[in] z_qp real two dimensional array holding the x's vertical + !> @param[out] dbasis real 3 dimensional array holding the evaluated basis + !> functions + procedure, public :: compute_diff_basis_function + + !> @brief Gets the size of the space + !!(1 is scalar 3 is vector). Returns dim + !> @return dim The size of the space + procedure, public :: get_dim_space + + !> @brief Gets the size of the differential space + !! (1 is scalar 3 is vector). Returns dim + !> @return dim The size of the differential space + procedure, public :: get_dim_space_diff + + !> @brief Access the mesh object used to create this function space + !> @return mesh Mesh object + procedure, public :: get_mesh + + !> @brief Gets the id of the mesh object for this space + !> @return mesh_id ID of the mesh object + procedure, public :: get_mesh_id + + !> @brief Returns the horizontal element order of a function space + procedure, public :: get_element_order_h + + !> @brief Returns the vertical element order of a function space + procedure, public :: get_element_order_v + + !> @brief Returns the horizontal order of a function space + procedure, public :: get_fs_order_h + + !> @brief Returns the vertical order of a function space + procedure, public :: get_fs_order_v + + !> @brief Returns the number of data values held at each dof + procedure, public :: get_ndata + + !> Returns if the ordering of data is multi-data quickest + !> @return True if the data is ordered multi-data quickest + procedure, public :: is_ndata_first + + !> @brief Gets mapping from degree of freedom to reference element entity. + !> @return Integer array mapping degree of freedom index to geometric entity + !> on the reference element. + procedure, public :: get_entity_dofs + + !> Gets the array that holds the global indices of all dofs + procedure get_global_dof_id + + !> Gets the array that holds the global indices of all cell dofs + !> in 2D horizontal domain + procedure get_global_cell_dof_id_2d + + !> Gets the array that holds the global indices of all edge dofs + !> in 2D horizontal domain + procedure get_global_edge_dof_id_2d + + !> Gets the array that holds the global indices of all vertex dofs + !> in 2D horizontal domain + procedure get_global_vert_dof_id_2d + + !> Gets the index within the dofmap of the last "owned" dof + procedure get_last_dof_owned + + !> Gets the index within the dofmap of the last "annexed" dof + procedure get_last_dof_annexed + + !> Gets the index in the dofmap of the last dof in any depth of halo + procedure get_last_dof_halo_any - !> The index within the dofmap of the last "owned" dof - integer(i_def) :: last_dof_owned + !> Gets the index in the dofmap of the last dof in the deepest depth of halo + procedure get_last_dof_halo_deepest - !> The index within the dofmap of the last "annexed" dof - !> ("Annexed" dofs that those that are not owned, but are on owned cells) - integer(i_def) :: last_dof_annexed + generic :: get_last_dof_halo => get_last_dof_halo_any, & + get_last_dof_halo_deepest + + !> Returns whether fields on this function space are readonly + procedure, public :: is_readonly - !> A one dimensional, allocatable array which holds the index in the dofmap - !> of the last of the halo dofs (from the various depths of halo) - integer(i_def), allocatable :: last_dof_halo(:) + !> Returns whether fields on this function space can be written to + procedure, public :: is_writable - !> A linked list of stencil dofmaps - type(linked_list_type) :: dofmap_list + !> Get the instance of a stencil dofmap for a given id + procedure, public :: get_stencil_dofmap - !> Flag holds whether fields on this function space will be readonly - logical(l_def) :: readonly + !> Get the instance of a 2D stencil dofmap for a given id + procedure, public :: get_stencil_2D_dofmap -contains + ! Mesh colouring wrapper methods + !> @brief Populates args with colouring info from member mesh. + !> + !> @param[out] ncolours Number of colours used to colour member mesh. + !> @param[out] ncells_per_colour Count of cells in each colour. + !> @param[out] colour_map Indices of cells in each colour. + procedure, public :: get_colours - !> @brief Gets the total number of unique degrees of freedom for this space, - !> @return Integer Total number of unique degrees of freedom - procedure, public :: get_undf - - !> @brief Gets the total number of unique degrees of freedom located on - !> the 3D mesh associated with this function space. - !> @return Integer Total number of unique degrees of freedom - - procedure, public :: get_ndof_glob - - !> @brief Returns the number of cells in a horizontal 2D layer - !> in the function space - !> @return Integer, Number of cells in 2D layer - procedure, public :: get_ncell - - !> @brief Returns the number of layers in the function space - !> @return Integer, Number of layers - procedure, public :: get_nlayers - - !> @brief Returns a pointer to the dofmap for the cell - !> @param[in] cell Which cell - !> @return The pointer which points to a slice of the dofmap - procedure, public :: get_cell_dofmap - - !> @brief Returns a pointer to the dofmap for all cells - !> @return The pointer which points to the cell-ordered dofmap - procedure, public :: get_whole_dofmap - - !> @brief Returns a pointer to the fractional levels in a column - !> for the function space - !> @return The pointer which points to the fractional levels array - procedure, public :: get_levels - - !> @brief Obtains the number of dofs per cell - !> @return Integer, the number of dofs per cell - procedure, public :: get_ndf - !> @brief Obtains the number of interior dofs - !> @return Integer, the number of dofs associated with the interior of - !> each cell - procedure, public :: get_ndof_interior - - !> @brief Obtains the number of face dofs - !> @return Integer, the number of dofs associated with the faces of - !> each cell - procedure, public :: get_ndof_face - !> Gets the coordinates of the function space - !> @return A pointer to the two dimensional array of nodal_coords, (xyz,ndf) - procedure, public :: get_nodes - - !> @brief Returns the enumerated integer for the functions_space which - !! is this function_space - !> @return Integer, The enumerated integer for the functions space - procedure, public :: which - - !> @brief Gets the flag (0) for dofs on bottom and top faces of element - !> @return A pointer to boundary_dofs(ndf,2) the flag for bottom (:,1) - !> and top (:,2) boundaries - procedure, public :: get_boundary_dofs - - !> @brief Calls an available function at a point - !> @param[in] function_to_call The function to call - !> @param[in] df The dof to compute the basis function of - !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function - procedure, public :: call_function - - !> @brief Evaluates the basis function at a point - !> @param[in] df The dof to compute the basis function of - !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function - !> @TODO once the new quadrature object is implemented via call_function then - !> this function could be made private as its accessed from - !> call_function - procedure, public :: evaluate_basis - - !> @brief Evaluates the differential of a basis function - !> @param[in] df The dof to compute the basis function of - !> @param[in] xi The (x,y,z) coodinates to evaluate the basis function - !> @TODO once the new quadrature object is implemented via call_function then - !> this function could be made private as its accessed from - !> call_function - procedure, public :: evaluate_diff_basis - - !> @brief Evaluates the basis function for a given quadrature. - !>@deprecated has been moved to the new evaluater_type and once that is - !supported, this can be removed - !> @param[in] ndf integer number of dofs - !> @param[in] qp_h integer number of quadrature points in the horizontal - !> @param[in] qp_v integer number of quadrature points in the vertical - !> @param[in] x_qp real two dimensional array holding the x's horizontal - !> @param[in] z_qp real two dimensional array holding the x's vertical - !> @param[out] basis real 3 dimensional array holding the evaluated basis - !! functions - procedure, public :: compute_basis_function - - !> @brief Evaluates the differential basis function for a given quadrature - !>@deprecated has been moved to the new evaluater_type and once that is - !supported, this can be removed - !> @param[in] ndf integer number of dofs - !> @param[in] qp_h integer number of quadrature points in the horizontal - !> @param[in] qp_v integer number of quadrature points in the vertical - !> @param[in] x_qp real two dimensional array holding the x's horizontal - !> @param[in] z_qp real two dimensional array holding the x's vertical - !> @param[out] dbasis real 3 dimensional array holding the evaluated basis - !> functions - procedure, public :: compute_diff_basis_function - - !> @brief Gets the size of the space - !!(1 is scalar 3 is vector). Returns dim - !> @return dim The size of the space - procedure, public :: get_dim_space - - !> @brief Gets the size of the differential space - !! (1 is scalar 3 is vector). Returns dim - !> @return dim The size of the differential space - procedure, public :: get_dim_space_diff - - !> @brief Access the mesh object used to create this function space - !> @return mesh Mesh object - procedure, public :: get_mesh - procedure, public :: get_mesh_id - - !> @brief Returns the element order of a function space - procedure, public :: get_element_order - - !> @brief Returns the order of a function space - procedure, public :: get_fs_order - - !> @brief Returns the number of data values held at each dof - procedure, public :: get_ndata - - !> @brief Gets mapping from degree of freedom to reference element entity. - !> @return Integer array mapping degree of freedom index to geometric entity - !> on the reference element. - procedure, public :: get_entity_dofs - - !> Gets the array that holds the global indices of all dofs - procedure get_global_dof_id - - !> Gets the array that holds the global indices of all cell dofs - !> in 2D horizontal domain - procedure get_global_cell_dof_id_2d - - !> Gets the array that holds the global indices of all edge dofs - !> in 2D horizontal domain - procedure get_global_edge_dof_id_2d - - !> Gets the array that holds the global indices of all vertex dofs - !> in 2D horizontal domain - procedure get_global_vert_dof_id_2d - - !> Gets the index within the dofmap of the last "owned" dof - procedure get_last_dof_owned - - !> Gets the index within the dofmap of the last "annexed" dof - procedure get_last_dof_annexed - - !> Gets the index in the dofmap of the last dof in any depth of halo - procedure get_last_dof_halo_any - - !> Gets the index in the dofmap of the last dof in the deepest depth of halo - procedure get_last_dof_halo_deepest - - generic :: get_last_dof_halo => get_last_dof_halo_any, & - get_last_dof_halo_deepest - - !> Returns whether fields on this function space are readonly - procedure, public :: is_readonly - - !> Returns whether fields on this function space can be written to - procedure, public :: is_writable - - !> Get the instance of a stencil dofmap with for a given id - procedure, public :: get_stencil_dofmap - - !> Get the instance of a 2D stencil dofmap with for a given id - procedure, public :: get_stencil_2D_dofmap - - ! Mesh colouring wrapper methods - !> @brief Populates args with colouring info from member mesh. - !> - !> @param[out] ncolours Number of colours used to colour member mesh. - !> @param[out] ncells_per_colour Count of cells in each colour. - !> @param[out] colour_map Indices of cells in each colour. - procedure, public :: get_colours + !> @brief Returns count of colours used in colouring member mesh. + !> @return Number of colours used to colour this mesh. + procedure, public :: get_ncolours - !> @brief Returns count of colours used in colouring member mesh. - !> @return Number of colours used to colour this mesh. - procedure, public :: get_ncolours + !> @brief Returns the halo depth of the function space + !> @return Halo depth + procedure, public :: get_halo_depth - procedure, public :: clear + procedure, public :: clear - procedure, public :: get_cell_orientation + !> Routine to destroy function_space_type + final :: function_space_destructor - !> Routine to destroy function_space_type - final :: function_space_destructor -end type function_space_type + end type function_space_type -interface function_space_type - module procedure fs_constructor -end interface + interface function_space_type + module procedure fs_constructor + end interface !------------------------------------------------------------------------------- ! Contained functions/subroutines !------------------------------------------------------------------------------- contains -!------------------------------------------------------------------------------- -! Returns a pointer to a function space object -!------------------------------------------------------------------------------- -!> @brief Stucture-Constructor for function_space_type object. -!> @details This constructor function returns a pointer to an instantiated -!> function space. The pointer is to a function space singleton, -!> i.e. the function space is only created on the initial call, -!> all other calls just return a pointer to the function space. -!> @param[in] mesh The mesh upon which to base this function space -!> @param[in] element_order The element order for this function space, 0 being -!> the lowest element order for function spaces defined -!> for Gungho. -!> @b Note: This is not necessarily the same as the -!> order of the function space -!> @param[in] lfric_fs The integer number indicating which of the function -!> spaces predefined for lfric to base the -!> instantiated function space on. Recognised integers -!> are assigned to the function spaces "handles" in the -!> fs_handles_mod module. -!> @param[in] ndata The number of data values to be held at each dof -!> location -!> @return A pointer to the function space held in this module -function fs_constructor(mesh, & - element_order, & - lfric_fs, & - ndata) result(instance) - - implicit none + !----------------------------------------------------------------------------- + ! Returns a pointer to a function space object + !----------------------------------------------------------------------------- + !> @brief Stucture-Constructor for function_space_type object. + !> @details This constructor function returns a pointer to an instantiated + !> function space. The pointer is to a function space singleton, + !> i.e. the function space is only created on the initial call, + !> all other calls just return a pointer to the function space. + !> @param[in] mesh The mesh upon which to base this function space + !> @param[in] element_order_h The element order for this function space in + !> the horizontal direction, 0 being the lowest + !> element order for function spaces defined for + !> Gungho. + !> @b Note: This is not necessarily the same as + !> the order of the function space + !> @param[in] element_order_v The element order for this function space in + !> the vertical direction, 0 being the lowest + !> element order for function spaces defined for + !> Gungho. + !> @b Note: This is not necessarily the same as the + !> order of the function space + !> @param[in] lfric_fs The integer number indicating which of the + !> function spaces predefined for lfric to base the + !> instantiated function space on. Recognised + !> integers are assigned to the function spaces + !> "handles" in the fs_handles_mod module. + !> @param[in] ndata The number of data values to be held at each dof + !> location + !> @param[in] ndata_first Flag to set data to be layer first (false) or + !! ndata first (true) + !> @return A pointer to the function space held in this module + function fs_constructor( mesh, & + element_order_h, & + element_order_v, & + lfric_fs, & + ndata, & + ndata_first ) result(instance) + + implicit none + + class(mesh_type), target, intent(in) :: mesh + integer(i_def), intent(in) :: element_order_h + integer(i_def), intent(in) :: element_order_v + integer(i_def), intent(in) :: lfric_fs + integer(i_def), optional, intent(in) :: ndata + logical(l_def), optional, intent(in) :: ndata_first + + type(function_space_type) :: instance + + integer(i_def) :: id + + if ( present(ndata_first) ) then + instance%ndata_first = ndata_first + else + instance%ndata_first = .false. + end if - class(mesh_type), intent(in), target :: mesh - integer(i_def), intent(in) :: element_order - integer(i_native), intent(in) :: lfric_fs - integer(i_def), optional, intent(in) :: ndata + if (present(ndata)) then + instance%ndata = ndata + else + instance%ndata = 1 + end if - type(function_space_type) :: instance + instance%mesh => mesh + instance%fs = lfric_fs + instance%element_order_h = element_order_h + instance%element_order_v = element_order_v - integer(i_def) :: ndata_sz + ! Generate unique id with mesh_id=0 since mesh_collection_mod is not used + ! in this modified example + id = generate_fs_id(lfric_fs, element_order_h, element_order_v, 0, & + instance%ndata, instance%ndata_first) + call instance%set_id(id) - if (present(ndata)) then - ndata_sz = ndata + if (lfric_fs == W0) then + instance%fs_order_h = element_order_h + 1 + instance%fs_order_v = element_order_v + 1 else - ndata_sz = 1 + instance%fs_order_h = element_order_h + instance%fs_order_v = element_order_v end if + call init_function_space(instance) - instance%mesh => mesh - instance%fs = lfric_fs - instance%element_order = element_order - instance%ndata = ndata_sz + end function fs_constructor - if (lfric_fs == W0) then - instance%fs_order = element_order + 1 - else - instance%fs_order = element_order - end if - call init_function_space( instance ) - return -end function fs_constructor + subroutine init_function_space(self) + implicit none -subroutine init_function_space( self ) + type(function_space_type), intent(inout) :: self - implicit none + integer(i_def) :: ncells_2d + integer(i_def) :: ncells_2d_with_ghost - type(function_space_type), intent(inout) :: self + integer(i_def), allocatable :: dofmap(:,:) - integer(i_def) :: ncells_2d - integer(i_def) :: ncells_2d_with_ghost + ncells_2d = self%mesh % get_ncells_2d() + ncells_2d_with_ghost = self%mesh % get_ncells_2d_with_ghost() - integer(i_def), allocatable :: dofmap(:,:) + select case (self%fs) + case (W0, WTHETA, WCHI) + self%dim_space = 1 ! Scalar field + self%dim_space_diff = 3 ! Vector field - ncells_2d = self%mesh % get_ncells_2d() - ncells_2d_with_ghost = self%mesh % get_ncells_2d_with_ghost() + case (W1) + self%dim_space = 3 ! Vector field + self%dim_space_diff = 3 ! Vector field - select case (self%fs) - case (W0, WTHETA, WCHI) - self%dim_space = 1 ! Scalar field - self%dim_space_diff = 3 ! Vector field + case (W2, W2broken, W2V, W2H, W2Hbroken) + self%dim_space = 3 ! Vector field + self%dim_space_diff = 1 ! Scalar field - case (W1) - self%dim_space = 3 ! Vector field - self%dim_space_diff = 3 ! Vector field + case (W2trace, W2Vtrace, W2Htrace, W3) + self%dim_space = 1 ! Scalar field + self%dim_space_diff = 3 ! Vector field - case (W2, W2broken, W2V, W2H) - self%dim_space = 3 ! Vector field - self%dim_space_diff = 1 ! Scalar field + case default + call log_event(& + 'Attempt to initialise unknown function space', & + LOG_LEVEL_ERROR) + + end select + + call ndof_setup ( self%mesh, & + self%element_order_h, self%element_order_v, & + self%fs, & + self%ndof_vert, & + self%ndof_edge_h, self%ndof_edge_v, & + self%ndof_face_h, self%ndof_face_v, & + self%ndof_vol, & + self%ndof_cell, & + self%ndof_glob, & + self%ndof_interior, self%ndof_exterior ) + + if (allocated(self%basis_index)) deallocate(self%basis_index) + if (allocated(self%basis_order)) deallocate(self%basis_order) + if (allocated(self%basis_vector)) deallocate(self%basis_vector) + if (allocated(self%basis_x)) deallocate(self%basis_x) + if (allocated(self%basis_z)) deallocate(self%basis_z) + if (allocated(self%nodal_coords)) deallocate(self%nodal_coords) + if (allocated(self%dof_on_vert_boundary)) & + deallocate(self%dof_on_vert_boundary) + if (allocated(self%entity_dofs)) deallocate(self%entity_dofs) + + allocate(self%basis_index( 3, self%ndof_cell )) + allocate(self%basis_order( 3, self%ndof_cell )) + allocate(self%basis_vector( self%dim_space, self%ndof_cell )) + + allocate(self%basis_x( self%element_order_h + 2, 2, self%ndof_cell )) + allocate(self%basis_z( self%element_order_v + 2, self%ndof_cell )) + allocate(self%nodal_coords( 3, self%ndof_cell )) + allocate(self%dof_on_vert_boundary ( self%ndof_cell, 2 )) + allocate(self%entity_dofs(self%ndof_cell)) + + call basis_setup( self%element_order_h, & + self%element_order_v, & + self%fs, & + self%ndof_vert, self%ndof_cell, & + self%mesh%get_reference_element(), & + self%basis_index, self%basis_order, & + self%basis_vector, self%basis_x, & + self%basis_z, & + self%nodal_coords, & + self%dof_on_vert_boundary, & + self%entity_dofs) + + ncells_2d_with_ghost = self%mesh % get_ncells_2d_with_ghost() + + allocate(dofmap( self%ndof_cell, 0:ncells_2d_with_ghost )) + + allocate(self%global_dof_id (self%ndof_glob * self%ndata)) + allocate(& + self%global_cell_dof_id_2d(self%mesh%get_last_edge_cell() * self%ndata)) + + allocate(& + self%global_edge_dof_id_2d(self%mesh%get_num_edges_owned_2d() * self%ndata)) + + allocate(& + self%global_vert_dof_id_2d(self%mesh%get_num_verts_owned_2d() * self%ndata)) + + allocate(self%last_dof_halo (0 : self%mesh % get_halo_depth())) + + call dofmap_setup ( self%mesh, & + self%fs, & + self%element_order_h, self%element_order_v, & + self%ndata, & + self%ndata_first, & + ncells_2d_with_ghost, & + self%ndof_vert, & + self%ndof_edge_h, self%ndof_edge_v, & + self%ndof_face_h, self%ndof_face_v, & + self%ndof_vol, & + self%ndof_cell, & + self%last_dof_owned, & + self%last_dof_annexed, & + self%last_dof_halo, & + dofmap, & + self%global_dof_id, & + self%global_cell_dof_id_2d, & + self%global_edge_dof_id_2d, & + self%global_vert_dof_id_2d ) + + self%master_dofmap = master_dofmap_type(dofmap) + + + ! create the linked list + self%dofmap_list = linked_list_type() + + ! Set the readonly flag for WCHI. This means routing tables don't need to be + ! set up for this function space + if(self%fs == WCHI) then + self%readonly = .true. + else + self%readonly = .false. + end if - case (W2trace, W2Vtrace, W2Htrace, W3) - self%dim_space = 1 ! Scalar field - self%dim_space_diff = 3 ! Vector field + ! Set up the fractional levels (for diagnostic output) for this fs - end select + call levels_setup( self%mesh, self%get_nlayers(), & + self%fs, self%fractional_levels ) - call ndof_setup ( self%mesh, self%element_order, self%fs & - , self%ndof_vert, self%ndof_edge, self%ndof_face & - , self%ndof_vol, self%ndof_cell, self%ndof_glob & - , self%ndof_interior, self%ndof_exterior ) + if (allocated(dofmap)) deallocate (dofmap) - if (allocated( self%basis_index )) deallocate( self%basis_index ) - if (allocated( self%basis_order )) deallocate( self%basis_order ) - if (allocated( self%basis_vector )) deallocate( self%basis_vector) - if (allocated( self%basis_x )) deallocate( self%basis_x ) - if (allocated( self%nodal_coords )) deallocate( self%nodal_coords ) - if (allocated( self%dof_on_vert_boundary )) & - deallocate(self%dof_on_vert_boundary ) - if (allocated( self%entity_dofs )) deallocate( self%entity_dofs ) + end subroutine init_function_space - allocate( self%basis_index ( 3, self%ndof_cell) ) - allocate( self%basis_order ( 3, self%ndof_cell) ) - allocate( self%basis_vector (self%dim_space, self%ndof_cell) ) - allocate( self%basis_x (self%element_order+2,3, self%ndof_cell) ) - allocate( self%nodal_coords ( 3, self%ndof_cell) ) - allocate( self%dof_on_vert_boundary (self%ndof_cell,2) ) - allocate( self%entity_dofs(self%ndof_cell) ) + !----------------------------------------------------------------------------- + ! Gets total local unique dofs for this space + !----------------------------------------------------------------------------- + integer function get_undf(self) - call basis_setup( self%element_order, self%fs, & - self%ndof_vert, self%ndof_cell, & - self%mesh%get_reference_element(), & - self%basis_index, self%basis_order, & - self%basis_vector, self%basis_x, & - self%nodal_coords, & - self%dof_on_vert_boundary, & - self%entity_dofs ) + implicit none - ncells_2d_with_ghost = self%mesh % get_ncells_2d_with_ghost() + class(function_space_type), intent(in) :: self - allocate( dofmap ( self%ndof_cell & - , 0:ncells_2d_with_ghost ) ) + get_undf = self%last_dof_halo(ubound(self%last_dof_halo,1)) - allocate( self%global_dof_id ( self%ndof_glob*self%ndata ) ) - allocate( & - self%global_cell_dof_id_2d( self%mesh%get_last_edge_cell()*self%ndata ) ) + end function get_undf - allocate( & - self%global_edge_dof_id_2d( self%mesh%get_num_edges_owned_2d()*self%ndata ) ) + !----------------------------------------------------------------------------- + ! Gets the total number of unique degrees of freedom located on + ! the 3D mesh associated with this function space. + !----------------------------------------------------------------------------- + integer function get_ndof_glob(self) - allocate( & - self%global_vert_dof_id_2d( self%mesh%get_num_verts_owned_2d()*self%ndata ) ) + implicit none - allocate( self%last_dof_halo ( self%mesh % get_halo_depth()) ) + class(function_space_type), intent(in) :: self - call dofmap_setup ( self%mesh, self%fs, self%element_order, self%ndata, & - ncells_2d_with_ghost, & - self%ndof_vert, self%ndof_edge, self%ndof_face, & - self%ndof_vol, self%ndof_cell, self%last_dof_owned, & - self%last_dof_annexed, self%last_dof_halo, dofmap, & - self%global_dof_id, & - self%global_cell_dof_id_2d, & - self%global_edge_dof_id_2d, & - self%global_vert_dof_id_2d ) + get_ndof_glob = self%ndof_glob - self%master_dofmap = master_dofmap_type( dofmap ) + end function get_ndof_glob + !----------------------------------------------------------------------------- + ! Gets the number of cells for this function space + !----------------------------------------------------------------------------- + function get_ncell(self) result(ncells_2d) - ! create the linked list - self%dofmap_list = linked_list_type() + implicit none - ! Set the readonly flag for WCHI. This means routing tables don't need to be - ! set up for this function space - if( self%fs == WCHI ) then - self%readonly=.true. - else - self%readonly=.false. - end if + class(function_space_type), intent(in) :: self + integer(i_def) :: ncells_2d - ! Set up the fractional levels (for diagnostic output) for this fs + ncells_2d = self%mesh%get_ncells_2d() - call levels_setup( self%mesh, self%get_nlayers(), & - self%fs, self%fractional_levels ) + end function get_ncell - if (allocated(dofmap)) deallocate (dofmap) - - return -end subroutine init_function_space + !----------------------------------------------------------------------------- + ! Gets the number of layers for this functions space + !----------------------------------------------------------------------------- + function get_nlayers(self) result(nlayers) -!----------------------------------------------------------------------------- -! Gets total local unique dofs for this space -!----------------------------------------------------------------------------- -integer function get_undf(self) - implicit none + implicit none - class(function_space_type), intent(in) :: self + class(function_space_type), intent(in) :: self + integer(i_def) :: nlayers - get_undf = self%last_dof_halo(size(self%last_dof_halo)) + nlayers = self%mesh%get_nlayers() - return -end function get_undf + end function get_nlayers -!----------------------------------------------------------------------------- -! Gets the total number of unique degrees of freedom located on -! the 3D mesh associated with this function space. -!----------------------------------------------------------------------------- -integer function get_ndof_glob(self) - implicit none + !----------------------------------------------------------------------------- + ! Gets the number of dofs for a single cell + !----------------------------------------------------------------------------- + function get_ndf(self) result(ndof_cell) - class(function_space_type), intent(in) :: self + implicit none - get_ndof_glob = self%ndof_glob + class(function_space_type), intent(in) :: self + integer(i_def) :: ndof_cell - return -end function get_ndof_glob + ndof_cell = self%ndof_cell -!----------------------------------------------------------------------------- -! Gets the number of cells for this function space -!----------------------------------------------------------------------------- -function get_ncell(self) result(ncells_2d) + end function get_ndf + !----------------------------------------------------------------------------- + ! Gets the number of interior dofs for a single cell + !----------------------------------------------------------------------------- + function get_ndof_interior(self) result(ndof_interior) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ncells_2d + implicit none - ncells_2d = self%mesh%get_ncells_2d() + class(function_space_type), intent(in) :: self + integer(i_def) :: ndof_interior - return -end function get_ncell + ndof_interior = self%ndof_interior -!----------------------------------------------------------------------------- -! Gets the number of layers for this functions space -!----------------------------------------------------------------------------- -function get_nlayers(self) result(nlayers) + end function get_ndof_interior - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: nlayers + !----------------------------------------------------------------------------- + ! Gets the number of horizontal face dofs for a single cell + !----------------------------------------------------------------------------- + function get_ndof_face_h(self) result(ndof_face_h) - nlayers = self%mesh%get_nlayers() + implicit none - return -end function get_nlayers + class(function_space_type), intent(in) :: self + integer(i_def) :: ndof_face_h -!----------------------------------------------------------------------------- -! Gets the number of dofs for a single cell -!----------------------------------------------------------------------------- -function get_ndf(self) result(ndof_cell) + ndof_face_h = self%ndof_face_h - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ndof_cell + end function get_ndof_face_h - ndof_cell= self%ndof_cell + !----------------------------------------------------------------------------- + ! Gets the number of vertical face dofs for a single cell + !----------------------------------------------------------------------------- + function get_ndof_face_v(self) result(ndof_face_v) - return -end function get_ndf -!----------------------------------------------------------------------------- -! Gets the number of interior dofs for a single cell -!----------------------------------------------------------------------------- -function get_ndof_interior(self) result(ndof_interior) + implicit none - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ndof_interior + class(function_space_type), intent(in) :: self + integer(i_def) :: ndof_face_v - ndof_interior = self%ndof_interior + ndof_face_v = self%ndof_face_v - return -end function get_ndof_interior + end function get_ndof_face_v -!----------------------------------------------------------------------------- -! Gets the number of face dofs for a single cell -!----------------------------------------------------------------------------- -function get_ndof_face(self) result(ndof_face) + !----------------------------------------------------------------------------- + ! Gets the dofmap for a single cell + !----------------------------------------------------------------------------- + function get_cell_dofmap(self, cell_lid) result(map) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ndof_face + implicit none - ndof_face = self%ndof_face + class(function_space_type), target, intent(in) :: self + integer(i_def), intent(in) :: cell_lid + integer(i_def), pointer :: map(:) - return -end function get_ndof_face + map => self%master_dofmap%get_master_dofmap(cell_lid) -!----------------------------------------------------------------------------- -! Gets the dofmap for a single cell -!----------------------------------------------------------------------------- -function get_cell_dofmap(self,cell_lid) result(map) + end function get_cell_dofmap - implicit none - class(function_space_type), target, intent(in) :: self - integer(i_def), intent(in) :: cell_lid - integer(i_def), pointer :: map(:) + !----------------------------------------------------------------------------- + ! Gets the dofmap for the whole domain + !----------------------------------------------------------------------------- + function get_whole_dofmap(self) result(map) - map => self%master_dofmap%get_master_dofmap(cell_lid) - return -end function get_cell_dofmap + implicit none -!----------------------------------------------------------------------------- -! Gets the dofmap for the whole domain -!----------------------------------------------------------------------------- -function get_whole_dofmap(self) result(map) + class(function_space_type), target, intent(in) :: self + integer(i_def), pointer :: map(:,:) - implicit none - class(function_space_type), target, intent(in) :: self - integer(i_def), pointer :: map(:,:) + map => self%master_dofmap%get_whole_master_dofmap() - map => self%master_dofmap%get_whole_master_dofmap() - return -end function get_whole_dofmap + end function get_whole_dofmap -!----------------------------------------------------------------------------- -! Gets the fractional levels for a column in this function space -!----------------------------------------------------------------------------- -function get_levels(self) result(levels) + !----------------------------------------------------------------------------- + ! Gets the fractional levels for a column in this function space + !----------------------------------------------------------------------------- + function get_levels(self) result(levels) - implicit none - class(function_space_type), target, intent(in) :: self - real(r_def), pointer :: levels(:) + implicit none - levels => self%fractional_levels - return -end function get_levels + class(function_space_type), target, intent(in) :: self + real(r_def), pointer :: levels(:) -!----------------------------------------------------------------------------- -! Gets the nodal coordinates of the function_space -!----------------------------------------------------------------------------- -function get_nodes(self) result(nodal_coords) + levels => self%fractional_levels - implicit none - class(function_space_type), target, intent(in) :: self + end function get_levels - real(r_def), pointer :: nodal_coords(:,:) + !----------------------------------------------------------------------------- + ! Gets the nodal coordinates of the function_space + !----------------------------------------------------------------------------- + function get_nodes(self) result(nodal_coords) - nodal_coords => self%nodal_coords + implicit none - return -end function get_nodes + class(function_space_type), target, intent(in) :: self -!----------------------------------------------------------------------------- -! Gets a flag for dofs on vertical boundaries -!----------------------------------------------------------------------------- -function get_boundary_dofs(self) result(boundary_dofs) + real(r_def), pointer :: nodal_coords(:,:) - implicit none - class(function_space_type), target, intent(in) :: self + nodal_coords => self%nodal_coords - integer(i_def), pointer :: boundary_dofs(:,:) + end function get_nodes - boundary_dofs => self%dof_on_vert_boundary(:,:) + !----------------------------------------------------------------------------- + ! Gets a flag for dofs on vertical boundaries + !----------------------------------------------------------------------------- + function get_boundary_dofs(self) result(boundary_dofs) - return -end function get_boundary_dofs + implicit none -!----------------------------------------------------------------------------- -! Gets enumerated integer for the function space -!----------------------------------------------------------------------------- -function which(self) result(fs) + class(function_space_type), target, intent(in) :: self - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: fs + integer(i_def), pointer :: boundary_dofs(:,:) - fs = self%fs + boundary_dofs => self%dof_on_vert_boundary(:,:) - return -end function which + end function get_boundary_dofs -!----------------------------------------------------------------------------- -! Gets the size of the function space -!----------------------------------------------------------------------------- -function get_dim_space(self) result(dim) + !----------------------------------------------------------------------------- + ! Gets enumerated integer for the function space + !----------------------------------------------------------------------------- + function which(self) result(fs) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: dim + implicit none - dim = self%dim_space + class(function_space_type), intent(in) :: self + integer(i_def) :: fs - return -end function get_dim_space + fs = self%fs -!----------------------------------------------------------------------------- -! Gets the size of the differential function space -!----------------------------------------------------------------------------- -function get_dim_space_diff(self) result(dim) + end function which - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: dim + !----------------------------------------------------------------------------- + ! Gets the size of the function space + !----------------------------------------------------------------------------- + function get_dim_space(self) result(dim) - dim = self%dim_space_diff + implicit none - return -end function get_dim_space_diff + class(function_space_type), intent(in) :: self + integer(i_def) :: dim -!----------------------------------------------------------------------------- -! Evaluates one of the listed (function_to_call) functions -!----------------------------------------------------------------------------- -function call_function(self, function_to_call, df, xi) result(evaluate) + dim = self%dim_space - implicit none + end function get_dim_space - class(function_space_type) :: self - integer(i_def), intent(in) :: function_to_call - integer(i_def), intent(in) :: df - real(r_def), intent(in) :: xi(3) - real(r_def), allocatable :: evaluate(:) + !----------------------------------------------------------------------------- + ! Gets the size of the diferential function space + !----------------------------------------------------------------------------- + function get_dim_space_diff(self) result(dim) - select case ( function_to_call ) + implicit none - case( BASIS ) - allocate( evaluate(self%dim_space) ) + class(function_space_type), intent(in) :: self + integer(i_def) :: dim + + dim = self%dim_space_diff + + end function get_dim_space_diff + + !----------------------------------------------------------------------------- + ! Evaluates one of the listed (function_to_call) functions + !----------------------------------------------------------------------------- + function call_function(self, function_to_call, df, xi) result(evaluate) + + implicit none + + class(function_space_type) :: self + integer(i_def), intent(in) :: function_to_call + integer(i_def), intent(in) :: df + real(r_def), intent(in) :: xi(3) + real(r_def), allocatable :: evaluate(:) + + select case (function_to_call) + case(BASIS) + allocate(evaluate(self%dim_space)) evaluate = evaluate_basis(self, df, xi) - case( DIFF_BASIS ) - allocate( evaluate(self%dim_space_diff) ) + case(DIFF_BASIS) + allocate(evaluate(self%dim_space_diff)) evaluate = evaluate_diff_basis(self, df, xi) case default - call log_event( & + call log_event(& 'function_to_call does not match the available enumerators', & - LOG_LEVEL_ERROR ) + LOG_LEVEL_ERROR) - end select + end select -end function call_function + end function call_function -!----------------------------------------------------------------------------- -! Evaluates a basis function at a point -!----------------------------------------------------------------------------- -function evaluate_basis(self, df, xi) result(p) + !----------------------------------------------------------------------------- + ! Evaluates a basis function at a point + !----------------------------------------------------------------------------- + function evaluate_basis(self, df, xi) result(p) - use polynomial_mod, only: poly1d + use polynomial_mod, only : poly1d - implicit none + implicit none - class(function_space_type), intent(in) :: self + class(function_space_type), intent(in) :: self - integer(i_def), intent(in) :: df - real(r_def), intent(in) :: xi(3) - real(r_def) :: p(self%dim_space) + integer(i_def), intent(in) :: df + real(r_def), intent(in) :: xi(3) + real(r_def) :: p(self%dim_space) - p(:) = poly1d( self%basis_order(1,df), xi(1), self%basis_x(:,1,df), self%basis_index(1,df)) & - * poly1d( self%basis_order(2,df), xi(2), self%basis_x(:,2,df), self%basis_index(2,df)) & - * poly1d( self%basis_order(3,df), xi(3), self%basis_x(:,3,df), self%basis_index(3,df)) & - * self%basis_vector(:,df) + p(:) = poly1d(self%basis_order(1, df), xi(1), self%basis_x(:, 1, df), self%basis_index(1, df)) & + * poly1d(self%basis_order(2, df), xi(2), self%basis_x(:, 2, df), self%basis_index(2, df)) & + * poly1d(self%basis_order(3, df), xi(3), self%basis_z(:, df), self%basis_index(3, df)) & + * self%basis_vector(:, df) -end function evaluate_basis + end function evaluate_basis -!----------------------------------------------------------------------------- -! Evaluates the differential of a basis function at a point -!----------------------------------------------------------------------------- -pure function evaluate_diff_basis(self, df, xi) result(evaluate) + !----------------------------------------------------------------------------- + ! Evaluates the differential of a basis function at a point + !----------------------------------------------------------------------------- + pure function evaluate_diff_basis(self, df, xi) result(evaluate) - use polynomial_mod, only: poly1d, poly1d_deriv + use polynomial_mod, only : poly1d, poly1d_deriv - implicit none + implicit none - class(function_space_type), intent(in) :: self - - integer(i_def), intent(in) :: df - real(r_def), intent(in) :: xi(3) - real(r_def) :: evaluate(self%dim_space_diff) - real(r_def) :: dpdx(3) - - dpdx(1) = poly1d_deriv( self%basis_order(1,df), xi(1) & - , self%basis_x(:,1,df), self%basis_index(1,df)) & - * poly1d ( self%basis_order(2,df), xi(2) & - , self%basis_x(:,2,df), self%basis_index(2,df)) & - * poly1d ( self%basis_order(3,df), xi(3) & - , self%basis_x(:,3,df), self%basis_index(3,df)) - - dpdx(2) = poly1d ( self%basis_order(1,df), xi(1) & - , self%basis_x(:,1,df), self%basis_index(1,df)) & - * poly1d_deriv( self%basis_order(2,df), xi(2) & - , self%basis_x(:,2,df), self%basis_index(2,df)) & - * poly1d ( self%basis_order(3,df), xi(3) & - , self%basis_x(:,3,df), self%basis_index(3,df)) - - dpdx(3) = poly1d ( self%basis_order(1,df), xi(1) & - , self%basis_x(:,1,df), self%basis_index(1,df)) & - * poly1d ( self%basis_order(2,df), xi(2) & - , self%basis_x(:,2,df), self%basis_index(2,df)) & - * poly1d_deriv( self%basis_order(3,df), xi(3) & - , self%basis_x(:,3,df), self%basis_index(3,df)) - - - if ( self%dim_space == 1 .and. self%dim_space_diff == 3 ) then - ! grad(p) - evaluate(1) = dpdx(1) - evaluate(2) = dpdx(2) - evaluate(3) = dpdx(3) - else if ( self%dim_space == 3 .and. self%dim_space_diff == 3 ) then - ! curl(p) - evaluate(1) = dpdx(2)*self%basis_vector(3,df) - dpdx(3)*self%basis_vector(2,df) - evaluate(2) = dpdx(3)*self%basis_vector(1,df) - dpdx(1)*self%basis_vector(3,df) - evaluate(3) = dpdx(1)*self%basis_vector(2,df) - dpdx(2)*self%basis_vector(1,df) - else if ( self%dim_space == 3 .and. self%dim_space_diff == 1 ) then - ! div(p) - evaluate(1) = dpdx(1)*self%basis_vector(1,df) + dpdx(2)*self%basis_vector(2,df) & - + dpdx(3)*self%basis_vector(3,df) - else if ( self%dim_space == 1 .and. self%dim_space_diff == 1 ) then - ! dp/dz - evaluate(1) = dpdx(3) - else - evaluate(:) = 0.0_r_def - end if - -end function evaluate_diff_basis + class(function_space_type), intent(in) :: self -!----------------------------------------------------------------------------- -! Evaluates the basis function for a given quadrature -!----------------------------------------------------------------------------- -subroutine compute_basis_function(self, basis, ndf, qp_h, qp_v, x_qp, z_qp) + integer(i_def), intent(in) :: df + real(r_def), intent(in) :: xi(3) + real(r_def) :: evaluate(self%dim_space_diff) + real(r_def) :: dpdx(3) - implicit none + dpdx(1) = poly1d_deriv(self%basis_order(1, df), xi(1), self%basis_x(:, 1, df), self%basis_index(1, df)) & + * poly1d (self%basis_order(2, df), xi(2), self%basis_x(:, 2, df), self%basis_index(2, df)) & + * poly1d (self%basis_order(3, df), xi(3), self%basis_z(:, df), self%basis_index(3, df)) + + dpdx(2) = poly1d (self%basis_order(1, df), xi(1), self%basis_x(:, 1, df), self%basis_index(1, df)) & + * poly1d_deriv(self%basis_order(2, df), xi(2), self%basis_x(:, 2, df), self%basis_index(2, df)) & + * poly1d (self%basis_order(3, df), xi(3), self%basis_z(:, df), self%basis_index(3, df)) + + dpdx(3) = poly1d (self%basis_order(1, df), xi(1), self%basis_x(:, 1, df), self%basis_index(1, df)) & + * poly1d (self%basis_order(2, df), xi(2), self%basis_x(:, 2, df), self%basis_index(2, df)) & + * poly1d_deriv(self%basis_order(3, df), xi(3), self%basis_z(:, df), self%basis_index(3, df)) + + if (self%dim_space == 1 .and. self%dim_space_diff == 3) then + ! grad(p) + evaluate(1) = dpdx(1) + evaluate(2) = dpdx(2) + evaluate(3) = dpdx(3) + else if (self%dim_space == 3 .and. self%dim_space_diff == 3) then + ! curl(p) + evaluate(1) = dpdx(2) * self%basis_vector(3, df) & + - dpdx(3) * self%basis_vector(2, df) + evaluate(2) = dpdx(3) * self%basis_vector(1, df) & + - dpdx(1) * self%basis_vector(3, df) - class(function_space_type), intent(in) :: self + evaluate(3) = dpdx(1) * self%basis_vector(2, df) & + - dpdx(2) * self%basis_vector(1, df) - integer(i_def), intent(in) :: ndf - integer(i_def), intent(in) :: qp_h - integer(i_def), intent(in) :: qp_v + else if (self%dim_space == 3 .and. self%dim_space_diff == 1) then + ! div(p) + evaluate(1) = dpdx(1) * self%basis_vector(1, df) & + + dpdx(2) * self%basis_vector(2, df) & + + dpdx(3) * self%basis_vector(3, df) + + else if (self%dim_space == 1 .and. self%dim_space_diff == 1) then + ! dp/dz + evaluate(1) = dpdx(3) + else + evaluate(:) = 0.0_r_def + end if - real(r_def), intent(in) :: x_qp (qp_h,2) - real(r_def), intent(in) :: z_qp (qp_v) + end function evaluate_diff_basis - real(r_def), intent(out) :: basis(self%dim_space,ndf,qp_h,qp_v) + !----------------------------------------------------------------------------- + ! Evaluates the basis function for a given quadrature + !----------------------------------------------------------------------------- + subroutine compute_basis_function(self, basis, ndf, qp_h, qp_v, x_qp, z_qp) - ! Local variables - loop counters - integer(i_def) :: df - integer(i_def) :: qp1 - integer(i_def) :: qp2 - real(r_def) :: xyz(3) + implicit none - do qp2=1, qp_v - xyz(3) = z_qp(qp2) - do qp1=1, qp_h - xyz(1) = x_qp(qp1,1) - xyz(2) = x_qp(qp1,2) - do df=1, ndf - basis(:,df,qp1,qp2) = self%evaluate_basis(df,xyz) + class(function_space_type), intent(in) :: self + + integer(i_def), intent(in) :: ndf + integer(i_def), intent(in) :: qp_h + integer(i_def), intent(in) :: qp_v + + real(r_def), intent(in) :: x_qp (qp_h, 2) + real(r_def), intent(in) :: z_qp (qp_v) + + real(r_def), intent(out) :: basis( self%dim_space, ndf, qp_h, qp_v ) + + ! Local variables - loop counters + integer(i_def) :: df + integer(i_def) :: qp1 + integer(i_def) :: qp2 + real(r_def) :: xyz(3) + + do qp2 = 1, qp_v + xyz(3) = z_qp(qp2) + do qp1 = 1, qp_h + xyz(1) = x_qp( qp1, 1 ) + xyz(2) = x_qp( qp1, 2 ) + do df = 1, ndf + basis(:, df, qp1, qp2) = self%evaluate_basis( df, xyz ) + end do + end do + end do + + end subroutine compute_basis_function + + !----------------------------------------------------------------------------- + ! Evaluates the differential basis function for a given quadrature + !----------------------------------------------------------------------------- + subroutine compute_diff_basis_function( self, & + dbasis, & + ndf, & + qp_h, & + qp_v, & + x_qp, & + z_qp ) + + implicit none + + class(function_space_type), intent(in) :: self + + integer(i_def), intent(in) :: ndf + integer(i_def), intent(in) :: qp_h + integer(i_def), intent(in) :: qp_v + + real(r_def), intent(in) :: x_qp(qp_h, 2) + real(r_def), intent(in) :: z_qp(qp_v) + + real(r_def), intent(out) :: dbasis( self%dim_space_diff, ndf, qp_h, qp_v ) + + ! local variables - loop counters + integer(i_def) :: df + integer(i_def) :: qp1 + integer(i_def) :: qp2 + real(r_def) :: xyz(3) + + do qp2 = 1, qp_v + xyz(3) = z_qp(qp2) + do qp1 = 1, qp_h + xyz(1) = x_qp( qp1, 1 ) + xyz(2) = x_qp( qp1, 2 ) + do df = 1, ndf + dbasis( :, df, qp1, qp2 ) = self%evaluate_diff_basis( df, xyz ) end do - end do - end do + end do + end do -end subroutine compute_basis_function + end subroutine compute_diff_basis_function -!----------------------------------------------------------------------------- -! Evaluates the differential basis function for a given quadrature -!----------------------------------------------------------------------------- -subroutine compute_diff_basis_function(self, & - dbasis, & - ndf, & - qp_h, & - qp_v, & - x_qp, & - z_qp) + !----------------------------------------------------------------------------- + ! Gets order for this space in the horizontal direction + !----------------------------------------------------------------------------- + !> @brief Gets the polynomial order for this space, returns an integer + !> @param[in] self the calling function space + !----------------------------------------------------------------------------- + function get_element_order_h(self) result (element_order_h) + implicit none - implicit none + class(function_space_type), intent(in) :: self + integer(i_def) :: element_order_h - class(function_space_type), intent(in) :: self + element_order_h = self%element_order_h - integer(i_def), intent(in) :: ndf - integer(i_def), intent(in) :: qp_h - integer(i_def), intent(in) :: qp_v + end function get_element_order_h - real(r_def), intent(in) :: x_qp(qp_h,2) - real(r_def), intent(in) :: z_qp(qp_v) + !----------------------------------------------------------------------------- + ! Gets order for this space in the vertical direction + !----------------------------------------------------------------------------- + !> @brief Gets the polynomial order for this space, returns an integer + !> @param[in] self the calling function space + !----------------------------------------------------------------------------- + function get_element_order_v(self) result (element_order_v) - real(r_def), intent(out) :: dbasis(self%dim_space_diff, ndf, qp_h, qp_v) + implicit none - ! local variables - loop counters - integer(i_def) :: df - integer(i_def) :: qp1 - integer(i_def) :: qp2 - real(r_def) :: xyz(3) + class(function_space_type), intent(in) :: self + integer(i_def) :: element_order_v - do qp2=1, qp_v - xyz(3) = z_qp(qp2) - do qp1=1, qp_h - xyz(1) = x_qp(qp1,1) - xyz(2) = x_qp(qp1,2) - do df=1, ndf - dbasis(:,df,qp1,qp2) = self%evaluate_diff_basis(df,xyz) - end do - end do - end do + element_order_v = self%element_order_v -end subroutine compute_diff_basis_function + end function get_element_order_v -!----------------------------------------------------------------------------- -! Gets order for this space -!----------------------------------------------------------------------------- -!> @brief Gets the polynomial order for this space, returns an integer -!> @param[in] self the calling function space -!----------------------------------------------------------------------------- -function get_element_order(self) result (element_order) + !----------------------------------------------------------------------------- + !> @details Gets the order for this function space in the horizontal direction + !> @return The order of the function space + function get_fs_order_h(self) result (fs_order_h) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: element_order + implicit none - element_order = self%element_order + class(function_space_type), intent(in) :: self + integer(i_def) :: fs_order_h - return -end function get_element_order + fs_order_h = self%fs_order_h -!----------------------------------------------------------------------------- -!> @details Gets the order for this function space -!> @return The order of the function space -function get_fs_order(self) result (fs_order) + end function get_fs_order_h - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: fs_order + !----------------------------------------------------------------------------- + !> @details Gets the order for this function space in the vertical direction + !> @return The order of the function space + function get_fs_order_v(self) result (fs_order_v) - fs_order = self%fs_order + implicit none - return -end function get_fs_order + class(function_space_type), intent(in) :: self + integer(i_def) :: fs_order_v -!----------------------------------------------------------------------------- -!> @details Gets the number of data values held at each dof -!> @return The number of data values held at each dof -function get_ndata(self) result (ndata) + fs_order_v = self%fs_order_v - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ndata + end function get_fs_order_v - ndata = self%ndata + !----------------------------------------------------------------------------- + !> @details Gets the number of data values held at each dof + !> @return The number of data values held at each dof + function get_ndata(self) result (ndata) - return -end function get_ndata + implicit none -!----------------------------------------------------------------------------- -! Gets the mapping from degrees of freedom to reference -! element entity. -!----------------------------------------------------------------------------- -function get_entity_dofs(self) result (entity_dofs) + class(function_space_type), intent(in) :: self + integer(i_def) :: ndata - implicit none + ndata = self%ndata - class(function_space_type), target, intent(in) :: self - integer(i_def), pointer :: entity_dofs(:) + end function get_ndata - entity_dofs => self%entity_dofs(:) + !> Returns whether the field data is ordered multi-data first + !> + !> @return Flag for if field data order is multi-data first + function is_ndata_first(self) result(flag) - return -end function get_entity_dofs + implicit none -!----------------------------------------------------------------------------- -! Gets mesh object for this space -!----------------------------------------------------------------------------- -!> @brief Gets the mesh object for this space -!> @param[in] self the calling function space -!> @return mesh Mesh Object -!----------------------------------------------------------------------------- -function get_mesh(self) result (mesh) + class(function_space_type), intent(in) :: self + logical(l_def) :: flag - implicit none + flag = self%ndata_first - class(function_space_type), intent(in) :: self - type(mesh_type), pointer :: mesh + end function is_ndata_first - mesh => self%mesh + !----------------------------------------------------------------------------- + ! Gets the mapping from degrees of freedom to reference + ! element entity. + !----------------------------------------------------------------------------- + function get_entity_dofs(self) result (entity_dofs) -end function get_mesh + implicit none -!----------------------------------------------------------------------------- -! Get id of mesh object for this space -!----------------------------------------------------------------------------- -!> @brief Gets the id of the mesh object for this space -!> @param[in] self the calling function space -!> @return mesh_id -!----------------------------------------------------------------------------- -function get_mesh_id(self) result (mesh_id) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: mesh_id + class(function_space_type), target, intent(in) :: self + integer(i_def), pointer :: entity_dofs(:) - mesh_id = self%mesh%get_id() + entity_dofs => self%entity_dofs(:) - return -end function get_mesh_id + end function get_entity_dofs -!----------------------------------------------------------------------------- -! Gets the array that holds the global indices of all dofs -!----------------------------------------------------------------------------- -subroutine get_global_dof_id(self, global_dof_id) + !----------------------------------------------------------------------------- + ! Gets mesh object for this space + !----------------------------------------------------------------------------- + !> @brief Gets the mesh object for this space + !> @param[in] self the calling function space + !> @return mesh Mesh Object + !----------------------------------------------------------------------------- + function get_mesh(self) result (mesh) - implicit none - class(function_space_type) :: self + implicit none - integer(i_halo_index) :: global_dof_id(:) + class(function_space_type), intent(in) :: self + type(mesh_type), pointer :: mesh - global_dof_id(:) = self%global_dof_id(:) + if ( associated (self%mesh) ) then + mesh => self%mesh + else + call log_event('Function space has null pointer to mesh!!!', log_level_error) + end if - return -end subroutine get_global_dof_id + end function get_mesh -!----------------------------------------------------------------------------- -! Gets the array that holds the global indices of cell dofs in 2D -! Horizontal domain -!----------------------------------------------------------------------------- -subroutine get_global_cell_dof_id_2d(self, global_cell_dof_id_2d) + !----------------------------------------------------------------------------- + ! Get id of mesh object for this space + !----------------------------------------------------------------------------- + !> @brief Gets the id of the mesh object for this space + !> @param[in] self the calling function space + !> @return mesh_id + !----------------------------------------------------------------------------- + function get_mesh_id(self) result (mesh_id) - implicit none - class(function_space_type), intent(in) :: self + implicit none - integer(i_def), intent(out) :: global_cell_dof_id_2d(:) + class(function_space_type), intent(in) :: self + integer(i_def) :: mesh_id - global_cell_dof_id_2d(:) = self%global_cell_dof_id_2d(:) + mesh_id = self%mesh%get_id() - return -end subroutine get_global_cell_dof_id_2d + end function get_mesh_id -!----------------------------------------------------------------------------- -! Gets the array that holds the global indices of edge dofs in 2D -! Horizontal domain -!----------------------------------------------------------------------------- -subroutine get_global_edge_dof_id_2d(self, global_edge_dof_id_2d) + !----------------------------------------------------------------------------- + ! Gets the array that holds the global indices of all dofs + !----------------------------------------------------------------------------- + function get_global_dof_id(self) result(global_dof_id) - implicit none - class(function_space_type), intent(in) :: self + implicit none - integer(i_def), intent(out) :: global_edge_dof_id_2d(:) + class(function_space_type), target, intent(in) :: self - global_edge_dof_id_2d(:) = self%global_edge_dof_id_2d(:) + integer(i_halo_index), pointer :: global_dof_id(:) - return -end subroutine get_global_edge_dof_id_2d + global_dof_id => self%global_dof_id(:) -!----------------------------------------------------------------------------- -! Gets the array that holds the global indices of vertex dofs in 2D -! Horizontal domain -!----------------------------------------------------------------------------- -subroutine get_global_vert_dof_id_2d(self, global_vert_dof_id_2d) + end function get_global_dof_id - implicit none - class(function_space_type), intent(in) :: self + !----------------------------------------------------------------------------- + ! Gets the array that holds the global indices of cell dofs in 2D + ! Horizontal domain + !----------------------------------------------------------------------------- + subroutine get_global_cell_dof_id_2d(self, global_cell_dof_id_2d) - integer(i_def), intent(out) :: global_vert_dof_id_2d(:) + implicit none - global_vert_dof_id_2d(:) = self%global_vert_dof_id_2d(:) + class(function_space_type), intent(in) :: self - return -end subroutine get_global_vert_dof_id_2d + integer(i_def), intent(out) :: global_cell_dof_id_2d(:) -!----------------------------------------------------------------------------- -! Gets the index within the dofmap of the last "owned" dof -!----------------------------------------------------------------------------- -function get_last_dof_owned(self) result (last_dof_owned) + global_cell_dof_id_2d(:) = self%global_cell_dof_id_2d(:) - implicit none - class(function_space_type) :: self + end subroutine get_global_cell_dof_id_2d - integer(i_def) :: last_dof_owned + !----------------------------------------------------------------------------- + ! Gets the array that holds the global indices of edge dofs in 2D + ! Horizontal domain + !----------------------------------------------------------------------------- + subroutine get_global_edge_dof_id_2d(self, global_edge_dof_id_2d) - last_dof_owned = self%last_dof_owned + implicit none - return -end function get_last_dof_owned + class(function_space_type), intent(in) :: self -!----------------------------------------------------------------------------- -! Gets the index within the dofmap of the last "annexed" dof -!----------------------------------------------------------------------------- -function get_last_dof_annexed(self) result (last_dof_annexed) + integer(i_def), intent(out) :: global_edge_dof_id_2d(:) - implicit none - class(function_space_type) :: self + global_edge_dof_id_2d(:) = self%global_edge_dof_id_2d(:) - integer(i_def) :: last_dof_annexed + end subroutine get_global_edge_dof_id_2d - last_dof_annexed = self%last_dof_annexed + !----------------------------------------------------------------------------- + ! Gets the array that holds the global indices of vertex dofs in 2D + ! Horizontal domain + !----------------------------------------------------------------------------- + subroutine get_global_vert_dof_id_2d(self, global_vert_dof_id_2d) - return -end function get_last_dof_annexed + implicit none -!----------------------------------------------------------------------------- -! Gets the index within the dofmap of the last dof in the specified halo -!----------------------------------------------------------------------------- -function get_last_dof_halo_any(self, depth) result (last_dof_halo) + class(function_space_type), intent(in) :: self - implicit none - class(function_space_type) :: self - integer(i_def), intent(in) :: depth + integer(i_def), intent(out) :: global_vert_dof_id_2d(:) - integer(i_def) :: last_dof_halo + global_vert_dof_id_2d(:) = self%global_vert_dof_id_2d(:) - last_dof_halo = self%last_dof_halo(depth) + end subroutine get_global_vert_dof_id_2d - return -end function get_last_dof_halo_any + !----------------------------------------------------------------------------- + ! Gets the index within the dofmap of the last "owned" dof + !----------------------------------------------------------------------------- + function get_last_dof_owned(self) result (last_dof_owned) -!----------------------------------------------------------------------------- -! Gets the index within the dofmap of the last dof in the deepest halo -!----------------------------------------------------------------------------- -function get_last_dof_halo_deepest(self) result (last_dof_halo) - implicit none - class(function_space_type) :: self + implicit none - integer(i_def) :: last_dof_halo + class(function_space_type) :: self - last_dof_halo = self%last_dof_halo(size(self%last_dof_halo)) + integer(i_def) :: last_dof_owned - return -end function get_last_dof_halo_deepest + last_dof_owned = self%last_dof_owned + end function get_last_dof_owned -!> @brief Returns whether fields on this function space are readonly -!> @return return_readonly Flag describes if fields on this function space -!> will be readonly -function is_readonly(self) result(return_readonly) - implicit none + !----------------------------------------------------------------------------- + ! Gets the index within the dofmap of the last "annexed" dof + !----------------------------------------------------------------------------- + function get_last_dof_annexed(self) result (last_dof_annexed) - class(function_space_type), intent(in) :: self - logical(l_def) :: return_readonly + implicit none - return_readonly = self%readonly + class(function_space_type) :: self -end function is_readonly + integer(i_def) :: last_dof_annexed + last_dof_annexed = self%last_dof_annexed -!> @brief Returns whether fields on this function space can be written to -!> @return return_writable Flag describes if fields on this function space -!> can be written to -function is_writable(self) result(return_writable) - implicit none + end function get_last_dof_annexed - class(function_space_type), intent(in) :: self - logical(l_def) :: return_writable + !----------------------------------------------------------------------------- + ! Gets the index within the dofmap of the last dof in the specified halo + !----------------------------------------------------------------------------- + function get_last_dof_halo_any(self, depth) result (last_dof_halo) - return_writable = .not.self%readonly + implicit none -end function is_writable + class(function_space_type) :: self + integer(i_def), intent(in) :: depth -!> @brief Get the instance of a stencil dofmap for a given shape and size -!> @param[in] stencil_shape The shape identifier for the stencil dofmap to create -!> @param[in] stencil_extent The extent of the stencil excluding the centre cell -!> @return map the stencil_dofmap object to return -function get_stencil_dofmap(self, stencil_shape, stencil_extent) result(map) - use stencil_dofmap_mod, only: stencil_dofmap_type + integer(i_def) :: last_dof_halo - implicit none + last_dof_halo = self%last_dof_halo(depth) - class(function_space_type), intent(inout) :: self - integer(i_def), intent(in) :: stencil_shape - integer(i_def), intent(in) :: stencil_extent - type(stencil_dofmap_type), pointer :: map ! return value + end function get_last_dof_halo_any - type(linked_list_item_type), pointer :: loop => null() + !----------------------------------------------------------------------------- + ! Gets the index within the dofmap of the last dof in the deepest halo + !----------------------------------------------------------------------------- + function get_last_dof_halo_deepest(self) result (last_dof_halo) - integer(i_def) :: id + implicit none - map => null() + class(function_space_type) :: self - ! Calculate id of the stencil_dofmap we want - id = generate_stencil_dofmap_id( stencil_shape, stencil_extent ) + integer(i_def) :: last_dof_halo + last_dof_halo = self%last_dof_halo(ubound(self%last_dof_halo,1)) - ! point at the head of the stencil_dofmap linked list - loop => self%dofmap_list%get_head() + end function get_last_dof_halo_deepest - ! loop through list - do - if ( .not. associated(loop) ) then - ! At the end of list and we didn't find it - ! create stencil dofmap and add it - call self%dofmap_list%insert_item(stencil_dofmap_type(stencil_shape, & - stencil_extent, & - self%ndof_cell, & - self%mesh, & + !> @brief Returns whether fields on this function space are readonly + !> @return return_readonly Flag describes if fields on this function space + !> will be readonly + function is_readonly(self) result(return_readonly) + + implicit none + + class(function_space_type), intent(in) :: self + logical(l_def) :: return_readonly + + return_readonly = self%readonly + + end function is_readonly + + + !> @brief Returns whether fields on this function space can be written to + !> @return return_writable Flag describes if fields on this function space + !> can be written to + function is_writable(self) result(return_writable) + + implicit none + + class(function_space_type), intent(in) :: self + logical(l_def) :: return_writable + + return_writable = .not.self%readonly + + end function is_writable + + !> @brief Get the instance of a stencil dofmap for a given shape and size + !> @param[in] stencil_shape The shape identifier for the stencil dofmap to create + !> @param[in] stencil_extent The extent of the stencil excluding the centre cell + !> @return map the stencil_dofmap object to return + function get_stencil_dofmap(self, stencil_shape, stencil_extent) result(map) + + use stencil_dofmap_mod, only : stencil_dofmap_type + + implicit none + + class(function_space_type), intent(inout) :: self + integer(i_def), intent(in) :: stencil_shape + integer(i_def), intent(in) :: stencil_extent + + type(stencil_dofmap_type), pointer :: map ! return value + type(linked_list_item_type), pointer :: loop => null() + + integer(i_def) :: id + + map => null() + + ! Calculate id of the stencil_dofmap we want + id = generate_stencil_dofmap_id(stencil_shape, stencil_extent) + + + ! point at the head of the stencil_dofmap linked list + loop => self%dofmap_list%get_head() + + ! loop through list + do + if (.not. associated(loop)) then + ! At the end of list and we didn't find it + ! create stencil dofmap and add it + + call self%dofmap_list%insert_item(stencil_dofmap_type(stencil_shape, & + stencil_extent, & + self%ndof_cell, & + self%mesh, & self%master_dofmap)) - ! At this point the desired stencil dofmap is the tail of the list - ! so just retrieve it and exit loop + ! At this point the desired stencil dofmap is the tail of the list + ! so just retrieve it and exit loop - loop => self%dofmap_list%get_tail() + loop => self%dofmap_list%get_tail() - ! 'cast' to the stencil_dofmap_type - select type(v => loop%payload) + ! 'cast' to the stencil_dofmap_type + select type(v => loop%payload) type is (stencil_dofmap_type) map => v - end select - exit - - end if - ! otherwise search list for the id we want - if ( id == loop%payload%get_id() ) then - ! 'cast' to the stencil_dofmap_type - select type(v => loop%payload) + end select + exit + + end if + ! otherwise search list for the id we want + if (id == loop%payload%get_id()) then + ! 'cast' to the stencil_dofmap_type + select type(v => loop%payload) type is (stencil_dofmap_type) map => v - end select - exit - end if - loop => loop%next - end do -end function get_stencil_dofmap + end select + exit + end if + loop => loop%next + end do -!> @brief Get the instance of a 2D stencil dofmap for a given shape and size -!> @param[in] stencil_shape The shape identifier for the stencil dofmap to create -!> @param[in] stencil_extent The extent of the stencil excluding the centre cell -!> @return map The stencil_dofmap object to return -function get_stencil_2D_dofmap(self, stencil_shape, stencil_extent) result(map) + end function get_stencil_dofmap - use stencil_2d_dofmap_mod, only: stencil_2D_dofmap_type + !> @brief Get the instance of a 2D stencil dofmap for a given shape and size + !> @param[in] stencil_shape The shape identifier for the stencil dofmap to create + !> @param[in] stencil_extent The extent of the stencil excluding the centre cell + !> @return map The stencil_dofmap object to return + function get_stencil_2D_dofmap(self, stencil_shape, stencil_extent) result(map) - implicit none + use stencil_2D_dofmap_mod, only : stencil_2D_dofmap_type - class(function_space_type), intent(inout) :: self - integer(i_def), intent(in) :: stencil_shape - integer(i_def), intent(in) :: stencil_extent - type(stencil_2D_dofmap_type), pointer :: map ! return value + implicit none - type(linked_list_item_type), pointer :: loop => null() + class(function_space_type), intent(inout) :: self + integer(i_def), intent(in) :: stencil_shape + integer(i_def), intent(in) :: stencil_extent + type(stencil_2D_dofmap_type), pointer :: map ! return value - integer(i_def) :: id + type(linked_list_item_type), pointer :: loop => null() - map => null() + integer(i_def) :: id - ! Calculate id of the stencil_dofmap we want - id = generate_stencil_dofmap_id( stencil_shape, stencil_extent ) + map => null() + ! Calculate id of the stencil_dofmap we want + id = generate_stencil_dofmap_id(stencil_shape, stencil_extent) - ! point at the head of the stencil_dofmap linked list - loop => self%dofmap_list%get_head() + ! point at the head of the stencil_dofmap linked list + loop => self%dofmap_list%get_head() - ! loop through list - do - if ( .not. associated(loop) ) then - ! At the end of list and we didn't find it - ! create stencil dofmap and add it + ! loop through list + do + if (.not. associated(loop)) then + ! At the end of list and we didn't find it + ! create stencil dofmap and add it - call self%dofmap_list%insert_item(stencil_2D_dofmap_type(stencil_shape, & + call self%dofmap_list%insert_item(stencil_2D_dofmap_type( & + stencil_shape, & stencil_extent, & self%ndof_cell, & self%mesh, & self%master_dofmap)) - ! At this point the desired stencil dofmap is the tail of the list - ! so just retrieve it and exit loop + ! At this point the desired stencil dofmap is the tail of the list + ! so just retrieve it and exit loop - loop => self%dofmap_list%get_tail() + loop => self%dofmap_list%get_tail() - ! 'cast' to the stencil_dofmap_type - select type(v => loop%payload) + ! 'cast' to the stencil_dofmap_type + select type(v => loop%payload) type is (stencil_2D_dofmap_type) map => v - end select - exit - - end if - ! otherwise search list for the id we want - if ( id == loop%payload%get_id() ) then - ! 'cast' to the stencil_dofmap_type - select type(v => loop%payload) + end select + exit + + end if + ! otherwise search list for the id we want + if (id == loop%payload%get_id()) then + ! 'cast' to the stencil_dofmap_type + select type(v => loop%payload) type is (stencil_2D_dofmap_type) map => v - end select - exit - end if - loop => loop%next - end do -end function get_stencil_2D_dofmap + end select + exit + end if + loop => loop%next + end do -!---------------------------------------------------------------------------- -!> @brief Returns count of colours used in colouring member mesh. -!> -!> @return Number of colours used to colour this mesh. -!---------------------------------------------------------------------------- -function get_ncolours(self) result(ncolours) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def) :: ncolours + end function get_stencil_2D_dofmap - ncolours = self%mesh%get_ncolours() + !----------------------------------------------------------------------------- + !> @brief Returns count of colours used in colouring member mesh. + !> + !> @return Number of colours used to colour this mesh. + !----------------------------------------------------------------------------- + function get_ncolours(self) result(ncolours) -end function get_ncolours + implicit none -!============================================================================ -!> @brief Populates args with colouring info from member mesh. -!> -!> @param[out] ncolours Number of colours used to colour member mesh. -!> @param[out] ncells_per_colour Count of cells in each colour. -!> @param[out] colour_map Indices of cells in each colour. -!============================================================================ -subroutine get_colours(self, ncolours, ncells_per_colour, colour_map) - implicit none - class(function_space_type), intent(in) :: self - integer(i_def), intent(out) :: ncolours - integer(i_def), pointer, intent(out) :: ncells_per_colour(:) - integer(i_def), pointer, intent(out) :: colour_map(:,:) + class(function_space_type), intent(in) :: self + integer(i_def) :: ncolours + ncolours = self%mesh%get_ncolours() - call self%mesh%get_colours(ncolours, ncells_per_colour, colour_map) + end function get_ncolours -end subroutine get_colours + !============================================================================= + !> @brief Populates args with colouring info from member mesh. + !> + !> @param[out] ncolours Number of colours used to colour member mesh. + !> @param[out] ncells_per_colour Count of cells in each colour. + !> @param[out] colour_map Indices of cells in each colour. + !============================================================================= + subroutine get_colours(self, ncolours, ncells_per_colour, colour_map) -!----------------------------------------------------------------------------- -! Function to clear up objects - called by destructor -!----------------------------------------------------------------------------- -!> @details Explcitly deallocates any allocatable arrays in the function space -!> to avoid memory leaks -!> @return Error status variable -subroutine clear(self) + implicit none - implicit none + class(function_space_type), intent(in) :: self + integer(i_def), intent(out) :: ncolours + integer(i_def), pointer, intent(out) :: ncells_per_colour(:) + integer(i_def), pointer, intent(out) :: colour_map(:,:) - class (function_space_type), intent(inout) :: self - - if (allocated(self%entity_dofs)) deallocate( self%entity_dofs ) - if (allocated(self%nodal_coords)) deallocate( self%nodal_coords ) - if (allocated(self%basis_order)) deallocate( self%basis_order ) - if (allocated(self%basis_index)) deallocate( self%basis_index ) - if (allocated(self%basis_vector)) deallocate( self%basis_vector ) - if (allocated(self%basis_x)) deallocate( self%basis_x ) - if (allocated(self%global_dof_id)) deallocate( self%global_dof_id ) - if (allocated(self%global_cell_dof_id_2d)) & - deallocate( self%global_cell_dof_id_2d ) - if (allocated(self%global_edge_dof_id_2d)) & - deallocate( self%global_edge_dof_id_2d ) - if (allocated(self%global_vert_dof_id_2d)) & - deallocate( self%global_vert_dof_id_2d ) - if (allocated(self%last_dof_halo)) deallocate( self%last_dof_halo ) - if (allocated(self%fractional_levels))deallocate( self%fractional_levels ) - if (allocated(self%dof_on_vert_boundary)) & - deallocate( self%dof_on_vert_boundary ) - call self%master_dofmap%clear() - call self%dofmap_list%clear() - - nullify(self%mesh) - -end subroutine clear - -function get_cell_orientation(self, cell) result(orientation) - implicit none - class(function_space_type) :: self - integer, intent(in) :: cell - integer, dimension(:), pointer :: orientation - orientation => null() -end function get_cell_orientation + call self%mesh%get_colours(ncolours, ncells_per_colour, colour_map) -!----------------------------------------------------------------------------- -! Function space destructor -!----------------------------------------------------------------------------- + end subroutine get_colours -subroutine function_space_destructor(self) + !----------------------------------------------------------------------------- + !> @brief Returns the halo depth of the function space + !> + !> @return Depth of the halo + !----------------------------------------------------------------------------- + function get_halo_depth(self) result(halo_depth) - implicit none + implicit none + + class(function_space_type), intent(in) :: self + integer(i_def) :: halo_depth + + halo_depth = self%mesh%get_halo_depth() + + end function get_halo_depth + + !----------------------------------------------------------------------------- + ! Function to clear up objects - called by destructor + !----------------------------------------------------------------------------- + !> @details Explcitly deallocates any allocatable arrays in the function space + !> to avoid memory leaks + !> @return Error status variable + subroutine clear(self) + + implicit none + + class (function_space_type), intent(inout) :: self + + if (allocated(self%entity_dofs)) deallocate(self%entity_dofs) + if (allocated(self%nodal_coords)) deallocate(self%nodal_coords) + if (allocated(self%basis_order)) deallocate(self%basis_order) + if (allocated(self%basis_index)) deallocate(self%basis_index) + if (allocated(self%basis_vector)) deallocate(self%basis_vector) + if (allocated(self%basis_x)) deallocate(self%basis_x) + if (allocated(self%basis_z)) deallocate(self%basis_z) + if (allocated(self%global_dof_id)) deallocate(self%global_dof_id) + if (allocated(self%global_cell_dof_id_2d)) & + deallocate(self%global_cell_dof_id_2d) + if (allocated(self%global_edge_dof_id_2d)) & + deallocate(self%global_edge_dof_id_2d) + if (allocated(self%global_vert_dof_id_2d)) & + deallocate(self%global_vert_dof_id_2d) + if (allocated(self%last_dof_halo)) deallocate(self%last_dof_halo) + if (allocated(self%fractional_levels))deallocate(self%fractional_levels) + if (allocated(self%dof_on_vert_boundary)) & + deallocate(self%dof_on_vert_boundary) + + call self%master_dofmap%clear() + call self%dofmap_list%clear() + + nullify(self%mesh) + + end subroutine clear + + !----------------------------------------------------------------------------- + ! Function space destructor + !----------------------------------------------------------------------------- + + subroutine function_space_destructor(self) + + implicit none - type (function_space_type), intent(inout) :: self + type (function_space_type), intent(inout) :: self - call self%clear() + call self%clear() -end subroutine function_space_destructor + end subroutine function_space_destructor end module function_space_mod diff --git a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/operator/columnwise_operator_mod.f90 b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/operator/columnwise_operator_mod.f90 index 0abd0389bf..62dcf14348 100644 --- a/src/psyclone/tests/test_files/dynamo0p3/infrastructure/operator/columnwise_operator_mod.f90 +++ b/src/psyclone/tests/test_files/dynamo0p3/infrastructure/operator/columnwise_operator_mod.f90 @@ -37,6 +37,7 @@ ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Modified by: I. Kavcic, Met Office +! J. Dendy, Met Office ! !> @brief A module providing columnwise operator related classes. !> @@ -457,8 +458,8 @@ subroutine extract_mesh_fs_info(self) fs_to=>self%get_fs_to() fs_from=>self%get_fs_from() ! Extract function types and other function space information - self%ndof_face_to = fs_to%get_ndof_face() - self%ndof_face_from = fs_from%get_ndof_face() + self%ndof_face_to = fs_to%get_ndof_face_v() + self%ndof_face_from = fs_from%get_ndof_face_v() self%ndof_interior_to = fs_to%get_ndof_interior() self%ndof_interior_from = fs_from%get_ndof_interior() ! The following two formulae for the total number of DoFs only diff --git a/src/psyclone/transformations.py b/src/psyclone/transformations.py index bf60af1909..a081b029d8 100644 --- a/src/psyclone/transformations.py +++ b/src/psyclone/transformations.py @@ -35,6 +35,7 @@ # A. B. G. Chalk STFC Daresbury Lab # J. Henrichs, Bureau of Meteorology # Modified I. Kavcic, J. G. Wallwork, O. Brunt and L. Turner, Met Office +# J. Dendy, Met Office ''' This module provides the various transformations that can be applied to PSyIR nodes. There are both general and API-specific transformation @@ -2154,7 +2155,8 @@ class Dynamo0p3KernelConstTrans(Transformation): # ndofs per 3D cell for different function spaces on a quadrilateral # element for different orders. Formulas kindly provided by Tom Melvin and - # Thomas Gibson. See the Qr table at http://femtable.org/background.html, + # Thomas Gibson (modified in 2024 to reflect splitting of element orders). + # See the Qr table at http://femtable.org/background.html, # for computed values of w0, w1, w2 and w3 up to order 7. # Note: w2*trace spaces have dofs only on cell faces and no volume dofs. # As there is currently no dedicated structure for face dofs in kernel @@ -2163,18 +2165,22 @@ class Dynamo0p3KernelConstTrans(Transformation): # for w2htrace space, in the vertical (2) for w2vtrace space and all (6) # for w2trace space. - space_to_dofs = {"w3": (lambda n: (n+1)**3), - "w2": (lambda n: 3*(n+2)*(n+1)**2), - "w1": (lambda n: 3*(n+2)**2*(n+1)), - "w0": (lambda n: (n+2)**3), - "wtheta": (lambda n: (n+2)*(n+1)**2), - "w2h": (lambda n: 2*(n+2)*(n+1)**2), - "w2v": (lambda n: (n+2)*(n+1)**2), - "w2broken": (lambda n: 3*(n+1)**2*(n+2)), - "wchi": (lambda n: (n+1)**3), - "w2trace": (lambda n: 6*(n+1)**2), - "w2htrace": (lambda n: 4*(n+1)**2), - "w2vtrace": (lambda n: 2*(n+1)**2)} + space_to_dofs = {"w3": (lambda k_h, k_v: (k_h+1)*(k_h+1)*(k_v+1)), + "w2": (lambda k_h, k_v: 2*(k_h+2)*(k_h+1)*(k_v+1) + + (k_h+1)*(k_h+1)*(k_v+2)), + "w1": (lambda k_h, k_v: 2*(k_h+1)*(k_h+2)*(k_v+2) + + (k_h+2)*(k_h+2)*(k_v+1)), + "w0": (lambda k_h, k_v: (k_h+2)*(k_h+2)*(k_v+2)), + "wtheta": (lambda k_h, k_v: (k_h+1)*(k_h+1)*(k_v+2)), + "w2h": (lambda k_h, k_v: 2*(k_h+1)*(k_h+2)*(k_v+1)), + "w2v": (lambda k_h, k_v: (k_h+1)*(k_h+1)*(k_v+2)), + "w2broken": (lambda k_h, k_v: 2*(k_h+1)*(k_h+2)*(k_v+1) + + (k_h+1)*(k_h+1)*(k_v+2)), + "wchi": (lambda k_h, k_v: (k_h+1)*(k_h+1)*(k_v+1)), + "w2trace": (lambda k_h, k_v: 4*(k_h+1)*(k_v+1) + + 2*(k_h+1)**2), + "w2htrace": (lambda k_h, k_v: 4*(k_h+1)*(k_v+1)), + "w2vtrace": (lambda k_h, k_v: 2*(k_h+1)**2)} def __str__(self): return ("Makes the number of degrees of freedom, the number of " @@ -2192,41 +2198,48 @@ def name(self): def apply(self, node, options=None): # pylint: disable=too-many-statements, too-many-locals '''Transforms a kernel so that the values for the number of degrees of - freedom (if a valid value for the element_order arg is - provided), the number of quadrature points (if the quadrature + freedom (if valid values for the element_order_h and element_order_v + args are provided), the number of quadrature points (if the quadrature arg is set to True) and the number of layers (if a valid value for the number_of_layers arg is provided) are constant in a kernel rather than being passed in by argument. - The "cellshape", "element_order" and "number_of_layers" - arguments are provided to mirror the namelist values that are - input into an LFRic model when it is run. + The "cellshape", "element_order_h", "element_order_v" and + "number_of_layers" arguments are provided to mirror the namelist values + that are input into an LFRic model when it is run. Quadrature support is currently limited to XYoZ in ths transformation. In the case of XYoZ the number of quadrature points (for horizontal and vertical) are set to the - element_order + 3 in the LFRic infrastructure so their value - is derived. + MAX(element_order_h, element_order_v) + 3 in the LFRic infrastructure + so their value is derived. :param node: a kernel node. :type node: :py:obj:`psyclone.domain.lfric.LFRicKern` :param options: a dictionary with options for transformations. :type options: Optional[Dict[str, Any]] - :param str options["cellshape"]: the shape of the cells. This is\ - provided as it helps determine the number of dofs a field has\ - for a particular function space. Currently only "quadrilateral"\ + :param str options["cellshape"]: the shape of the cells. This is + provided as it helps determine the number of dofs a field has + for a particular function space. Currently only "quadrilateral" is supported which is also the default value. - :param int options["element_order"]: the order of the cell. In \ - combination with cellshape, this determines the number of \ - dofs a field has for a particular function space. If it is set \ - to None (the default) then the dofs values are not set as \ - constants in the kernel, otherwise they are. - :param int options["number_of_layers"]: the number of vertical \ - layers in the LFRic model mesh used for this particular run. If \ - this is set to None (the default) then the nlayers value is not \ + :param int options["element_order_h"]: the polynomial order of the + cell in the horizontal. In combination with cellshape and + element_order_v, this determines the number of dofs a field has + for a particular function space. If it is set to None (the + default), then the dofs values are not set as constants in the + kernel, otherwise they are. + :param int options["element_order_v"]: the polynomial order of the + cell in the vertical. In combination with cellshape and + element_order_h, this determines the number of dofs a field has + for a particular function space. If it is set to None (the + default), then the dofs values are not set as constants in the + kernel, otherwise they are. + :param int options["number_of_layers"]: the number of vertical + layers in the LFRic model mesh used for this particular run. If + this is set to None (the default) then the nlayers value is not set as a constant in the kernel, otherwise it is. - :param bool options["quadrature"]: whether the number of quadrature \ - points values are set as constants in the kernel (True) or not \ + :param bool options["quadrature"]: whether the number of quadrature + points values are set as constants in the kernel (True) or not (False). The default is False. ''' @@ -2297,7 +2310,8 @@ def make_constant(symbol_table, arg_position, value, options = {} number_of_layers = options.get("number_of_layers", None) quadrature = options.get("quadrature", False) - element_order = options.get("element_order", None) + element_order_h = options.get("element_order_h", None) + element_order_v = options.get("element_order_v", None) kernel = node arg_list_info = KernCallArgList(kernel) @@ -2320,10 +2334,10 @@ def make_constant(symbol_table, arg_position, value, if kernel.eval_shapes == ["gh_quadrature_xyoz"]: make_constant(symbol_table, arg_list_info.nqp_positions[0]["horizontal"], - element_order+3) + max(element_order_h, element_order_v)+3) make_constant(symbol_table, arg_list_info.nqp_positions[0]["vertical"], - element_order+3) + max(element_order_h, element_order_v)+3) else: raise TransformationError( f"Error in Dynamo0p3KernelConstTrans transformation. " @@ -2331,7 +2345,7 @@ def make_constant(symbol_table, arg_position, value, f"found {kernel.eval_shapes}.") const = LFRicConstants() - if element_order is not None: + if (element_order_h is not None) and (element_order_h is not None): # Modify the symbol table for degrees of freedom here. for info in arg_list_info.ndf_positions: if (info.function_space.lower() in @@ -2345,7 +2359,8 @@ def make_constant(symbol_table, arg_position, value, try: ndofs = Dynamo0p3KernelConstTrans. \ space_to_dofs[ - info.function_space](element_order) + info.function_space](element_order_h, + element_order_v) except KeyError as err: raise InternalError( f"Error in Dynamo0p3KernelConstTrans " @@ -2368,18 +2383,21 @@ def validate(self, node, options=None): :param options: a dictionary with options for transformations. :type options: Optional[Dict[str, Any]] :param str options["cellshape"]: the shape of the elements/cells. - :param int options["element_order"]: the order of the elements/cells. + :param int options["element_order_h"]: the horizontal order of the\ + elements/cells. + :param int options["element_order_v"]: the vertical order of the\ + elements/cells. :param int options["number_of_layers"]: the number of layers to use. :param bool options["quadrature"]: whether quadrature dimension sizes \ should or shouldn't be set as constants in a kernel. :raises TransformationError: if the node argument is not a \ dynamo 0.3 kernel, the cellshape argument is not set to \ - "quadrilateral", the element_order argument is not a 0 or a \ - positive integer, the number of layers argument is not a \ - positive integer, the quadrature argument is not a boolean, \ - neither element order nor number of layers arguments are set \ - (as the transformation would then do nothing), or the \ + "quadrilateral", the element_order_h or element_order_v arguments\ + are not a 0 or a positive integer, the number of layers argument\ + is not a positive integer, the quadrature argument is not a\ + boolean, neither element orders nor number of layers arguments are\ + set (as the transformation would then do nothing), or the \ quadrature argument is True but the element order is not \ provided (as the former needs the latter). @@ -2392,7 +2410,8 @@ def validate(self, node, options=None): if not options: options = {} cellshape = options.get("cellshape", "quadrilateral") - element_order = options.get("element_order", None) + element_order_h = options.get("element_order_h", None) + element_order_v = options.get("element_order_v", None) number_of_layers = options.get("number_of_layers", None) quadrature = options.get("quadrature", False) if cellshape.lower() != "quadrilateral": @@ -2402,13 +2421,17 @@ def validate(self, node, options=None): f"cellshape must be set to 'quadrilateral' but found " f"'{cellshape}'.") - if element_order is not None and \ - (not isinstance(element_order, int) or element_order < 0): + if (element_order_h is not None and element_order_v is not None) and \ + (not isinstance(element_order_h, int) or + not isinstance(element_order_v, int) or + element_order_h < 0 or + element_order_v < 0): # element order must be 0 or a positive integer raise TransformationError( f"Error in Dynamo0p3KernelConstTrans transformation. The " - f"element_order argument must be >= 0 but found " - f"'{element_order}'.") + f"element_order_h and element_order_v argument must be >= 0 " + f"but found element_order_h = '{element_order_h}', " + f"element_order_v = '{element_order_v}'.") if number_of_layers is not None and \ (not isinstance(number_of_layers, int) or number_of_layers < 1): @@ -2425,19 +2448,23 @@ def validate(self, node, options=None): f"quadrature argument must be boolean but found " f"'{quadrature}'.") - if element_order is None and not number_of_layers: - # As a minimum, element order or number of layers must have values. + if (element_order_h is None or element_order_v is None) and \ + not number_of_layers: + # As a minimum, element orders or number of layers must have + # values. raise TransformationError( "Error in Dynamo0p3KernelConstTrans transformation. At least " - "one of element_order or number_of_layers must be set " - "otherwise this transformation does nothing.") + "one of [element_order_h, element_order_v] or " + "number_of_layers must be set otherwise this transformation " + "does nothing.") - if quadrature and element_order is None: + if quadrature and (element_order_h is None or element_order_v is None): # if quadrature then element order raise TransformationError( "Error in Dynamo0p3KernelConstTrans transformation. If " - "quadrature is set then element_order must also be set (as " - "the values of the former are derived from the latter.") + "quadrature is set then both element_order_h and " + "element_order_v must also be set (as the values of the " + "former are derived from the latter.") class ACCEnterDataTrans(Transformation): diff --git a/tutorial/practicals/LFRic/building_code/1_simple_kernels/README.md b/tutorial/practicals/LFRic/building_code/1_simple_kernels/README.md index 06217ad29e..28fa5d8b31 100644 --- a/tutorial/practicals/LFRic/building_code/1_simple_kernels/README.md +++ b/tutorial/practicals/LFRic/building_code/1_simple_kernels/README.md @@ -145,7 +145,7 @@ however the specific calls may be different). 1) Create a `W0` function space object with single-valued field data points (`ndata_sz`) and initialise a pointer to it ```fortran - fs_w0 = function_space_type( mesh, element_order, W0, ndata_sz ) + fs_w0 = function_space_type( mesh, element_order_h, element_order_v, W0, ndata_sz ) fs_w0_ptr => fs_w0 ``` diff --git a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/simple_kernels_alg_mod.x90 b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/simple_kernels_alg_mod.x90 index 1cdde199f4..1f3e907063 100644 --- a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/simple_kernels_alg_mod.x90 +++ b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/simple_kernels_alg_mod.x90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! ! ----------------------------------------------------------------------------- ! A module that creates fields on W0 and W3 function spaces and calls kernels @@ -59,14 +60,15 @@ contains !> @brief Creates and initialises fields on W0 and W3 function spaces !> @param[in] mesh Partitioned 3D mesh object - !> @param[in] element_order Finite-element method (FEM) order - subroutine simple_kernels_alg(mesh, element_order) + !> @param[in] element_order_h Finite-element method (FEM) order in horizontal + !> @param[in] element_order_v Finite-element method (FEM) order in vertical + subroutine simple_kernels_alg(mesh, element_order_, element_order_v) implicit none ! Input arguments from the driver: Mesh and FEM order type(mesh_type), intent(in) :: mesh - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h, element_order_v ! Function spaces W0 and W3 and fields on them type(function_space_type), target :: fs_w0 type(function_space_type), target :: fs_w3 @@ -81,9 +83,11 @@ contains call log_event( "simple_kernels_alg: Running algorithm", LOG_LEVEL_INFO ) ! Create W0 and W3 function spaces with single-valued data points - fs_w0 = function_space_type( mesh, element_order, W0, ndata_sz ) + fs_w0 = function_space_type( mesh, element_order_h, element_order_v, & + W0, ndata_sz ) fs_w0_ptr => fs_w0 - fs_w3 = function_space_type( mesh, element_order, W3, ndata_sz ) + fs_w3 = function_space_type( mesh, element_order_h, element_order_v, & + W3, ndata_sz ) fs_w3_ptr => fs_w3 ! Create fields on W0 and W3 function spaces diff --git a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/simple_kernels_driver.f90 b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/simple_kernels_driver.f90 index f997a116d7..3649360f4d 100644 --- a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/simple_kernels_driver.f90 +++ b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/simple_kernels_driver.f90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! !------------------------------------------------------------------------------ ! Drives the execution of the algorithms and kernels in Example 1. @@ -78,16 +79,20 @@ program simple_kernels_driver ! Vertical extrusion parameters integer(kind=i_def) :: number_of_layers real(kind=r_def) :: domain_top - ! Finite element method (FEM) order - integer(kind=i_def) :: element_order + ! Finite-element method (FEM) order in the horizontal direction + integer(kind=i_def) :: element_order_h + ! Finite-element method (FEM) order in the vertical direction + integer(kind=i_def) :: element_order_v !----------------------------------------------------------------------------- ! Set model parameters !----------------------------------------------------------------------------- call log_event( "Setting 'simple_kernels_driver' model parameters", & LOG_LEVEL_INFO ) - ! Finite-element method (FEM) order - element_order = 0 + ! Finite-element method (FEM) order in the horizontal + element_order_h = 0 + ! Finite-element method (FEM) order in the vertical + element_order_v = 0 ! Height of atmosphere in meters domain_top = 10000.0_r_def ! Number of layers in the vertical @@ -99,7 +104,7 @@ program simple_kernels_driver xproc = 1 yproc = 1 max_stencil_depth = 0 - local_rank = 0 + local_rank = 0 total_ranks = 1 !----------------------------------------------------------------------------- @@ -131,7 +136,7 @@ program simple_kernels_driver ! Call algorithms !----------------------------------------------------------------------------- call log_event( "Calling 'simple_kernels_alg'", LOG_LEVEL_INFO ) - call simple_kernels_alg(mesh, element_order) + call simple_kernels_alg(mesh, element_order_h, element_order_v) !----------------------------------------------------------------------------- ! Tidy up after a run diff --git a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/solutions/simple_kernels_alg_mod.x90 b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/solutions/simple_kernels_alg_mod.x90 index 74c3b22195..4a498edebd 100644 --- a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/solutions/simple_kernels_alg_mod.x90 +++ b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part1/solutions/simple_kernels_alg_mod.x90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! ! ----------------------------------------------------------------------------- ! A module that creates fields on W0 and W3 function spaces and calls kernels @@ -59,14 +60,15 @@ contains !> @brief Creates and initialises fields on W0 and W3 function spaces !> @param[in] mesh Partitioned 3D mesh object - !> @param[in] element_order Finite-element method (FEM) order - subroutine simple_kernels_alg(mesh, element_order) + !> @param[in] element_order_h Finite-element method (FEM) order in horizontal + !> @param[in] element_order_v Finite-element method (FEM) order in vertical + subroutine simple_kernels_alg(mesh, element_order_h, element_order_v) implicit none ! Input arguments from the driver: Mesh and FEM order type(mesh_type), intent(in) :: mesh - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h, element_order_v ! Function spaces W0 and W3 and fields on them type(function_space_type), target :: fs_w0 type(function_space_type), target :: fs_w3 @@ -81,9 +83,11 @@ contains call log_event( "simple_kernels_alg: Running algorithm", LOG_LEVEL_INFO ) ! Create W0 and W3 function spaces with single-valued data points - fs_w0 = function_space_type( mesh, element_order, W0, ndata_sz ) + fs_w0 = function_space_type( mesh, element_order_h, element_order_v, W0, & + ndata_sz ) fs_w0_ptr => fs_w0 - fs_w3 = function_space_type( mesh, element_order, W3, ndata_sz ) + fs_w3 = function_space_type( mesh, element_order_h, element_order_v, W3, & + ndata_sz ) fs_w3_ptr => fs_w3 ! Create fields on W0 and W3 function spaces diff --git a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/simple_kernels_alg_mod.x90 b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/simple_kernels_alg_mod.x90 index 90e5708b16..59c82b6012 100644 --- a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/simple_kernels_alg_mod.x90 +++ b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/simple_kernels_alg_mod.x90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! ! ----------------------------------------------------------------------------- ! A module that creates fields on W0 and W3 function spaces and calls generic @@ -59,14 +60,15 @@ contains !> @brief Creates and adds fields on multiple function spaces !> @param[in] mesh Partitioned 3D mesh object - !> @param[in] element_order Finite-element method (FEM) order - subroutine simple_kernels_alg(mesh, element_order) + !> @param[in] element_order_h Finite-element method (FEM) order in horizontal + !> @param[in] element_order_v Finite-element method (FEM) order in vertical + subroutine simple_kernels_alg(mesh, element_order_h, element_order_v) implicit none ! Input arguments from the driver: Mesh and FEM order type(mesh_type), intent(in) :: mesh - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h, element_order_v ! Function spaces W2 and Wtheta and fields on them type(function_space_type), target :: fs_w0 type(function_space_type), target :: fs_w3 @@ -82,9 +84,11 @@ contains call log_event( "simple_kernels_alg: Running algorithm", LOG_LEVEL_INFO ) ! Create W0 and W3 function spaces with single-valued data points - fs_w0 = function_space_type( mesh, element_order, W0, ndata_sz ) + fs_w0 = function_space_type( mesh, element_order_h, element_order_v, W0, & + ndata_sz ) fs_w0_ptr => fs_w0 - fs_w3 = function_space_type( mesh, element_order, W3, ndata_sz ) + fs_w3 = function_space_type( mesh, element_order_h, element_order_v, W3, & + ndata_sz ) fs_w3_ptr => fs_w3 ! Create fields on W0 function space diff --git a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/simple_kernels_driver.f90 b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/simple_kernels_driver.f90 index f997a116d7..0bb53e2a77 100644 --- a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/simple_kernels_driver.f90 +++ b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/simple_kernels_driver.f90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! !------------------------------------------------------------------------------ ! Drives the execution of the algorithms and kernels in Example 1. @@ -78,16 +79,20 @@ program simple_kernels_driver ! Vertical extrusion parameters integer(kind=i_def) :: number_of_layers real(kind=r_def) :: domain_top - ! Finite element method (FEM) order - integer(kind=i_def) :: element_order + ! Finite-element method (FEM) order in the horizontal direction + integer(kind=i_def) :: element_order_h + ! Finite-element method (FEM) order in the vertical direction + integer(kind=i_def) :: element_order_v !----------------------------------------------------------------------------- ! Set model parameters !----------------------------------------------------------------------------- call log_event( "Setting 'simple_kernels_driver' model parameters", & LOG_LEVEL_INFO ) - ! Finite-element method (FEM) order - element_order = 0 + ! Finite-element method (FEM) order in horizontal + element_order_h = 0 + ! Finite-element method (FEM) order in vertical + element_order_v = 0 ! Height of atmosphere in meters domain_top = 10000.0_r_def ! Number of layers in the vertical @@ -99,7 +104,7 @@ program simple_kernels_driver xproc = 1 yproc = 1 max_stencil_depth = 0 - local_rank = 0 + local_rank = 0 total_ranks = 1 !----------------------------------------------------------------------------- @@ -131,7 +136,7 @@ program simple_kernels_driver ! Call algorithms !----------------------------------------------------------------------------- call log_event( "Calling 'simple_kernels_alg'", LOG_LEVEL_INFO ) - call simple_kernels_alg(mesh, element_order) + call simple_kernels_alg(mesh, element_order_h, element_order_v) !----------------------------------------------------------------------------- ! Tidy up after a run diff --git a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/solutions/simple_kernels_alg_mod.x90 b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/solutions/simple_kernels_alg_mod.x90 index b5f8ca77c0..4e22b55812 100644 --- a/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/solutions/simple_kernels_alg_mod.x90 +++ b/tutorial/practicals/LFRic/building_code/1_simple_kernels/part2/solutions/simple_kernels_alg_mod.x90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! ! ----------------------------------------------------------------------------- ! A module that creates fields on W0 and W3 function spaces and calls generic @@ -59,14 +60,17 @@ contains !> @brief Creates and adds fields on multiple function spaces !> @param[in] mesh Partitioned 3D mesh object - !> @param[in] element_order Finite-element method (FEM) order - subroutine simple_kernels_alg(mesh, element_order) + !> @param[in] element_order_h Finite-element method (FEM) order in the + !> horizontal direction + !> @param[in] element_order_v Finite-element method (FEM) order in the + !> vertical direction + subroutine simple_kernels_alg(mesh, element_order_h, element_order_v) implicit none ! Input arguments from the driver: Mesh and FEM order type(mesh_type), intent(in) :: mesh - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h, element_order_v ! Function spaces W2 and Wtheta and fields on them type(function_space_type), target :: fs_w0 type(function_space_type), target :: fs_w3 @@ -82,9 +86,11 @@ contains call log_event( "simple_kernels_alg: Running algorithm", LOG_LEVEL_INFO ) ! Create W0 and W3 function spaces with single-valued data points - fs_w0 = function_space_type( mesh, element_order, W0, ndata_sz ) + fs_w0 = function_space_type( mesh, element_order_h, element_order_v, W0, & + ndata_sz ) fs_w0_ptr => fs_w0 - fs_w3 = function_space_type( mesh, element_order, W3, ndata_sz ) + fs_w3 = function_space_type( mesh, element_order_h, element_order_v, W3, & + ndata_sz ) fs_w3_ptr => fs_w3 ! Create fields on W0 function space diff --git a/tutorial/practicals/LFRic/building_code/2_built_ins/builtins_alg_mod.x90 b/tutorial/practicals/LFRic/building_code/2_built_ins/builtins_alg_mod.x90 index b8a5181f7b..7a833fc76f 100644 --- a/tutorial/practicals/LFRic/building_code/2_built_ins/builtins_alg_mod.x90 +++ b/tutorial/practicals/LFRic/building_code/2_built_ins/builtins_alg_mod.x90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! ! ----------------------------------------------------------------------------- ! A module that creates fields on W0 and W3 function spaces and uses PSyclone @@ -57,14 +58,17 @@ contains !> @brief Creates and adds fields on W0 and W3 function spaces using built-ins !> @param[in] mesh Partitioned 3D mesh object - !> @param[in] element_order Finite-element method (FEM) order - subroutine builtins_alg(mesh, element_order) + !> @param[in] element_order_h Finite-element method (FEM) order in the + !> horizontal direction + !> @param[in] element_order_v Finite-element method (FEM) order in the + !> vertical direction + subroutine builtins_alg(mesh, element_order_h, element_order_v) implicit none ! Input arguments from the driver: Mesh and FEM order type(mesh_type), intent(in) :: mesh - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h, element_order_v ! Function spaces W0 and W3 and fields on them type(function_space_type), target :: fs_w0 type(function_space_type), target :: fs_w3 @@ -82,9 +86,11 @@ contains call log_event( "builtins_alg: Running algorithm", LOG_LEVEL_INFO ) ! Create W0 and W3 function spaces with single-valued data points - fs_w0 = function_space_type( mesh, element_order, W0, ndata_sz ) + fs_w0 = function_space_type( mesh, element_order_h, element_order_v, W0, & + ndata_sz ) fs_w0_ptr => fs_w0 - fs_w3 = function_space_type( mesh, element_order, W3, ndata_sz ) + fs_w3 = function_space_type( mesh, element_order_h, element_order_v, W3, & + ndata_sz ) fs_w3_ptr => fs_w3 ! Create fields on W0 function space diff --git a/tutorial/practicals/LFRic/building_code/2_built_ins/builtins_driver.f90 b/tutorial/practicals/LFRic/building_code/2_built_ins/builtins_driver.f90 index 7f19252176..63ca871e10 100644 --- a/tutorial/practicals/LFRic/building_code/2_built_ins/builtins_driver.f90 +++ b/tutorial/practicals/LFRic/building_code/2_built_ins/builtins_driver.f90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! !------------------------------------------------------------------------------ ! Drives the execution of the algorithms and kernels in Example 2. @@ -78,15 +79,18 @@ program builtins_driver ! Vertical extrusion parameters integer(kind=i_def) :: number_of_layers real(kind=r_def) :: domain_top - ! Finite element method (FEM) order - integer(kind=i_def) :: element_order + ! Finite-element method (FEM) order in the horizontal direction + integer(kind=i_def) :: element_order_h + ! Finite-element method (FEM) order in the vertical direction + integer(kind=i_def) :: element_order_v !----------------------------------------------------------------------------- ! Set model parameters !----------------------------------------------------------------------------- call log_event( "Setting 'builtins_driver' model parameters", LOG_LEVEL_INFO ) - ! FEM order - element_order = 0 + ! FEM orders + element_order_h = 0 + element_order_v = 0 ! Height of atmosphere in meters domain_top = 10000.0_r_def ! Number of layers in the vertical @@ -98,7 +102,7 @@ program builtins_driver xproc = 1 yproc = 1 max_stencil_depth = 0 - local_rank = 0 + local_rank = 0 total_ranks = 1 !----------------------------------------------------------------------------- @@ -130,7 +134,7 @@ program builtins_driver ! Call algorithms !----------------------------------------------------------------------------- call log_event( "Calling 'builtins_alg'", LOG_LEVEL_INFO ) - call builtins_alg(mesh, element_order) + call builtins_alg(mesh, element_order_h, element_order_v) !----------------------------------------------------------------------------- ! Tidy up after a run diff --git a/tutorial/practicals/LFRic/building_code/2_built_ins/solutions/builtins_alg_mod.x90 b/tutorial/practicals/LFRic/building_code/2_built_ins/solutions/builtins_alg_mod.x90 index fd390ce8a0..3f9a12e42b 100644 --- a/tutorial/practicals/LFRic/building_code/2_built_ins/solutions/builtins_alg_mod.x90 +++ b/tutorial/practicals/LFRic/building_code/2_built_ins/solutions/builtins_alg_mod.x90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! ! ----------------------------------------------------------------------------- ! A module that creates fields on W0 and W3 function spaces and uses PSyclone @@ -57,14 +58,17 @@ contains !> @brief Creates and adds fields on W0 and W3 function spaces using built-ins !> @param[in] mesh Partitioned 3D mesh object - !> @param[in] element_order Finite-element method (FEM) order - subroutine builtins_alg(mesh, element_order) + !> @param[in] element_order_h Finite-element method (FEM) order in the + !> horizontal direction + !> @param[in] element_order_v Finite-element method (FEM) order in the + !> vertical direction + subroutine builtins_alg(mesh, element_order_h, element_order_v) implicit none ! Input arguments from the driver: Mesh and FEM order type(mesh_type), intent(in) :: mesh - integer(i_def), intent(in) :: element_order + integer(i_def), intent(in) :: element_order_h, element_order_v ! Function spaces W0 and W3 and fields on them type(function_space_type), target :: fs_w0 type(function_space_type), target :: fs_w3 @@ -82,9 +86,11 @@ contains call log_event( "builtins_alg: Running algorithm", LOG_LEVEL_INFO ) ! Create W0 and W3 function spaces with single-valued data points - fs_w0 = function_space_type( mesh, element_order, W0, ndata_sz ) + fs_w0 = function_space_type( mesh, element_order_h, element_order_v, W0, & + ndata_sz ) fs_w0_ptr => fs_w0 - fs_w3 = function_space_type( mesh, element_order, W3, ndata_sz ) + fs_w3 = function_space_type( mesh, element_order_h, element_order_v, W3, & + ndata_sz ) fs_w3_ptr => fs_w3 ! Create fields on W0 function space diff --git a/tutorial/practicals/LFRic/building_code/3_time_evolution/configuration.nml b/tutorial/practicals/LFRic/building_code/3_time_evolution/configuration.nml index 6aa39c6bd5..d6cbaeda56 100644 --- a/tutorial/practicals/LFRic/building_code/3_time_evolution/configuration.nml +++ b/tutorial/practicals/LFRic/building_code/3_time_evolution/configuration.nml @@ -19,7 +19,8 @@ &finite_element cellshape = 'quadrilateral' - element_order = 0 + element_order_h = 0 + element_order_v = 0 coordinate_order = 1 / diff --git a/tutorial/practicals/LFRic/building_code/3_time_evolution/solutions/configuration.nml b/tutorial/practicals/LFRic/building_code/3_time_evolution/solutions/configuration.nml index 122120fbfe..00cf63c61c 100644 --- a/tutorial/practicals/LFRic/building_code/3_time_evolution/solutions/configuration.nml +++ b/tutorial/practicals/LFRic/building_code/3_time_evolution/solutions/configuration.nml @@ -19,7 +19,8 @@ &finite_element cellshape = 'quadrilateral' - element_order = 0 + element_order_h = 0 + element_order_v = 0 coordinate_order = 1 / diff --git a/tutorial/practicals/LFRic/building_code/3_time_evolution/time_evolution_driver.f90 b/tutorial/practicals/LFRic/building_code/3_time_evolution/time_evolution_driver.f90 index 46aa518883..29e24430bf 100644 --- a/tutorial/practicals/LFRic/building_code/3_time_evolution/time_evolution_driver.f90 +++ b/tutorial/practicals/LFRic/building_code/3_time_evolution/time_evolution_driver.f90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! !------------------------------------------------------------------------------ ! Drives the execution of the algorithms and kernels in Example 3. @@ -64,7 +65,7 @@ program time_evolution_driver only : domain_top, & number_of_layers use finite_element_config_mod, & - only : element_order + only : element_order_h, element_order_v use partitioning_config_mod, & only : panel_xproc, & panel_yproc @@ -162,7 +163,8 @@ program time_evolution_driver call log_event( "Creating perturbation field on W3 space", LOG_LEVEL_INFO ) ! Create W3 function space with single-valued data points - fs_w3 = function_space_type( mesh, element_order, W3, ndata_sz ) + fs_w3 = function_space_type( mesh, element_order_h, element_order_v, W3, & + ndata_sz ) fs_w3_ptr => fs_w3 ! Create perturbation field on W3 function space call perturbation%initialise( vector_space = fs_w3_ptr, & diff --git a/tutorial/practicals/LFRic/building_code/4_psydata/configuration.nml b/tutorial/practicals/LFRic/building_code/4_psydata/configuration.nml index 6aa39c6bd5..d6cbaeda56 100644 --- a/tutorial/practicals/LFRic/building_code/4_psydata/configuration.nml +++ b/tutorial/practicals/LFRic/building_code/4_psydata/configuration.nml @@ -19,7 +19,8 @@ &finite_element cellshape = 'quadrilateral' - element_order = 0 + element_order_h = 0 + element_order_v = 0 coordinate_order = 1 / diff --git a/tutorial/practicals/LFRic/building_code/4_psydata/time_evolution_driver.f90 b/tutorial/practicals/LFRic/building_code/4_psydata/time_evolution_driver.f90 index a5bc1200a6..a16b15b125 100644 --- a/tutorial/practicals/LFRic/building_code/4_psydata/time_evolution_driver.f90 +++ b/tutorial/practicals/LFRic/building_code/4_psydata/time_evolution_driver.f90 @@ -32,6 +32,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- ! Author: I. Kavcic, Met Office +! Modified by: J. Dendy, Met Office ! !------------------------------------------------------------------------------ ! Drives the execution of the algorithms and kernels in Example 3. @@ -63,7 +64,7 @@ program time_evolution_driver only : domain_top, & number_of_layers use finite_element_config_mod, & - only : element_order + only : element_order_h, element_order_v use partitioning_config_mod, & only : panel_xproc, & panel_yproc @@ -161,7 +162,8 @@ program time_evolution_driver call log_event( "Creating perturbation field on W3 space", LOG_LEVEL_INFO ) ! Create W3 function space with single-valued data points - fs_w3 = function_space_type( mesh, element_order, W3, ndata_sz ) + fs_w3 = function_space_type( mesh, element_order_h, element_order_v, W3, & + ndata_sz ) fs_w3_ptr => fs_w3 ! Create perturbation field on W3 function space call perturbation%initialise( vector_space = fs_w3_ptr, & diff --git a/tutorial/practicals/LFRic/building_code/gungho_lib/finite_element_config_mod.f90 b/tutorial/practicals/LFRic/building_code/gungho_lib/finite_element_config_mod.f90 index e70f1493a2..48098d7602 100644 --- a/tutorial/practicals/LFRic/building_code/gungho_lib/finite_element_config_mod.f90 +++ b/tutorial/practicals/LFRic/building_code/gungho_lib/finite_element_config_mod.f90 @@ -35,6 +35,9 @@ ! ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. ! ----------------------------------------------------------------------------- +! Modified by: J. Dendy, Met Office +! ----------------------------------------------------------------------------- +! !> Manages the finite_element namelist. !> module finite_element_config_mod @@ -58,7 +61,8 @@ module finite_element_config_mod integer(i_native), public, protected :: cellshape integer(i_def), public, protected :: coordinate_order - integer(i_def), public, protected :: element_order + integer(i_def), public, protected :: element_order_h + integer(i_def), public, protected :: element_order_v integer(i_def), public, protected :: nqp_exact logical(l_def), public, protected :: rehabilitate logical(l_def), public, protected :: vorticity_in_w1 @@ -184,7 +188,7 @@ subroutine read_namelist( file_unit, local_rank, & integer(i_native), intent(in) :: local_rank integer(i_native), intent(out) :: dummy_cellshape - integer(i_def) :: buffer_integer_i_def(2) + integer(i_def) :: buffer_integer_i_def(3) integer(i_native) :: buffer_integer_i_native(1) integer(i_native) :: buffer_logical_l_def(2) @@ -192,7 +196,8 @@ subroutine read_namelist( file_unit, local_rank, & namelist /finite_element/ cellshape, & coordinate_order, & - element_order, & + element_order_h, & + element_order_v, & rehabilitate, & vorticity_in_w1 @@ -200,7 +205,8 @@ subroutine read_namelist( file_unit, local_rank, & cellshape = unset_key coordinate_order = imdi - element_order = imdi + element_order_h = imdi + element_order_v = imdi nqp_exact = imdi rehabilitate = .false. vorticity_in_w1 = .false. @@ -218,21 +224,25 @@ subroutine read_namelist( file_unit, local_rank, & buffer_integer_i_native(1) = dummy_cellshape buffer_integer_i_def(1) = coordinate_order - buffer_integer_i_def(2) = element_order + buffer_integer_i_def(2) = element_order_h + buffer_integer_i_def(3) = element_order_v buffer_logical_l_def(1) = merge( 1, 0, rehabilitate ) buffer_logical_l_def(2) = merge( 1, 0, vorticity_in_w1 ) dummy_cellshape = buffer_integer_i_native(1) coordinate_order = buffer_integer_i_def(1) - element_order = buffer_integer_i_def(2) + element_order_h = buffer_integer_i_def(2) + element_order_v = buffer_integer_i_def(3) rehabilitate = buffer_logical_l_def(1) /= 0 vorticity_in_w1 = buffer_logical_l_def(2) /= 0 - if ( any([element_order] == imdi) .or. & - any([element_order] == rmdi) ) then + if ( any([element_order_h] == imdi) .or. & + any([element_order_h] == rmdi) .or. & + any([element_order_v] == imdi) .or. & + any([element_order_v] == rmdi) ) then nqp_exact = imdi else - nqp_exact = element_order + 3 + nqp_exact = MAX(element_order_h, element_order_v) + 3 end if namelist_loaded = .true. @@ -288,7 +298,8 @@ subroutine finite_element_final() cellshape = int(imdi,i_native) coordinate_order = imdi - element_order = imdi + element_order_h = imdi + element_order_v = imdi nqp_exact = imdi rehabilitate = .false. vorticity_in_w1 = .false. diff --git a/tutorial/practicals/LFRic/single_node/3_sequential/kernel_constants.py b/tutorial/practicals/LFRic/single_node/3_sequential/kernel_constants.py index 56aff03d34..1586d3b497 100644 --- a/tutorial/practicals/LFRic/single_node/3_sequential/kernel_constants.py +++ b/tutorial/practicals/LFRic/single_node/3_sequential/kernel_constants.py @@ -32,6 +32,7 @@ # POSSIBILITY OF SUCH DAMAGE. # ----------------------------------------------------------------------------- # Authors: R. W. Ford and N. Nobre, STFC Daresbury Lab +# Modified by: J. Dendy, Met Office '''An example PSyclone transformation script which makes ndofs, nqp* @@ -58,10 +59,14 @@ # associated kernel value constant (rather than passing it in by # argument). NUMBER_OF_LAYERS = 20 -# The element order to use when modifying a kernel to make the +# The horizontal element order to use when modifying a kernel to make the # associated degrees of freedom values constant (rather than passing # them in by argument). -ELEMENT_ORDER = 0 +ELEMENT_ORDER_H = 0 +# The vertical element order to use when modifying a kernel to make the +# associated degrees of freedom values constant (rather than passing +# them in by argument). +ELEMENT_ORDER_V = 0 # Whether or not to make the number of quadrature points constant in a # kernel (rather than passing them in by argument). CONSTANT_QUADRATURE = True @@ -82,7 +87,8 @@ def trans(psyir): try: const_trans.apply(kernel, {"number_of_layers": NUMBER_OF_LAYERS, - "element_order": ELEMENT_ORDER, + "element_order_h": ELEMENT_ORDER_H, + "element_order_v": ELEMENT_ORDER_V, "quadrature": CONSTANT_QUADRATURE}) except TransformationError: print(f" Failed to modify kernel '{kernel.name}'")