From ae5689d2d13e4c50a3b4ac0db375caa3bfb62649 Mon Sep 17 00:00:00 2001 From: Bernard Gingold Date: Fri, 20 Dec 2024 19:56:03 +0100 Subject: [PATCH] MoM implementation. --- MoM/PMCHW_RWG_mod.f90 | 3726 +++++++++++++++++++++++++++++++ MoM/RWG_basis_mod.f90 | 487 ++++ MoM/constants_mod.f90 | 64 + MoM/gauss_quad_formulas_mod.f90 | 3059 +++++++++++++++++++++++++ MoM/io_mod.f90 | 908 ++++++++ MoM/is_close_mod.f90 | 106 + MoM/math_funcs_mod.f90 | 159 ++ MoM/mesh_mod.f90 | 1094 +++++++++ MoM/test_utilities.f90 | 277 +++ MoM/working_precision.f90 | 22 + 10 files changed, 9902 insertions(+) create mode 100644 MoM/PMCHW_RWG_mod.f90 create mode 100644 MoM/RWG_basis_mod.f90 create mode 100644 MoM/constants_mod.f90 create mode 100644 MoM/gauss_quad_formulas_mod.f90 create mode 100644 MoM/io_mod.f90 create mode 100644 MoM/is_close_mod.f90 create mode 100644 MoM/math_funcs_mod.f90 create mode 100644 MoM/mesh_mod.f90 create mode 100644 MoM/test_utilities.f90 create mode 100644 MoM/working_precision.f90 diff --git a/MoM/PMCHW_RWG_mod.f90 b/MoM/PMCHW_RWG_mod.f90 new file mode 100644 index 00000000..4fe1f7e1 --- /dev/null +++ b/MoM/PMCHW_RWG_mod.f90 @@ -0,0 +1,3726 @@ +module PMCHW_RWG_mod +!!============================================================================== +! This module uses PMCHW (Poggio, Miller, Chang, Harrington, and Wu) +! formulation for combining EFIE and MFIE to simulate electromagnetic +! scattering on an arbitrary surface. The scattering problem is solved using +! boundary element method, BEM, (often called mathod of moments) on a +! RWG-basis (Rao, Wilson, and Glisson) using Gelerkin's method. Integrals are +! solved numerically using Gaussian quadrature formulas. +! +! The problem consists of two regions, inside and outside of the closed +! surface. The regions have different permeability and permitivity. +! +! +! Abbreviations: +! CS - Closed Surface +! OS - Open Surface +! GQ - Gaussian Quadrature +! GQF - Gaussian Quadrature Formula +! GLQF - Gauss-Legendre Quadrature Formula +! EFIE - Electric Field Integral Formulation +! MFIE - Magnetic Field Integral Formulation +! +! Last edited: March 7th 2021. +!!============================================================================== + + !!==============!! + ! Use statements ! + !================!============================================================ + use iso_fortran_env , only: real32, real64, real128 + use ieee_arithmetic , only: ieee_is_finite + use working_precision, only: wp + use RWG_basis_mod , only: RWG_basis_type + use math_funcs_mod , only: cross_prod_3D + use math_funcs_mod , only: plane_wave + use constants_mod , only: PI + use constants_mod , only: I_IMAG + use constants_mod , only: ZERO_CMPLX + use constants_mod , only: ZERO + use constants_mod , only: UNITY + use constants_mod , only: PI4_INV + use is_close_mod , only: is_close + use io_mod , only: r8mat_write + use gauss_quad_formulas_mod, only: GQF_triangle_3pnt + use gauss_quad_formulas_mod, only: GQF_Legendre_3pnt + use gauss_quad_formulas_mod, only: GQF_Legendre_5pnt + + implicit none + + !!===================!! + ! External procedures ! + !=====================!======================================================= + external :: CGESV + external :: ZGESV + + !!=================================!! + ! Public types/procedures/constants ! + !===================================!========================================= + public :: PMCHW_RWG_type ! Main type + + integer , parameter, public :: NUM_REGIONS = 2 + integer , parameter, public :: INC_FIELD_TYPE_PLANE_WAVE = 1 + integer , parameter, public :: INC_FIELD_TYPE_SPHERICAL_WAVE = 2 + integer , parameter, public :: OUTER_REGION_IDX = 1 + integer , parameter, public :: INNER_REGION_IDX = 2 + integer , parameter, public :: X_IDX = 1 + integer , parameter, public :: Y_IDX = 2 + integer , parameter, public :: Z_IDX = 3 + integer , parameter, public :: SPATIAL_DIM = 3 + integer , parameter, public :: NUM_FACE_VERTICES = 3 + integer , parameter, public :: NUM_FACES_IN_BASIS = 2 + integer , parameter, public :: GQF_WEIGHT_IDX = 1 + integer , parameter, public :: GQF_XI_IDX = 2 + integer , parameter, public :: GQF_ETA_IDX = 3 + integer , parameter, public :: GQF_ZETA_IDX = 4 + integer , parameter, public :: GQF_LEGENDRE_POINT_IDX = 2 + real(wp) , parameter, public :: PROP_CONST_OBS_PNT_SRC_CLOSE = -1._wp!e-11 + logical , parameter, public :: CAUCHY = .false. + + public :: eval_green_func_integrals + public :: eval_outer_integrals + public :: face_pair_integral_EFIE + public :: face_pair_integral_MFIE + public :: surface_intgr_solution + public :: line_intgr_solution + public :: inner_intgr_of_subtr_terms + public :: green_func_smoothened + public :: calc_edge_unit_normals + public :: map_GLQF_pnt_to_triangle_edge + public :: dbl_singularity_intgr + public :: eval_subtracted_terms + public :: calc_green_func + public :: calc_grad_of_green_func + public :: Cauchy_principal_value + + !====================================! + ! Private types/procedures/constants ! + !====================================!======================================== + + private + !!------------------------!! + ! Derived type definitions ! + !--------------------------!-------------------------------------------------- + + + !!---------!! + ! Main type ! + !-----------!----------------------------------------------------------------- + type PMCHW_RWG_type + type (RWG_basis_type) :: RWG_basis + complex(wp), dimension(NUM_REGIONS) :: permeabilities + complex(wp), dimension(NUM_REGIONS) :: permitivities + real(wp) :: angular_frequency + complex(wp), dimension(:, :), allocatable :: PMCHW_matrix + complex(wp), dimension(:, :), allocatable :: q_vectors + complex(wp), dimension(:, :), allocatable :: expansion_coeff_alpha + complex(wp), dimension(:, :), allocatable :: expansion_coeff_beta + complex(wp), dimension(:, :), allocatable :: inc_E_field_ampl + complex(wp), dimension(:, :), allocatable :: inc_H_field_ampl + real(wp) , dimension(:, :), allocatable :: inc_wave_direction ! unit- + integer , dimension(:) , allocatable :: inc_field_type + integer :: num_q_vectors + contains + ! Initialisers + procedure, pass(this), public :: initialise + ! Deallocation + procedure, pass(this), public :: deallocate_attributes + ! Get-functions + procedure, pass(this), public :: get_permeability + procedure, pass(this), public :: get_permitivity + procedure, pass(this), public :: get_angular_frequency + procedure, pass(this), public :: get_num_q_vectors + procedure, pass(this), public :: get_PMCHW_matrix_size + procedure, pass(this), public :: get_q_vectors_size + procedure, pass(this), public :: get_q_vectors + procedure, pass(this), public :: get_PMCHW_matrix + procedure, pass(this), public :: get_solutions + ! Calculations + procedure, pass(this), public :: calc_q_vectors + procedure, pass(this), public :: calc_q_vectors_BBB + procedure, pass(this), public :: calc_PMCHW_matrix + procedure, pass(this), public :: D_and_K_matrix_element_mn + procedure, pass(this), public :: inc_E_and_H_field_at_obs_pnt + procedure, pass(this), public :: solve_matrix_equation + procedure, pass(this), public :: E_and_H_field_at_obs_pnt + procedure, pass(this), public :: E_and_H_field_at_obs_pnt_BBB + procedure, pass(this), public :: bistatic_scattering_cross_section + procedure, pass(this), public :: face_centroid + procedure, pass(this), public :: are_obs_pnt_and_src_close + procedure, pass(this), public :: get_edge_lengths + procedure, pass(this), public :: D_and_K_matrix_element_mn_BBB + ! Writing data + procedure, pass(this), public :: write_solutions + + end type PMCHW_RWG_type + + + !=======!=========================!==========================================! +contains ! /\/\/\/\/\/\/\/\/\/\/\/\!/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\! + !=======!=========================!==========================================! + + + !!=================!! + ! Public procedures ! + !===================!========================================================= + !!------------!! + ! Constructors ! + !--------------!-------------------------------------------------------------- + + + !!==================================!! + ! RWG_basis_type internal procedures ! + !====================================!======================================== + !!------------!! + ! Initialisers ! + !--------------!-------------------------------------------------------------- + subroutine initialise(& + this, & + RWG_basis, & + permeabilities, & + permitivities, & + angular_frequency) + class (PMCHW_RWG_type) , intent(inout) :: this + type (RWG_basis_type) , intent(in) :: RWG_basis + complex(wp), dimension(NUM_REGIONS), intent(in) :: permeabilities + complex(wp), dimension(NUM_REGIONS), intent(in) :: permitivities + real(wp) , intent(in) :: angular_frequency + this%RWG_basis = RWG_basis + this%permeabilities = permeabilities + this%permitivities = permitivities + this%angular_frequency = angular_frequency + if (allocated(this%PMCHW_matrix)) deallocate(this%PMCHW_matrix) + if (allocated(this%q_vectors)) deallocate(this%q_vectors) + if (allocated(this%expansion_coeff_alpha)) & + deallocate(this%expansion_coeff_alpha) + if (allocated(this%expansion_coeff_beta)) & + deallocate(this%expansion_coeff_beta) + + allocate(this%PMCHW_matrix(2*RWG_basis%num_bases, 2*RWG_basis%num_bases)) + end subroutine initialise + + !!---------------------------------------------------------------------------- + + subroutine deallocate_attributes(this) + class (PMCHW_RWG_type), intent(inout) :: this + deallocate(this%PMCHW_matrix) + deallocate(this%q_vectors) + deallocate(this%expansion_coeff_alpha) + deallocate(this%expansion_coeff_beta) + end subroutine deallocate_attributes + + + !!-------------!! + ! Get-functions ! + !---------------!------------------------------------------------------------- + + function get_permeability(this, region) result(return_value) + class (PMCHW_RWG_type), intent(in) :: this + integer :: region + complex(wp) :: return_value + return_value = this%permeabilities(region) + end function get_permeability + + !!---------------------------------------------------------------------------- + + function get_permitivity(this, region) result(return_value) + class (PMCHW_RWG_type), intent(in) :: this + integer :: region + complex(wp) :: return_value + return_value = this%permitivities(region) + end function get_permitivity + + !!---------------------------------------------------------------------------- + + function get_angular_frequency(this) result(return_value) + class (PMCHW_RWG_type), intent(in) :: this + real(wp) :: return_value + return_value = this%angular_frequency + end function get_angular_frequency + + !!---------------------------------------------------------------------------- + + function get_PMCHW_matrix_size(this) result(return_value) + class (PMCHW_RWG_type), intent(in) :: this + integer :: return_value + return_value = size(this%PMCHW_matrix) + end function get_PMCHW_matrix_size + + !!---------------------------------------------------------------------------- + + function get_q_vectors_size(this) result(return_value) + class (PMCHW_RWG_type), intent(in) :: this + integer :: return_value + return_value = size(this%q_vectors) + end function get_q_vectors_size + + !!---------------------------------------------------------------------------- + + function get_q_vectors(this) result(return_value) + class (PMCHW_RWG_type), intent(in) :: this + complex(wp), dimension(:, :), allocatable :: return_value + allocate(return_value, source=this%q_vectors) + end function get_q_vectors + + !!---------------------------------------------------------------------------- + + function get_num_q_vectors(this) result(return_value) + class (PMCHW_RWG_type), intent(in) :: this + integer :: return_value + return_value = this%num_q_vectors + end function get_num_q_vectors + + !!---------------------------------------------------------------------------- + + function get_PMCHW_matrix(this) result(return_value) + class (PMCHW_RWG_type), intent(in) :: this + complex(wp), dimension(:, :), allocatable :: return_value + allocate(return_value, source=this%PMCHW_matrix) + end function get_PMCHW_matrix + + !!---------------------------------------------------------------------------- + + function get_solutions(this) result(res) + class (PMCHW_RWG_type), intent(in) :: this + complex(wp), dimension(:, :), allocatable :: res + ! Variables for internal use ----------------------------------------------- + integer :: b + integer :: m + + if (.not. allocated(this%q_vectors) .or. & + .not. allocated(this%expansion_coeff_alpha) .or. & + .not. allocated(this%expansion_coeff_beta)) then + print *, 'Error: PMCHW_RWG_mod: get_solutions:' + print *, ' PMCHW_RWG_type must be initialised, PMCHW-matrix ', & + 'and q-vectors must be set, and matrix equation must be solved.' + stop 2 + end if + + allocate(res, mold=this%q_vectors) + do b = 1, this%num_q_vectors + res(:this%RWG_basis%num_bases, b) = this%expansion_coeff_alpha(:, b) + res(this%RWG_basis%num_bases + 1:, b) = this%expansion_coeff_beta(:, b) + end do + + end function get_solutions + + + !!-------------!! + ! Calculations ! + !---------------!------------------------------------------------------------- + subroutine calc_q_vectors(& + this, & + gauss_quad_formula, & + inc_E_field_ampl, & + inc_H_field_ampl, & + inc_wave_direction, & + inc_field_type) + class (PMCHW_RWG_type) , intent(inout) :: this + real(wp) , dimension(:, :) , intent(in) :: gauss_quad_formula + complex(wp), dimension(:, :) , intent(in) :: inc_E_field_ampl + complex(wp), dimension(:, :) , intent(in) :: inc_H_field_ampl + real(wp) , dimension(:, :) , intent(in) :: inc_wave_direction + integer , dimension(:) , intent(in) :: inc_field_type + ! Variables for internal use ----------------------------------------------- + real(wp) , dimension(NUM_FACE_VERTICES, SPATIAL_DIM) :: face_coords + integer , dimension(NUM_FACES_IN_BASIS) :: free_vertices + integer , dimension(NUM_FACES_IN_BASIS) :: T_m + real(wp) , dimension(SPATIAL_DIM) :: r1_obs + real(wp) , dimension(SPATIAL_DIM) :: r2_obs + real(wp) , dimension(SPATIAL_DIM) :: r3_obs + real(wp) , dimension(SPATIAL_DIM) :: p_m + real(wp) , dimension(SPATIAL_DIM) :: observation_pnt + complex(wp), dimension(SPATIAL_DIM) :: inc_E_field + complex(wp), dimension(SPATIAL_DIM) :: inc_H_field + complex(wp), dimension(:, :, :), allocatable :: intgr_xi_E_field + complex(wp), dimension(:, :, :), allocatable :: intgr_eta_E_field + complex(wp), dimension(:, :, :), allocatable :: intgr_zeta_E_field + complex(wp), dimension(:, :, :), allocatable :: intgr_E_field + complex(wp), dimension(:, :, :), allocatable :: intgr_xi_H_field + complex(wp), dimension(:, :, :), allocatable :: intgr_eta_H_field + complex(wp), dimension(:, :, :), allocatable :: intgr_zeta_H_field + complex(wp), dimension(:, :, :), allocatable :: intgr_H_field + real(wp) , dimension(NUM_FACES_IN_BASIS) :: signs + real(wp) :: xi + real(wp) :: eta + real(wp) :: zeta + real(wp) :: weight + real(wp) :: prefactor + integer :: m + integer :: m_plus_N + integer :: j + integer :: p + integer :: o + integer :: b + + if (allocated(this%q_vectors)) deallocate(this%q_vectors) + if (allocated(this%inc_E_field_ampl)) deallocate(this%inc_E_field_ampl) + if (allocated(this%inc_H_field_ampl)) deallocate(this%inc_H_field_ampl) + if (allocated(this%inc_wave_direction)) & + deallocate(this%inc_wave_direction) + if (allocated(this%inc_field_type)) deallocate(this%inc_field_type) + + this%num_q_vectors = size(inc_E_field_ampl, dim=2) + ! Allocate type attributes + allocate(this%q_vectors(2*this%RWG_basis%num_bases, this%num_q_vectors)) + allocate(this%inc_E_field_ampl(SPATIAL_DIM, this%num_q_vectors)) + allocate(this%inc_H_field_ampl, mold=this%inc_E_field_ampl) + allocate(this%inc_wave_direction(SPATIAL_DIM, this%num_q_vectors)) + allocate(this%inc_field_type(this%num_q_vectors)) + ! Allocate internal variables + allocate(intgr_xi_E_field(this%num_q_vectors, & + this%RWG_basis%mesh%num_faces, SPATIAL_DIM)) + allocate(intgr_eta_E_field, mold=intgr_xi_E_field) + allocate(intgr_zeta_E_field, mold=intgr_xi_E_field) + allocate(intgr_E_field, mold=intgr_xi_E_field) + allocate(intgr_xi_H_field, mold=intgr_xi_E_field) + allocate(intgr_eta_H_field, mold=intgr_xi_E_field) + allocate(intgr_zeta_H_field, mold=intgr_xi_E_field) + allocate(intgr_H_field, mold=intgr_xi_E_field) + + + do b = 1, this%num_q_vectors + this%inc_E_field_ampl(:, b) = inc_E_field_ampl(:, b) + this%inc_H_field_ampl(:, b) = inc_H_field_ampl(:, b) + this%inc_wave_direction(:, b) = inc_wave_direction(:, b) + this%inc_field_type(b) = inc_field_type(b) + + do p = 1, this%RWG_basis%mesh%num_faces + face_coords = this%RWG_basis%mesh%get_face_coords(p) + r1_obs = face_coords(1, :) + r2_obs = face_coords(2, :) + r3_obs = face_coords(3, :) + intgr_xi_E_field(b, p, :) = ZERO_CMPLX + intgr_eta_E_field(b, p, :) = ZERO_CMPLX + intgr_E_field(b, p, :) = ZERO_CMPLX + intgr_xi_H_field(b, p, :) = ZERO_CMPLX + intgr_eta_H_field(b, p, :) = ZERO_CMPLX + intgr_H_field(b, p, :) = ZERO_CMPLX + do j = 1, size(gauss_quad_formula, dim=1) + weight = gauss_quad_formula(j, 1) + xi = gauss_quad_formula(j, 2) + eta = gauss_quad_formula(j, 3) + zeta = gauss_quad_formula(j, 4) + observation_pnt = xi*r1_obs + eta*r2_obs + zeta*r3_obs + call this%inc_E_and_H_field_at_obs_pnt(& + inc_E_field, & + inc_H_field, & + b , & + observation_pnt) + intgr_xi_E_field(b, p, :) = & + intgr_xi_E_field(b, p, :) + weight*xi*inc_E_field + intgr_eta_E_field(b, p, :) = & + intgr_eta_E_field(b, p, :) + weight*eta*inc_E_field + intgr_E_field(b, p, :) = & + intgr_E_field(b, p, :) + weight*inc_E_field + intgr_xi_H_field(b, p, :) = & + intgr_xi_H_field(b, p, :) + weight*xi*inc_H_field + intgr_eta_H_field(b, p, :) = & + intgr_eta_H_field(b, p, :) + weight*eta*inc_H_field + intgr_H_field(b, p, :) = & + intgr_H_field(b, p, :) + weight*inc_H_field + end do + intgr_zeta_E_field(b, p, :) = & + intgr_E_field(b, p, :) - intgr_xi_E_field(b, p, :) & + -intgr_eta_E_field(b, p, :) + intgr_zeta_H_field(b, p, :) = & + intgr_H_field(b, p, :) - intgr_xi_H_field(b, p, :) & + -intgr_eta_H_field(b, p, :) + end do + + + signs = [ 1._wp, -1._wp ] + do m = 1, this%RWG_basis%num_bases + m_plus_N = m + this%RWG_basis%num_bases + this%q_vectors(m, b) = ZERO_CMPLX + this%q_vectors(m_plus_N, b) = ZERO_CMPLX + + free_vertices = this%RWG_basis%get_free_vertices(m) + T_m = this%RWG_basis%get_adjacent_faces(m) + do p = 1, NUM_FACES_IN_BASIS + face_coords = this%RWG_basis%mesh%get_face_coords(T_m(p)) + r1_obs = face_coords(1, :) + r2_obs = face_coords(2, :) + r3_obs = face_coords(3, :) + p_m = this%RWG_basis%mesh%get_vertex_coords(free_vertices(p)) + this%q_vectors(m, b) = this%q_vectors(m, b) & + + signs(p)*( & + + dot_product(r1_obs, intgr_xi_E_field(b, T_m(p), :)) & + + dot_product(r2_obs, intgr_eta_E_field(b, T_m(p), :)) & + + dot_product(r3_obs, intgr_zeta_E_field(b, T_m(p), :)) & + - dot_product(p_m, intgr_E_field(b, T_m(p), :)) ) + this%q_vectors(m_plus_N, b) = this%q_vectors(m_plus_N, b) & + + signs(p)*( & + + dot_product(r1_obs, intgr_xi_H_field(b, T_m(p), :)) & + + dot_product(r2_obs, intgr_eta_H_field(b, T_m(p), :)) & + + dot_product(r3_obs, intgr_zeta_H_field(b, T_m(p), :)) & + - dot_product(p_m, intgr_H_field(b, T_m(p), :)) ) + end do ! p + prefactor = this%RWG_basis%get_basis_edge_length(m)/2._wp + this%q_vectors(m, b) = prefactor*this%q_vectors(m, b) + this%q_vectors(m_plus_N, b) = prefactor*this%q_vectors(m_plus_N, b) + end do ! m + end do ! b + + + ! Deallocate coefficient vectors since q_vectors is changed + if (allocated(this%expansion_coeff_alpha)) then + deallocate(this%expansion_coeff_alpha) + deallocate(this%expansion_coeff_beta) + end if + + end subroutine calc_q_vectors + + !!---------------------------------------------------------------------------- + + subroutine calc_q_vectors_BBB(& + this, & + gauss_quad_formula, & + inc_E_field_ampl, & + inc_H_field_ampl, & + inc_wave_direction, & + inc_field_type) + class (PMCHW_RWG_type) , intent(inout) :: this + real(wp) , dimension(:, :) , intent(in) :: gauss_quad_formula + complex(wp), dimension(:, :) , intent(in) :: inc_E_field_ampl + complex(wp), dimension(:, :) , intent(in) :: inc_H_field_ampl + real(wp) , dimension(:, :) , intent(in) :: inc_wave_direction + integer , dimension(:) , intent(in) :: inc_field_type + ! Variables for internal use ----------------------------------------------- + real(wp) , dimension(NUM_FACE_VERTICES, SPATIAL_DIM) :: face_coords + integer , dimension(NUM_FACES_IN_BASIS) :: free_vertices + integer , dimension(NUM_FACES_IN_BASIS) :: T_m + real(wp) , dimension(SPATIAL_DIM) :: r1_obs + real(wp) , dimension(SPATIAL_DIM) :: r2_obs + real(wp) , dimension(SPATIAL_DIM) :: r3_obs + real(wp) , dimension(SPATIAL_DIM) :: p_m + real(wp) , dimension(SPATIAL_DIM) :: r_obs + complex(wp), dimension(SPATIAL_DIM) :: inc_E_field + complex(wp), dimension(SPATIAL_DIM) :: inc_H_field + complex(wp) :: sum_E_field + complex(wp) :: sum_H_field + real(wp) :: xi + real(wp) :: eta + real(wp) :: zeta + real(wp) :: weight + real(wp) :: prefactor + integer :: num_quad_pnts + integer :: m + integer :: m_plus_N + integer :: j + integer :: p + integer :: b + + if (allocated(this%q_vectors)) deallocate(this%q_vectors) + if (allocated(this%inc_E_field_ampl)) deallocate(this%inc_E_field_ampl) + if (allocated(this%inc_H_field_ampl)) deallocate(this%inc_H_field_ampl) + if (allocated(this%inc_wave_direction)) & + deallocate(this%inc_wave_direction) + if (allocated(this%inc_field_type)) deallocate(this%inc_field_type) + this%num_q_vectors = size(inc_E_field_ampl, dim=2) + ! Allocate type attributes + allocate(this%q_vectors(2*this%RWG_basis%num_bases, this%num_q_vectors)) + allocate(this%inc_E_field_ampl(SPATIAL_DIM, this%num_q_vectors)) + allocate(this%inc_H_field_ampl, mold=this%inc_E_field_ampl) + allocate(this%inc_wave_direction(SPATIAL_DIM, this%num_q_vectors)) + allocate(this%inc_field_type(this%num_q_vectors)) + + num_quad_pnts = size(gauss_quad_formula, dim=1) + + do b = 1, this%num_q_vectors + this%inc_E_field_ampl(:, b) = inc_E_field_ampl(:, b) + this%inc_H_field_ampl(:, b) = inc_H_field_ampl(:, b) + this%inc_wave_direction(:, b) = inc_wave_direction(:, b) + this%inc_field_type(b) = inc_field_type(b) + + do m = 1, this%RWG_basis%num_bases + m_plus_N = m + this%RWG_basis%num_bases + this%q_vectors(m, b) = ZERO_CMPLX + this%q_vectors(m_plus_N, b) = ZERO_CMPLX + T_m = this%RWG_basis%get_adjacent_faces(m) + free_vertices = this%RWG_basis%get_free_vertices(m) + + do p = 1, NUM_FACES_IN_BASIS + face_coords = this%RWG_basis%mesh%get_face_coords(T_m(p)) + r1_obs = face_coords(1, :) + r2_obs = face_coords(2, :) + r3_obs = face_coords(3, :) + p_m = this%RWG_basis%mesh%get_vertex_coords(free_vertices(p)) + + sum_E_field = ZERO_CMPLX + sum_H_field = ZERO_CMPLX + do j = 1, num_quad_pnts + weight = gauss_quad_formula(j, GQF_WEIGHT_IDX) + xi = gauss_quad_formula(j, GQF_XI_IDX) + eta = gauss_quad_formula(j, GQF_ETA_IDX) + zeta = gauss_quad_formula(j, GQF_ZETA_IDX) + r_obs = xi*r1_obs + eta*r2_obs + zeta*r3_obs + + call this%inc_E_and_H_field_at_obs_pnt(& + inc_E_field, & + inc_H_field, & + b , & + r_obs) + + sum_E_field = sum_E_field & + + weight*dot_product(r_obs - p_m, inc_E_field) + sum_H_field = sum_H_field & + + weight*dot_product(r_obs - p_m, inc_H_field) + end do ! j + + if (p == 1) then + prefactor = 1._wp + else + prefactor = -1._wp + end if + this%q_vectors(m, b) = this%q_vectors(m, b) + prefactor*sum_E_field + this%q_vectors(m_plus_N, b) = this%q_vectors(m_plus_N, b) & + + prefactor*sum_H_field + end do ! p + prefactor = this%RWG_basis%get_basis_edge_length(m)/2._wp + this%q_vectors(m, b) = prefactor*this%q_vectors(m, b) + this%q_vectors(m_plus_N, b) = prefactor*this%q_vectors(m_plus_N, b) + end do !i m + end do ! b + + ! Deallocate coefficient vectors since q_vectors is changed + if (allocated(this%expansion_coeff_alpha)) then + deallocate(this%expansion_coeff_alpha) + deallocate(this%expansion_coeff_beta) + end if + + end subroutine calc_q_vectors_BBB + + !!---------------------------------------------------------------------------- + + subroutine calc_PMCHW_matrix(& + this , & + gauss_quad_formula, & + BBB) + class (PMCHW_RWG_type) , intent(inout) :: this + real(wp) , dimension(:, :), intent(in) :: gauss_quad_formula + logical , intent(in) :: BBB + ! Variables for internal use ----------------------------------------------- + complex(wp), dimension(:, :, :), allocatable :: EFIE_integrals + complex(wp), dimension(:, :, :), allocatable :: MFIE_integrals + complex(wp), dimension(:, :, :), allocatable :: D_matrices + complex(wp), dimension(:, :, :), allocatable :: K_matrices + real(wp) , dimension(:, :, :), allocatable :: intgr_pnts + complex(wp), dimension(2) :: wavenumbers + complex(wp), dimension(2) :: Z + complex(wp) :: prefactor_1 + complex(wp) :: prefactor_2 + complex(wp) :: prefactor_3 + complex(wp) :: prefactor_4 + real(wp) , dimension(2, 3) :: r1_obs + real(wp) , dimension(2, 3) :: r2_obs + real(wp) , dimension(2, 3) :: r3_obs + real(wp) , dimension(2, 3) :: p_m + real(wp) , dimension(3, 3) :: face_coords + integer , dimension(2) :: free_vertices + integer , dimension(2) :: T_m + integer , parameter :: NUM_EFIE_INTGR = 9 + integer , parameter :: NUM_MFIE_INTGR = 18 + integer , parameter :: NUM_REGIONS = 2 + real(wp) :: centroid_separation_dist + logical :: faces_are_close + integer :: num_intgr_pnts + integer :: i + integer :: j + integer :: k + integer :: p + integer :: q + integer :: m + integer :: n + integer :: l + + if (.not. allocated(this%PMCHW_matrix)) then + print *, 'Error: PMCHW_RWG_mod: calc_PMCHW_matrix' + print *, ' q_vectors not allocated. PMCHW_RWG_type need to be' , & + 'initialised by calling internal procedure "initialise"' + stop 1 + end if + + !----------------------------------------------------! + ! Speed improvement possibilities ! + ! - Store vertex coordinates of faces ! + ! - Store free vertices of faces ! + ! - Store Green's functions for all possible source ! + ! and observation points. This allows one to reuse ! + ! them if necesarry ! + ! - Store faces_are_close variable ! + ! - Store face-coordinates in matrix so that ! + ! - Store dot and cross product of face-pair ! + ! vertices ! + ! - Factor out 4PI from the Green's function ! + ! - Calculate integrals over subtracted terms in a ! + ! face-by-face approach ! + ! - Store edge lengths of faces ! + ! - Store unit normals of faces ! + ! ! + ! Memory improvement possibilities ! + ! - Calculate integration points on the go ! + ! - Calculate outer integrals on the go ! + ! - Calculate inner (=all) integrals on the go ! + ! - Find a way to avoid allocating memory for both a ! + ! CFIE matrix and the D^i and H^i matrices ! + !----------------------------------------------------! + + ! Iterators: + ! p - triangles + ! q - triangles + ! i - regions + ! j - Outer quadrature points + ! k - Inner quadrature points + ! l - spatial dimensions + ! m - bases + ! n - bases + ! o - other + + + num_intgr_pnts = size(gauss_quad_formula, dim=1) + allocate(D_matrices(NUM_REGIONS, this%RWG_basis%num_bases, & + this%RWG_basis%num_bases)) + allocate(K_matrices(NUM_REGIONS, this%RWG_basis%num_bases, & + this%RWG_basis%num_bases)) + if (.not. BBB) then + allocate(intgr_pnts(this%RWG_basis%mesh%num_faces, num_intgr_pnts, & + SPATIAL_DIM)) + allocate(EFIE_integrals(this%RWG_basis%mesh%num_faces, & + this%RWG_basis%mesh%num_faces, & + NUM_EFIE_INTGR)) + allocate(MFIE_integrals(this%RWG_basis%mesh%num_faces, & + this%RWG_basis%mesh%num_faces, & + NUM_MFIE_INTGR)) + + ! Calculate integration points for each triangle (face) + do p = 1, this%RWG_basis%mesh%num_faces + face_coords = this%RWG_basis%mesh%get_face_coords(p) + do j = 1, num_intgr_pnts + intgr_pnts(p, j, :) = ZERO + do l = 1, SPATIAL_DIM + intgr_pnts(p, j, :) = intgr_pnts(p, j, :) & + + gauss_quad_formula(j, l + 1)*face_coords(l, :) + end do + end do + end do + end if + + ! Repeats over all regions + do i = 1, NUM_REGIONS + wavenumbers(i) = this%angular_frequency & + *sqrt(this%permeabilities(i)*this%permitivities(i)) + if (.not. BBB) then + do p = 1, this%RWG_basis%mesh%num_faces + do q = 1, this%RWG_basis%mesh%num_faces + ! If centroid-centroid separation is large enough, use only + ! centroid as quadrature point for outer integral. Else, + ! extract singularity from Green's function. + faces_are_close = this%are_obs_pnt_and_src_close(& + this%face_centroid(& + p, & + num_intgr_pnts, & + intgr_pnts(p, :, :)), & + this%face_centroid(& + q, & + num_intgr_pnts, & + intgr_pnts(q, :, :)), & + wavenumbers(i) , & + p=p , & + q=q) + call eval_outer_integrals(& + EFIE_integrals(p, q, :), & + MFIE_integrals(p, q, :), & + intgr_pnts(p, :, :) , & + intgr_pnts(q, :, :) , & + gauss_quad_formula , & + faces_are_close , & + p , & + q , & + wavenumbers(i)) + if (any(isnan(EFIE_integrals(p, q, :)%re))) then + print *, 'EFIE_integral%re is nan - ', p, q + end if + if (any(isnan(MFIE_integrals(p, q, :)%re))) then + print *, 'MFIE_integral%re is nan - ', p, q + end if + if (any(isnan(EFIE_integrals(p, q, :)%im))) then + print *, 'EFIE_integral%im is nan - ', p, q + end if + if (any(isnan(MFIE_integrals(p, q, :)%im))) then + print *, 'MFIE_integral%im is nan - ', p, q + end if + end do ! q + if (modulo(p, 100) == 0) then + print *, 'Region, p, num_faces:', i, p, this%RWG_basis%mesh%num_faces + end if + end do ! p + end if + + ! Evaluate the EFIE matrix D^i and MFIE matrix K^i + do m = 1, this%RWG_basis%num_bases + if (modulo(m, 100) == 0) then + print *, 'Region, m, num_bases:', i, m, this%RWG_basis%num_bases + end if + T_m = this%RWG_basis%get_adjacent_faces(m) + free_vertices = this%RWG_basis%get_free_vertices(m) + do p = 1, 2 + face_coords = this%RWG_basis%mesh%get_face_coords(T_m(p)) + r1_obs(p, :) = face_coords(1, :) + r2_obs(p, :) = face_coords(2, :) + r3_obs(p, :) = face_coords(3, :) + p_m(p, :) = this%RWG_basis%mesh%get_vertex_coords(free_vertices(p)) + end do ! p + do n = 1, this%RWG_basis%num_bases + + if (BBB) then + call this%D_and_K_matrix_element_mn_BBB(& + D_matrices(i, m, n), & + K_matrices(i, m, n), & + m , & + n , & + r1_obs , & + r2_obs , & + r3_obs , & + p_m , & + wavenumbers(i) , & + i , & + gauss_quad_formula) + else + call this%D_and_K_matrix_element_mn(& + D_matrices(i, m, n), & + K_matrices(i, m, n), & + m , & + n , & + r1_obs , & + r2_obs , & + r3_obs , & + p_m , & + EFIE_integrals , & + MFIE_integrals , & + wavenumbers(i) , & + i , & + num_intgr_pnts , & + intgr_pnts , & + gauss_quad_formula) + end if + end do ! n + end do ! m + end do ! i + + + ! At last, insert D and K matrices into CFIE matrix + prefactor_1 = this%permeabilities(1)*this%angular_frequency/I_IMAG + prefactor_2 = this%permeabilities(2)*this%angular_frequency/I_IMAG + prefactor_3 = this%permitivities(1)*this%angular_frequency/I_IMAG + prefactor_4 = this%permitivities(2)*this%angular_frequency/I_IMAG + + this%PMCHW_matrix(:this%RWG_basis%num_bases, :this%RWG_basis%num_bases) = & + prefactor_1*D_matrices(1, :, :) + prefactor_2*D_matrices(2, :, :) + this%PMCHW_matrix(:this%RWG_basis%num_bases, this%RWG_basis%num_bases + 1:)& + = -K_matrices(1, :, :) - K_matrices(2, :, :) + this%PMCHW_matrix(this%RWG_basis%num_bases + 1:, :this%RWG_basis%num_bases)& + = K_matrices(1, :, :) + K_matrices(2, :, :) + this%PMCHW_matrix(this%RWG_basis%num_bases + 1:, & + this%RWG_basis%num_bases + 1:) = & + prefactor_3*D_matrices(1, :, :) + prefactor_4*D_matrices(2, :, :) + + ! Deallocate coefficient vectors since PMCHW_matrix is changed + if (allocated(this%expansion_coeff_alpha)) then + deallocate(this%expansion_coeff_alpha) + deallocate(this%expansion_coeff_beta) + end if + end subroutine calc_PMCHW_matrix + + !!---------------------------------------------------------------------------- + + subroutine inc_E_and_H_field_at_obs_pnt(& + this , & + E_field , & + H_field , & + q_vector_idx, & + observation_pnt) + class (PMCHW_RWG_type) , intent(in) :: this + complex(wp), dimension(SPATIAL_DIM), intent(inout) :: E_field + complex(wp), dimension(SPATIAL_DIM), intent(inout) :: H_field + integer , intent(in) :: q_vector_idx + real(wp) , dimension(SPATIAL_DIM), intent(in) :: observation_pnt + ! Variables for internal use ----------------------------------------------- + complex(wp) :: wavenumber + + ! Works only for outer region observation points + + wavenumber = this%angular_frequency*sqrt( & + this%permeabilities(OUTER_REGION_IDX) & + *this%permitivities(OUTER_REGION_IDX)) + + if (this%inc_field_type(q_vector_idx) == INC_FIELD_TYPE_PLANE_WAVE) then + E_Field = plane_wave( & + observation_pnt , & + wavenumber , & + this%inc_E_field_ampl(:, q_vector_idx), & + this%inc_wave_direction(:, q_vector_idx)) + H_Field = plane_wave( & + observation_pnt , & + wavenumber , & + this%inc_H_field_ampl(:, q_vector_idx), & + this%inc_wave_direction(:, q_vector_idx)) + else + print *, 'Error: PMCHW_RWG_mod: calc_q_vectors:' + print *, ' Only plane wave incoming fields implemented' + stop 2 + end if + + end subroutine inc_E_and_H_field_at_obs_pnt + + !!---------------------------------------------------------------------------- + + subroutine E_and_H_field_at_obs_pnt(& + this , & + E_field , & + H_field , & + observation_pnt , & + gauss_quad_formula, & + region , & + scattered , & + test) + class (PMCHW_RWG_type) , intent(in) :: this + complex(wp), dimension(:, :) , intent(inout) :: E_field + complex(wp), dimension(:, :) , intent(inout) :: H_field + real(wp) , dimension(SPATIAL_DIM), intent(in) :: observation_pnt + real(wp) , dimension(:, :) , intent(in) :: gauss_quad_formula + integer , intent(in) :: region + logical , optional , intent(in) :: scattered + logical , optional :: test + ! Variables for internal use ----------------------------------------------- + complex(wp), dimension(:, :) , allocatable :: E_field_p + complex(wp), dimension(:, :) , allocatable :: H_field_p + complex(wp), dimension(this%RWG_basis%mesh%num_faces) :: intgr_xi + complex(wp), dimension(this%RWG_basis%mesh%num_faces) :: intgr_eta + complex(wp), dimension(this%RWG_basis%mesh%num_faces) :: intgr_zeta + complex(wp), dimension(this%RWG_basis%mesh%num_faces) :: intgr + complex(wp), dimension(this%RWG_basis%mesh%num_faces) :: grad_intgr_xi + complex(wp), dimension(this%RWG_basis%mesh%num_faces) :: grad_intgr_eta + complex(wp), dimension(this%RWG_basis%mesh%num_faces) :: grad_intgr_zeta + complex(wp), dimension(this%RWG_basis%mesh%num_faces) :: grad_intgr + complex(wp), dimension(SPATIAL_DIM) :: inc_E_field + complex(wp), dimension(SPATIAL_DIM) :: inc_H_field + complex(wp), dimension(SPATIAL_DIM) :: term1 + complex(wp), dimension(SPATIAL_DIM) :: term2 + complex(wp), dimension(SPATIAL_DIM) :: prod + complex(wp), dimension(SPATIAL_DIM) :: cross_product + complex(wp), dimension(SPATIAL_DIM) :: divergence + complex(wp) :: wavenumber + complex(wp) :: k2 + complex(wp) :: green_func + complex(wp) :: grad_of_green_func + real(wp) , dimension(:, :) , allocatable :: quad_pnts + real(wp) , dimension(NUM_FACES_IN_BASIS) :: signs + real(wp) , dimension(NUM_FACE_VERTICES, SPATIAL_DIM) :: face_coords + real(wp) , dimension(SPATIAL_DIM) :: source_pnt + real(wp) , dimension(SPATIAL_DIM) :: r1_src + real(wp) , dimension(SPATIAL_DIM) :: r2_src + real(wp) , dimension(SPATIAL_DIM) :: r3_src + real(wp) , dimension(SPATIAL_DIM) :: p_n + real(wp) :: prefactor + real(wp) :: alpha_n + real(wp) :: beta_n + integer , dimension(NUM_FACES_IN_BASIS) :: T_n + integer , dimension(NUM_FACES_IN_BASIS) :: free_vertices + integer :: num_quad_pnts + integer :: q + integer :: n + integer :: j + integer :: l + integer :: b + logical , dimension(:) , allocatable :: near_singularity + logical :: obs_pnt_and_src_are_close + logical :: check_allocation + logical :: sca + ! For exact evaluation of integrals over the subtracted termsm when -------- + ! near singularity --------------------------------------------------------- + complex(wp) :: half_of_k2 + complex(wp), dimension(SPATIAL_DIM) :: prod_subtr + complex(wp), dimension(SPATIAL_DIM) :: div_subtr + complex(wp), dimension(SPATIAL_DIM) :: cross_subtr + real(wp), dimension(NUM_FACE_VERTICES, SPATIAL_DIM) :: edge_unit_normals_q + real(wp), dimension(NUM_FACE_VERTICES) :: edge_lengths_q + real(wp), dimension(SPATIAL_DIM) :: face_unit_normal_q + real(wp) :: face_area_q + real(wp), dimension(SPATIAL_DIM) :: hnX1_minus_3 + real(wp), dimension(SPATIAL_DIM) :: X2_minus_1 + real(wp), dimension(SPATIAL_DIM) :: X2_plus_1 + real(wp), dimension(SPATIAL_DIM) :: X3_minus_1 + real(wp), dimension(SPATIAL_DIM) :: X3_plus_1 + real(wp), dimension(SPATIAL_DIM) :: X4_minus_1 + real(wp), dimension(SPATIAL_DIM) :: X4_plus_1 + real(wp) :: X1_minus_1 + real(wp) :: X1_plus_1 + !--------------------------------------------------------------------------- + + + check_allocation = .true. + if (present(test)) then + if (test) then + check_allocation = .false. + end if + end if + if (check_allocation) then + if (.not. allocated(this%PMCHW_matrix) .or. & + .not. allocated(this%q_vectors)) then + print *, 'Error: PMCHW_RWG_mod: E_and_H_field_at_obs_pnt:' + print *, ' Object must be initialised, PMCHW_matrix and ', & + ' q_vectors must be set, and matrix equation must be ', & + ' solved.' + stop 2 + else if (.not. allocated(this%expansion_coeff_alpha) .or. & + .not. allocated(this%expansion_coeff_beta)) then + print *, 'Error: PMCHW_RWG_mod: E_and_H_field_at_obs_pnt:' + print *, ' Matrix equation for current PMCHW_matrix and ', & + 'q_vectors has not been solved' + stop 2 + end if + end if + + if (present(scattered)) then + sca = scattered + else + sca = .false. + end if + if (sca .and. region==INNER_REGION_IDX) then + print *, 'Warning: Scattered field not aplicable to inner region.' + print *, ' Calculating total field.' + end if + + num_quad_pnts = size(gauss_quad_formula, dim=1) + allocate(quad_pnts(num_quad_pnts, SPATIAL_DIM)) + allocate(E_field_p(SPATIAL_DIM, this%num_q_vectors)) + allocate(H_field_p, mold=E_field_p) + allocate(near_singularity(this%RWG_basis%mesh%get_num_faces())) + + wavenumber = & + this%angular_frequency*sqrt(& + this%permeabilities(region)*this%permitivities(region)) + k2 = wavenumber**2 + half_of_k2 = k2/2._wp + + ! Calculate the integrals for each face/triangle + do q = 1, this%RWG_basis%mesh%get_num_faces() + ! Set observation point and source not close. + ! Will be altered if one of the quadrature points are close to the + ! observation point. + near_singularity(q) = .false. + + face_coords = this%RWG_basis%mesh%get_face_coords(q) + do j = 1, num_quad_pnts + quad_pnts(j, :) = 0._wp + do l = 1, SPATIAL_DIM + quad_pnts(j, :) = quad_pnts(j, :) & + + gauss_quad_formula(j, l + 1)*face_coords(l, :) + end do + source_pnt = quad_pnts(j, :) + obs_pnt_and_src_are_close = this%are_obs_pnt_and_src_close(& + observation_pnt, & + source_pnt , & + wavenumber) + if (obs_pnt_and_src_are_close) then + near_singularity(q) = .false. + end if + end do ! j + !------ FOR TESTING PORPUSES -------! + if (present(test)) then + if (test) then + wavenumber = ZERO_CMPLX + obs_pnt_and_src_are_close = .false. + do j = 1, num_quad_pnts + quad_pnts(j, :) = observation_pnt - 1._wp/(sqrt(3._wp)*4._wp*PI) + end do ! j + end if + end if + !-----------------------------------! + call eval_green_func_integrals( & + intgr_xi(q) , & + intgr_eta(q) , & + intgr(q) , & + grad_intgr_xi(q) , & + grad_intgr_eta(q) , & + grad_intgr(q) , & + observation_pnt , & + quad_pnts , & + gauss_quad_formula , & + wavenumber , & + near_singularity(q) , & + faces_are_in_same_plane=.false.) + intgr_zeta(q) = intgr(q) - intgr_xi(q) - intgr_eta(q) + grad_intgr_zeta(q) = & + + grad_intgr(q) & + - grad_intgr_xi(q) & + - grad_intgr_eta(q) + + !------ FOR TESTING PORPUSES -------! + if (present(test)) then + if (test) then + wavenumber = & + this%angular_frequency*sqrt(& + this%permeabilities(region)*this%permitivities(region)) + end if + end if + !-----------------------------------! + end do ! q + + ! Calculate the E- and H-field by summing integrals over all bases + E_field = ZERO_CMPLX + H_field = ZERO_CMPLX + signs = [ 1._wp, -1._wp ] + do n = 1, this%RWG_basis%get_num_bases() + T_n = this%RWG_basis%get_adjacent_faces(n) + free_vertices = this%RWG_basis%get_free_vertices(n) + prefactor = this%RWG_basis%get_basis_edge_length(n)/2._wp + E_field_p = ZERO_CMPLX + H_field_p = ZERO_CMPLX + term1 = ZERO_CMPLX + term2 = ZERO_CMPLX + do q = 1, NUM_FACES_IN_BASIS + face_coords = this%RWG_basis%mesh%get_face_coords(T_n(q)) + r1_src = face_coords(1, :) + r2_src = face_coords(2, :) + r3_src = face_coords(3, :) + p_n = this%RWG_basis%mesh%get_vertex_coords(free_vertices(q)) + ! Calculate the integrals of + ! 1. the product of the Green's function and the basis function + ! 2. the cross product of the gradient of the Green's function and + ! the basis function + ! 3. the gradient of the Green's function and the times the + ! divergence of the basis function + prod = & + + r1_src*intgr_xi(T_n(q)) & + + r2_src*intgr_eta(T_n(q)) & + + r3_src*intgr_zeta(T_n(q)) & + - p_n*intgr(T_n(q)) + divergence = & + - r1_src*grad_intgr_xi(T_n(q)) & + - r2_src*grad_intgr_eta(T_n(q)) & + - r3_src*grad_intgr_zeta(T_n(q)) & + + observation_pnt*grad_intgr(T_n(q)) + cross_product = & + ( cross_prod_3D(observation_pnt, r1_src) & + + cross_prod_3D(r1_src, p_n) ) & + *grad_intgr_xi(T_n(q)) & + + ( cross_prod_3D(observation_pnt, r2_src) & + + cross_prod_3D(r2_src, p_n) ) & + *grad_intgr_eta(T_n(q)) & + + ( cross_prod_3D(observation_pnt, r3_src) & + + cross_prod_3D(r3_src, p_n) ) & + *grad_intgr_zeta(T_n(q)) & + - cross_prod_3D(observation_pnt, p_n) & + *grad_intgr(T_n(q)) + + if (near_singularity(T_n(q))) then + face_area_q = this%RWG_basis%mesh%face_area(T_n(q)) + face_unit_normal_q = this%RWG_basis%mesh%face_unit_normal(T_n(q)) + edge_lengths_q = this%get_edge_lengths(T_n(q)) + edge_unit_normals_q = calc_edge_unit_normals(& + edge_lengths_q , & + face_unit_normal_q, & + r1_src , & + r2_src , & + r3_src) + + call inner_intgr_of_subtr_terms(& + hnX1_minus_3 , & + X1_minus_1 , & + X1_plus_1 , & + X2_minus_1 , & + X2_plus_1 , & + X3_minus_1 , & + X3_plus_1 , & + X4_minus_1 , & + X4_plus_1 , & + .false. , & + observation_pnt , & + r1_src , & + r2_src , & + r3_src , & + p_n , & + face_area_q , & + face_unit_normal_q, & + edge_lengths_q , & + edge_unit_normals_q) + + prod_subtr = PI4_inv/face_area_q*(X2_minus_1 - half_of_k2*X2_plus_1) + div_subtr = PI4_inv/face_area_q*(X3_minus_1 - half_of_k2*X3_plus_1) + cross_subtr = PI4_inv/face_area_q*(X4_minus_1 - half_of_k2*X4_plus_1) + else + prod_subtr = ZERO_CMPLX + div_subtr = ZERO_CMPLX + cross_subtr = ZERO_CMPLX + end if + + ! Calculate the resulting feilds using the expansion coefficients. + ! Iterate over all solutions. + if (q == 1) then + term1 = term1 + (prod + prod_subtr - 2._wp/k2*(divergence + div_subtr)) + term2 = term2 + (cross_product + cross_subtr) + else + term1 = term1 - (prod + prod_subtr - 2._wp/k2*(divergence + div_subtr)) + term2 = term2 - (cross_product + cross_subtr) + end if + end do ! q + + do b = 1, this%num_q_vectors + !------ FOR TESTING PORPUSES -------! + if (present(test)) then + if (test) then + alpha_n = 1._wp + beta_n = 1._wp + else + alpha_n = this%expansion_coeff_alpha(n, b) + beta_n = this%expansion_coeff_beta(n, b) + end if + !-----------------------------------! + else + alpha_n = this%expansion_coeff_alpha(n, b) + beta_n = this%expansion_coeff_beta(n, b) + end if + E_field(:, b) = E_field(:, b) + prefactor*( & + -alpha_n*this%permeabilities(region)*this%angular_frequency & + /I_IMAG*term1 + beta_n*term2 ) + H_field(:, b) = H_field(:, b) + prefactor*( & + -beta_n*this%permitivities(region)*this%angular_frequency & + /I_IMAG*term1 - alpha_n*term2 ) + end do ! end b + end do ! end n + + do b = 1, this%num_q_vectors + if ( region == INNER_REGION_IDX ) then + E_field(:, b) = -E_field(:, b) + H_field(:, b) = -H_field(:, b) + else if (.not. sca) then + call this%inc_E_and_H_field_at_obs_pnt(& + inc_E_field, & + inc_H_field, & + b , & + observation_pnt) + E_field(:, b) = E_field(:, b) + inc_E_field + H_field(:, b) = H_field(:, b) + inc_H_field + else + continue + end if + + end do ! b + end subroutine E_and_H_field_at_obs_pnt + + !!---------------------------------------------------------------------------- + + subroutine E_and_H_field_at_obs_pnt_BBB(& + this , & + E_field , & + H_field , & + observation_pnt , & + gauss_quad_formula, & + region , & + scattered , & + test) + class (PMCHW_RWG_type) , intent(in) :: this + complex(wp), dimension(:, :) , intent(inout) :: E_field + complex(wp), dimension(:, :) , intent(inout) :: H_field + real(wp) , dimension(SPATIAL_DIM), intent(in) :: observation_pnt + real(wp) , dimension(:, :) , intent(in) :: gauss_quad_formula + integer , intent(in) :: region + logical , optional , intent(in) :: scattered + logical , optional :: test + ! Variables for internal use ----------------------------------------------- + complex(wp), dimension(SPATIAL_DIM) :: inc_E_field + complex(wp), dimension(SPATIAL_DIM) :: inc_H_field + complex(wp), dimension(SPATIAL_DIM) :: term1 + complex(wp), dimension(SPATIAL_DIM) :: term2 + complex(wp), dimension(SPATIAL_DIM) :: inner_sum1 + complex(wp), dimension(SPATIAL_DIM) :: inner_sum2 + complex(wp), dimension(SPATIAL_DIM) :: inner_sum3 + complex(wp) :: wavenumber + complex(wp) :: kR + complex(wp) :: k2 + complex(wp) :: green_func + complex(wp) :: grad_of_green_func + real(wp) , dimension(NUM_FACE_VERTICES, SPATIAL_DIM) :: face_coords + real(wp) , dimension(SPATIAL_DIM) :: r_src + real(wp) , dimension(SPATIAL_DIM) :: r1_src + real(wp) , dimension(SPATIAL_DIM) :: r2_src + real(wp) , dimension(SPATIAL_DIM) :: r3_src + real(wp) , dimension(SPATIAL_DIM) :: p_n + real(wp) :: R + real(wp) :: R_inv + real(wp) :: prefactor + real(wp) :: alpha_n + real(wp) :: beta_n + real(wp) :: weight + real(wp) :: xi + real(wp) :: eta + real(wp) :: zeta + integer , dimension(NUM_FACES_IN_BASIS) :: T_n + integer , dimension(NUM_FACES_IN_BASIS) :: free_vertices + integer :: num_quad_pnts + integer :: p + integer :: n + integer :: b + integer :: k + logical :: pnts_are_close + logical :: check_allocation + !--------------------------------------------------------------------------- + + check_allocation = .true. + if (present(test)) then + if (test) then + check_allocation = .false. + end if + end if + if (check_allocation) then + if (.not. allocated(this%PMCHW_matrix) .or. & + .not. allocated(this%q_vectors)) then + print *, 'Error: PMCHW_RWG_mod: E_and_H_field_at_obs_pnt:' + print *, ' Object must be initialised, PMCHW_matrix and ', & + ' q_vectors must be set, and matrix equation must be ', & + ' solved.' + stop 2 + else if (.not. allocated(this%expansion_coeff_alpha) .or. & + .not. allocated(this%expansion_coeff_beta)) then + print *, 'Error: PMCHW_RWG_mod: E_and_H_field_at_obs_pnt:' + print *, ' Matrix equation for current PMCHW_matrix and ', & + 'q_vectors has not been solved' + stop 2 + end if + end if + + num_quad_pnts = size(gauss_quad_formula, dim=1) + + wavenumber = & + this%angular_frequency*sqrt(& + this%permeabilities(region)*this%permitivities(region)) + k2 = wavenumber**2 + + E_field = ZERO_CMPLX + H_field = ZERO_CMPLX + do n = 1, this%RWG_basis%num_bases + T_n = this%RWG_basis%get_adjacent_faces(n) + free_vertices = this%RWG_basis%get_free_vertices(n) + prefactor = this%RWG_basis%get_basis_edge_length(n)/2._wp + + term1 = ZERO_CMPLX + term2 = ZERO_CMPLX + do p = 1, NUM_FACES_IN_BASIS + face_coords = this%RWG_basis%mesh%get_face_coords(T_n(p)) + r1_src = face_coords(1, :) + r2_src = face_coords(2, :) + r3_src = face_coords(3, :) + p_n = this%RWG_basis%mesh%get_vertex_coords(free_vertices(p)) + + inner_sum1 = ZERO_CMPLX ! sum of G(r,r')f(r') + inner_sum2 = ZERO_CMPLX ! sum of nabla*G(r,r')f(r') + inner_sum3 = ZERO_CMPLX ! sum of nabla'*G(r,r') x f(r') + do k = 1, num_quad_pnts + weight = gauss_quad_formula(k, GQF_WEIGHT_IDX) + xi = gauss_quad_formula(k, GQF_XI_IDX) + eta = gauss_quad_formula(k, GQF_ETA_IDX) + zeta = gauss_quad_formula(k, GQF_ZETA_IDX) + r_src = xi*r1_src + eta*r2_src + zeta*r3_src + + R = norm2(observation_pnt - r_src) + kR = wavenumber*R + + if ( this%are_obs_pnt_and_src_close(& + observation_pnt, & + r_src , & + wavenumber) ) then + pnts_are_close = .true. + call green_func_smoothened(& + green_func , & + grad_of_green_func, & + wavenumber , & + kR , & + R , & + .false.) + else + R_inv = 1._wp/R + pnts_are_close = .false. + green_func = exp(I_IMAG*kR)*PI4_inv*R_inv + grad_of_green_func = R_inv*green_func & + *(R_inv - I_IMAG*wavenumber) + end if + + inner_sum1 = inner_sum1 + weight*green_func*(r_src - p_n) + inner_sum2 = inner_sum2 + weight*grad_of_green_func & + *(observation_pnt - r_src) + inner_sum3 = inner_sum3 + weight*grad_of_green_func & + *cross_prod_3D(observation_pnt - r_src, r_src - p_n) + end do ! k + + + if (p == 1) then + term1 = term1 + inner_sum1 - 2._wp/k2*inner_sum2 + term2 = term2 + inner_sum3 + else + term1 = term1 - inner_sum1 + 2._wp/k2*inner_sum2 + term2 = term2 - inner_sum3 + end if + end do ! p + + do b = 1, this%num_q_vectors + alpha_n = this%expansion_coeff_alpha(n, b) + beta_n = this%expansion_coeff_beta(n, b) + + E_field(:, b) = E_field(:, b) + prefactor*( & + -alpha_n*this%permeabilities(region)*this%angular_frequency & + /I_IMAG*term1 + beta_n*term2 ) + H_field(:, b) = H_field(:, b) + prefactor*( & + -beta_n*this%permitivities(region)*this%angular_frequency & + /I_IMAG*term1 - alpha_n*term2 ) + + end do ! b + end do ! n + + do b = 1, this%num_q_vectors + if ( region == OUTER_REGION_IDX .and. & + (.not. present(scattered) .or. & + (present(scattered) .and. scattered .eqv. .false.)) ) then + call this%inc_E_and_H_field_at_obs_pnt(& + inc_E_field, & + inc_H_field, & + b , & + observation_pnt) + E_field(:, b) = E_field(:, b) + inc_E_field + H_field(:, b) = H_field(:, b) + inc_H_field + else if ( region == OUTER_REGION_IDX .and. & + (present(scattered) .and. scattered .eqv. .true.) ) then + continue + else if (region == INNER_REGION_IDX .and. & + present(scattered) .and. scattered .eqv. .true. ) then + print *, 'Warning: Scattered field not aplicable to inner region.' + else + E_field(:, b) = -E_field(:, b) + H_field(:, b) = -H_field(:, b) + end if + end do ! b + end subroutine E_and_H_field_at_obs_pnt_BBB + + !!---------------------------------------------------------------------------- + + subroutine D_and_K_matrix_element_mn(& + this , & + D_mn , & + K_mn , & + m , & + n , & + r1_obs , & + r2_obs , & + r3_obs , & + p_m , & + EFIE_integrals, & + MFIE_integrals, & + wavenumber , & + region , & + num_intgr_pnts, & + intgr_pnts , & + gauss_quad_formula) + class (PMCHW_RWG_type) , intent(in) :: this + complex(wp) , intent(inout) :: D_mn + complex(wp) , intent(inout) :: K_mn + integer , intent(in) :: m + integer , intent(in) :: n + real(wp) , dimension(:, :) , intent(in) :: r1_obs + real(wp) , dimension(:, :) , intent(in) :: r2_obs + real(wp) , dimension(:, :) , intent(in) :: r3_obs + real(wp) , dimension(:, :) , intent(in) :: p_m + complex(wp), dimension(:, :, :), intent(in) :: EFIE_integrals + complex(wp), dimension(:, :, :), intent(in) :: MFIE_integrals + complex(wp) , intent(in) :: wavenumber + integer , intent(in) :: region + integer , intent(in) :: num_intgr_pnts + real(wp) , dimension(:, :, :), intent(in) :: intgr_pnts + real(wp) , dimension(:, :) , intent(in) :: gauss_quad_formula + ! Variables for internal use ----------------------------------------------- + complex(wp) :: D_mn_pq + complex(wp) :: K_mn_pq + complex(wp) :: subtr_terms_D_mn_pq + complex(wp) :: subtr_terms_K_mn_pq + real(wp) , dimension(SPATIAL_DIM) :: r1_src + real(wp) , dimension(SPATIAL_DIM) :: r2_src + real(wp) , dimension(SPATIAL_DIM) :: r3_src + real(wp) , dimension(SPATIAL_DIM) :: p_n + real(wp) , dimension(NUM_FACE_VERTICES, SPATIAL_DIM) :: face_coords + real(wp) , dimension(NUM_FACE_VERTICES, SPATIAL_DIM) ::edge_unit_normals_p + real(wp) , dimension(NUM_FACE_VERTICES, SPATIAL_DIM) ::edge_unit_normals_q + real(wp) , dimension(NUM_FACE_VERTICES) :: edge_lengths_p + real(wp) , dimension(NUM_FACE_VERTICES) :: edge_lengths_q + real(wp) , dimension(SPATIAL_DIM) :: face_unit_normal_p + real(wp) , dimension(SPATIAL_DIM) :: face_unit_normal_q + real(wp) :: face_area_p + real(wp) :: face_area_q + integer , dimension(NUM_FACES_IN_BASIS) :: free_vertices + integer , dimension(NUM_FACES_IN_BASIS) :: T_m + integer , dimension(NUM_FACES_IN_BASIS) :: T_n + real(wp) :: prefactor + logical :: faces_are_close + logical :: R_is_zero + integer :: p + integer :: q + integer :: l + integer, dimension(48, 2) :: faces_in_plane + integer :: i + + T_m = this%RWG_basis%get_adjacent_faces(m) + T_n = this%RWG_basis%get_adjacent_faces(n) + free_vertices = this%RWG_basis%get_free_vertices(n) + + D_mn = ZERO_CMPLX + K_mn = ZERO_CMPLX + do p = 1, NUM_FACES_IN_BASIS + do q = 1, NUM_FACES_IN_BASIS + + ! Increase speed by storing r1_src, etc. for both values of q + face_coords = this%RWG_basis%mesh%get_face_coords(T_n(q)) + r1_src = face_coords(1, :) + r2_src = face_coords(2, :) + r3_src = face_coords(3, :) + p_n = this%RWG_basis%mesh%get_vertex_coords(free_vertices(q)) + ! EFIE + D_mn_pq = face_pair_integral_EFIE(& + r1_obs(p, :), & + r2_obs(p, :), & + r3_obs(p, :), & + r1_src , & + r2_src , & + r3_src , & + p_m(p, :) , & + p_n , & + wavenumber , & + EFIE_integrals(T_m(p), T_n(q), :)) + + ! MFIE + if (T_m(p) == T_n(q)) then + ! Faces are equal. The inner integral will then be orthogonal + ! to the basis function f_m(r), and the double integral vanishes. + K_mn_pq = ZERO_CMPLX + else + K_mn_pq = face_pair_integral_MFIE(& + r1_obs(p, :), & + r2_obs(p, :), & + r3_obs(p, :), & + r1_src , & + r2_src , & + r3_src , & + p_m(p, :) , & + p_n , & + MFIE_integrals(T_m(p), T_n(q), :)) + end if + if (isnan(D_mn_pq%re)) then + print *, '(m, n)', [m, n], '(p, q)', [p, q], '(T^p, T^q)', & + [T_m(p), T_n(q)], 'D_mn_pq is NaN' + end if + if (isnan(K_mn_pq%re)) then + print *, '(m, n)', [m, n], '(p, q)', [p, q], '(T^p, T^q)', & + [T_m(p), T_n(q)], 'K_mn_pq is NaN' + end if + + + ! If faces are close, add evaluation of integrals over + ! subtracted terms + faces_are_close = this%are_obs_pnt_and_src_close(& + this%face_centroid(& + T_m(p) , & + num_intgr_pnts , & + intgr_pnts(T_m(p), :, :)), & + this%face_centroid(& + T_n(q) , & + num_intgr_pnts , & + intgr_pnts(T_n(q), :, :)), & + wavenumber , & + p=T_m(p) , & + q=T_n(q)) + if (faces_are_close .and. .not. CAUCHY) then + face_area_q = this%RWG_basis%mesh%face_area(T_n(q)) + face_unit_normal_q = this%RWG_basis%mesh%face_unit_normal(T_n(q)) + edge_lengths_q = this%get_edge_lengths(T_n(q)) + edge_unit_normals_q = calc_edge_unit_normals(& + edge_lengths_q , & + face_unit_normal_q, & + r1_src , & + r2_src , & + r3_src) + face_area_p = this%RWG_basis%mesh%face_area(T_m(p)) + face_unit_normal_p = this%RWG_basis%mesh%face_unit_normal(T_m(p)) + edge_lengths_p = this%get_edge_lengths(T_m(p)) + edge_unit_normals_p = calc_edge_unit_normals(& + edge_lengths_p , & + face_unit_normal_p, & + r1_obs(p, :) , & + r2_obs(p, :) , & + r3_obs(p, :)) + + + call eval_subtracted_terms(& + subtr_terms_D_mn_pq, & + subtr_terms_K_mn_pq, & + wavenumber , & + r1_obs(p, :) , & + r2_obs(p, :) , & + r3_obs(p, :) , & + r1_src , & + r2_src , & + r3_src , & + p_m(p, :) , & + p_n , & + gauss_quad_formula , & + T_m(p) , & + T_n(q) , & + face_area_p , & + face_area_q , & + face_unit_normal_p , & + face_unit_normal_q , & + edge_lengths_p , & + edge_lengths_q , & + edge_unit_normals_p, & + edge_unit_normals_q) + + if (isnan(subtr_terms_D_mn_pq%re)) then + print *, '(m, n)', [m, n], '(p, q)', [p, q], '(T^p, T^q)', & + [T_m(p), T_n(q)], 'subtr_terms_D_mn_pq is NaN for reals' + end if + if (isnan(subtr_terms_K_mn_pq%re)) then + print *, '(m, n)', [m, n], '(p, q)', [p, q], '(T^p, T^q)', & + [T_m(p), T_n(q)], 'subtr_terms_K_mn_pq is NaN for reals' + end if + + D_mn_pq = D_mn_pq + subtr_terms_D_mn_pq + K_mn_pq = K_mn_pq + subtr_terms_K_mn_pq + end if + + if (p + q == 3) then + D_mn = D_mn - D_mn_pq + K_mn = K_mn - K_mn_pq + else + D_mn = D_mn + D_mn_pq + K_mn = K_mn + K_mn_pq + end if + R_is_zero = .false. + end do ! q + end do ! p + ! Multiply by prefactor L_m*L_n/4 and add to matrices + prefactor = this%RWG_basis%get_basis_edge_length(m) & + *this%RWG_basis%get_basis_edge_length(n) & + /4.0_wp + D_mn = D_mn*prefactor + K_mn = K_mn*prefactor + + end subroutine D_and_K_matrix_element_mn + + !!---------------------------------------------------------------------------- + + subroutine D_and_K_matrix_element_mn_BBB(& + this , & + D_mn , & + K_mn , & + m , & + n , & + r1_obs , & + r2_obs , & + r3_obs , & + p_m , & + wavenumber , & + region , & + gauss_quad_formula) + class (PMCHW_RWG_type) , intent(in) :: this + complex(wp) , intent(inout) :: D_mn + complex(wp) , intent(inout) :: K_mn + integer , intent(in) :: m + integer , intent(in) :: n + real(wp) , dimension(:, :) , intent(in) :: r1_obs + real(wp) , dimension(:, :) , intent(in) :: r2_obs + real(wp) , dimension(:, :) , intent(in) :: r3_obs + real(wp) , dimension(:, :) , intent(in) :: p_m + complex(wp) , intent(in) :: wavenumber + integer , intent(in) :: region + real(wp) , dimension(:, :) , intent(in) :: gauss_quad_formula + ! Variables for internal use ----------------------------------------------- + complex(wp), dimension(SPATIAL_DIM) :: inner_sum + complex(wp), dimension(SPATIAL_DIM) :: inner_sum_gradient + complex(wp) :: D_mn_pq + complex(wp) :: K_mn_pq + complex(wp) :: test_term + complex(wp) :: main_term + complex(wp) :: int_xi_I_zeta + complex(wp) :: int_eta_I_zeta + complex(wp) :: int_I_zeta + complex(wp) :: term2 + complex(wp) :: E1 + complex(wp) :: E2 + complex(wp) :: E3 + complex(wp) :: E4 + complex(wp) :: E5 + complex(wp) :: E6 + complex(wp) :: E7 + complex(wp) :: E8 + complex(wp) :: E9 + complex(wp) :: kR + complex(wp) :: subtr_terms_D_mn_pq + complex(wp) :: subtr_terms_K_mn_pq + complex(wp) :: green_func + complex(wp) :: grad_of_green_func + complex(wp) :: inner_sum2 + real(wp) , dimension(SPATIAL_DIM) :: r_obs + real(wp) , dimension(SPATIAL_DIM) :: r_src + real(wp) , dimension(SPATIAL_DIM) :: r1_src + real(wp) , dimension(SPATIAL_DIM) :: r2_src + real(wp) , dimension(SPATIAL_DIM) :: r3_src + real(wp) , dimension(SPATIAL_DIM) :: p_n + real(wp) , dimension(NUM_FACE_VERTICES, SPATIAL_DIM) :: face_coords + real(wp) , dimension(NUM_FACE_VERTICES, SPATIAL_DIM) ::edge_unit_normals_p + real(wp) , dimension(NUM_FACE_VERTICES, SPATIAL_DIM) ::edge_unit_normals_q + real(wp) , dimension(NUM_FACE_VERTICES) :: edge_lengths_p + real(wp) , dimension(NUM_FACE_VERTICES) :: edge_lengths_q + real(wp) , dimension(SPATIAL_DIM) :: face_unit_normal_p + real(wp) , dimension(SPATIAL_DIM) :: face_unit_normal_q + real(wp) :: face_area_p + real(wp) :: face_area_q + real(wp) :: R + real(wp) :: R_inv + real(wp) :: weight_J + real(wp) :: weight_k + real(wp) :: alpha + real(wp) :: beta + real(wp) :: gamma + real(wp) :: xi + real(wp) :: eta + real(wp) :: zeta + integer , dimension(NUM_FACES_IN_BASIS) :: free_vertices + integer , dimension(NUM_FACES_IN_BASIS) :: T_m + integer , dimension(NUM_FACES_IN_BASIS) :: T_n + real(wp) :: prefactor + logical :: faces_are_close + logical :: R_is_zero + integer :: num_quad_pnts + integer :: p + integer :: q + integer :: j + integer :: k + integer, dimension(24, 2) :: faces_in_plane + integer :: i + + num_quad_pnts = size(gauss_quad_formula, dim=1) + T_m = this%RWG_basis%get_adjacent_faces(m) + T_n = this%RWG_basis%get_adjacent_faces(n) + free_vertices = this%RWG_basis%get_free_vertices(n) + D_mn = ZERO_CMPLX + K_mn = ZERO_CMPLX + do p = 1, NUM_FACES_IN_BASIS + do q = 1, NUM_FACES_IN_BASIS + faces_are_close = .false. + R_is_zero = .false. + face_coords = this%RWG_basis%mesh%get_face_coords(T_n(q)) + ! More efficient to store rx_src for both q-values in beginning + r1_src = face_coords(1, :) + r2_src = face_coords(2, :) + r3_src = face_coords(3, :) + p_n = this%RWG_basis%mesh%get_vertex_coords(free_vertices(q)) + + D_mn_pq = ZERO_CMPLX + K_mn_pq = ZERO_CMPLX + test_term = ZERO_CMPLX + main_term = ZERO_CMPLX + do j = 1, num_quad_pnts + weight_j = gauss_quad_formula(j, GQF_WEIGHT_IDX) + alpha = gauss_quad_formula(j, GQF_XI_IDX) + beta = gauss_quad_formula(j, GQF_ETA_IDX) + gamma = gauss_quad_formula(j, GQF_ZETA_IDX) + ! More efficient to store r_obs + r_obs = r1_obs(p, :)*alpha + r2_obs(p, :)*beta & + + r3_obs(p, :)*gamma + + inner_sum = ZERO_CMPLX + inner_sum2 = ZERO_CMPLX + inner_sum_gradient = ZERO_CMPLX + do k = 1, num_quad_pnts + weight_k = gauss_quad_formula(k, GQF_WEIGHT_IDX) + xi = gauss_quad_formula(k, GQF_XI_IDX) + eta = gauss_quad_formula(k, GQF_ETA_IDX) + zeta = gauss_quad_formula(k, GQF_ZETA_IDX) + ! More efficient to store r_src + r_src = r1_src*xi + r2_src*eta + r3_src*zeta + + R = norm2(r_obs - r_src) + kR = wavenumber*R + + ! This check could be done much more efficiently + if ( this%are_obs_pnt_and_src_close(& + this%face_centroid( & + T_m(p) , & + 0 , & + gauss_quad_formula), & + this%face_centroid( & + T_n(q) , & + 0 , & + gauss_quad_formula), & + wavenumber , & + p=T_m(p) , & + q=T_n(q)) ) then + faces_are_close = .true. + if (is_close(R, 0._wp)) then + R_is_zero = .true. + end if + if (CAUCHY) then + ! Cauchy Principal value for singularity in green's function + call Cauchy_principal_value(& + green_func , & + grad_of_green_func, & + wavenumber , & + kR , & + R) + else + call green_func_smoothened(& + green_func , & + grad_of_green_func, & + wavenumber , & + kR , & + R , & + T_m(p)==T_n(q)) + end if + else + ! This should never occur + if (is_close(R, 0._wp)) then + R_is_zero = .true. + print *, 'Error: R is zero, but faces are not close' + stop 2 + else + R_inv = 1._wp/R + green_func = calc_green_func(wavenumber, kR, R_inv) + if (.not. T_m(p)==T_n(p)) then + ! No reason to waste computation time on integrals that will vanish + ! because the faces are on the same plane. Which they are if p and q + ! points are the same face. + grad_of_green_func = calc_grad_of_green_func(& + wavenumber, & + kR , & + R_inv , & + green_func=green_func) + end if + end if + end if + + inner_sum = inner_sum + weight_k*green_func*(r_src - p_n) + inner_sum2 = inner_sum2 + weight_k*green_func + inner_sum_gradient = inner_sum_gradient & + + weight_k*grad_of_green_func & + *cross_prod_3D(r_obs - r_src, r_src - p_n) + + end do ! k + + D_mn_pq = D_mn_pq + weight_j*dot_product(r_obs - p_m(p, :), & + inner_sum) + D_mn_pq = D_mn_pq - 4._wp/wavenumber**2*weight_j*inner_sum2 + K_mn_pq = K_mn_pq + weight_j*dot_product(r_obs - p_m(p, :), & + inner_sum_gradient) + + end do ! j + + if (faces_are_close .and. .not. CAUCHY) then + face_area_q = this%RWG_basis%mesh%face_area(T_n(q)) + face_unit_normal_q = this%RWG_basis%mesh%face_unit_normal(T_n(q)) + edge_lengths_q = this%get_edge_lengths(T_n(q)) + edge_unit_normals_q = calc_edge_unit_normals(& + edge_lengths_q , & + face_unit_normal_q, & + r1_src , & + r2_src , & + r3_src) + face_area_p = this%RWG_basis%mesh%face_area(T_m(p)) + face_unit_normal_p = this%RWG_basis%mesh%face_unit_normal(T_m(p)) + edge_lengths_p = this%get_edge_lengths(T_m(p)) + edge_unit_normals_p = calc_edge_unit_normals(& + edge_lengths_p , & + face_unit_normal_p, & + r1_obs(p, :) , & + r2_obs(p, :) , & + r3_obs(p, :)) + + call eval_subtracted_terms(& + subtr_terms_D_mn_pq, & + subtr_terms_K_mn_pq, & + wavenumber , & + r1_obs(p, :) , & + r2_obs(p, :) , & + r3_obs(p, :) , & + r1_src , & + r2_src , & + r3_src , & + p_m(p, :) , & + p_n , & + gauss_quad_formula , & + T_m(p) , & + T_n(q) , & + face_area_p , & + face_area_q , & + face_unit_normal_p , & + face_unit_normal_q , & + edge_lengths_p , & + edge_lengths_q , & + edge_unit_normals_p, & + edge_unit_normals_q) + + + D_mn_pq = D_mn_pq + subtr_terms_D_mn_pq + K_mn_pq = K_mn_pq + subtr_terms_K_mn_pq + end if + + if (p + q == 3) then + D_mn = D_mn - D_mn_pq + K_mn = K_mn - K_mn_pq + else + D_mn = D_mn + D_mn_pq + K_mn = K_mn + K_mn_pq + end if + end do ! q + end do ! p + ! Multiply by prefactor L_m*L_n/4 and add to matrices + prefactor = this%RWG_basis%get_basis_edge_length(m) & + *this%RWG_basis%get_basis_edge_length(n) & + /4.0_wp + D_mn = D_mn*prefactor + K_mn = K_mn*prefactor + + end subroutine D_and_K_matrix_element_mn_BBB + + !!---------------------------------------------------------------------------- + + subroutine solve_matrix_equation(this, numerical_method_in) + class (PMCHW_RWG_type), intent(inout) :: this + integer, optional , intent(in) :: numerical_method_in + ! Variables for internal use ----------------------------------------------- + integer :: numerical_method + complex(wp), dimension(:, :), allocatable :: A_matrix + complex(wp), dimension(:, :), allocatable :: B_vectors + integer , dimension(:) , allocatable :: IPIV + integer :: NN + integer :: NRHS + integer :: LDA + integer :: LDB + integer :: INFO + integer :: m + integer :: n + integer :: b + + if (.not. allocated(this%PMCHW_matrix) .or. & + .not. allocated(this%q_vectors)) then + print *, 'Error: PMCHW_RWG_mod: E_and_H_field_at_obs_pnt:' + print *, ' Object must be initialised, PMCHW_matrix and ', & + ' q_vectors must be set. ' + stop 2 + end if + + allocate(this%expansion_coeff_alpha(& + this%RWG_basis%num_bases, this%num_q_vectors)) + allocate(this%expansion_coeff_beta, mold=this%expansion_coeff_alpha) + + NN = 2*this%RWG_basis%num_bases + NRHS = this%num_q_vectors + LDA = NN + LDB = NN + allocate(IPIV(NN)) + allocate(B_vectors, source=this%q_vectors) + allocate(A_matrix, source=this%PMCHW_matrix) + + ! Set default numerical method to LU decomposition + if (.not. present(numerical_method_in)) then + numerical_method = 1 + else + numerical_method = numerical_method_in + end if + + select case (numerical_method) + case (1) + ! Solve matrix equation using LU decomposition + select case (wp) + case (real32) + call CGESV(NN, NRHS, this%PMCHW_matrix, LDA, IPIV, & + this%q_vectors, LDB, INFO) + case (real64) + call ZGESV(NN, NRHS, this%PMCHW_matrix, LDA, IPIV, & + this%q_vectors, LDB, INFO) + case (real128) + print *, 'Error: PMCHW_RWG_mod: solve_matrix_equation' + print *, ' LU-decomposition not available for quadruple ', & + 'precision.' + stop 2 + case default + print *, 'Error: PMCHW_RWG_mod: solve_matrix_equation' + print *, ' LU-decomposition not available for current ', & + 'data type precision.' + stop 2 + end select + !Check for the exact singularity. + if( INFO.gt.0 ) then + write(*,*)'The diagonal element of the triangular factor of A,' + write(*,*)'U(',INFO,',',INFO,') is zero, so that' + write(*,*)'A is singular; the solution could not be computed.' + stop + end if + case (2) + ! Solve matrix equation using some iterative mehtod. Not yet implemented + end select + + do b = 1, this%num_q_vectors + do m = 1, NN + if (m <= this%RWG_basis%num_bases) then + this%expansion_coeff_alpha(m, b) = this%q_vectors(m, b) + else + this%expansion_coeff_beta(m - this%RWG_basis%num_bases, b) = & + this%q_vectors(m, b) + end if + end do + end do + + end subroutine solve_matrix_equation + + !!---------------------------------------------------------------------------- + + function bistatic_scattering_cross_section(& + this , & + scattering_angle , & + arc_radius , & + phi , & + q_vector_idx , & + gauss_quad_formula, & + BBB ) & + result(res) + class (PMCHW_RWG_type) , intent(in) :: this + real(wp) , intent(in) :: scattering_angle + real(wp) , intent(in) :: arc_radius + real(wp), dimension(:, :), intent(in) :: gauss_quad_formula + integer , intent(in) :: phi + integer , intent(in) :: q_vector_idx + logical , intent(in) :: BBB + ! Result variable to be returned ------------------------------------------- + real(wp) :: res + ! Variables for internal use ----------------------------------------------- + complex(wp), dimension(SPATIAL_DIM) :: incoming_E_field + complex(wp), dimension(SPATIAL_DIM) :: incoming_H_field + complex(wp), dimension(:, :), allocatable :: scattered_E_field + complex(wp), dimension(:, :), allocatable :: scattered_H_field + complex(wp) :: radial_comp + real(wp) , dimension(SPATIAL_DIM) :: r + real(wp) :: scat_E_field_magn_sqrd + real(wp) :: inc_E_field_magn_sqrd + real(wp) :: r1 + real(wp) :: r2 + real(wp) :: r3 + integer :: i + integer :: l + + !--------------------------------------------------------------------------- + ! Assuming scatterer is localised in origio and that the arc radius is large + ! enough to cover the whole scatterer. + ! + ! Incoming E-field must (with current implementation) be polarized in + ! the positive x-direction and propagating in the positive z-direction. + !--------------------------------------------------------------------------- + + if (.not. allocated(this%expansion_coeff_alpha) .or. & + .not. allocated(this%expansion_coeff_beta)) then + print *, 'Error: PMCHW_RWG_mod: bistatic_scattering_cross_section:' + print *, ' Matrix equation must be solved ...' + stop 2 + end if + + if (allocated(this%inc_E_field_ampl)) then + if (is_close(this%inc_E_field_ampl(Y_IDX, q_vector_idx)%re, ZERO) & + .and. is_close(& + this%inc_E_field_ampl(Z_IDX, q_vector_idx)%re, ZERO)) then + continue + else + print *, 'Error: PMCHW_RWG_mod: bistatic_scattering_cross_section:' + print *, ' Polarisation of incoming E-field should be along ', & + 'the positive x-axis' + stop 2 + end if + else + print *, 'Error: PMCHW_RWG_mod: bistatic_scattering_cross_section:' + print *, ' Matrix equation must be solved ...' + stop 2 + end if + if (allocated(this%inc_wave_direction)) then + if (is_close(this%inc_wave_direction(X_IDX, q_vector_idx), ZERO) & + .and. is_close(& + this%inc_wave_direction(Y_IDX, q_vector_idx), ZERO) & + .and. is_close(& + this%inc_wave_direction(Z_IDX, q_vector_idx), UNITY)) then + continue + else + print *, 'Error: PMCHW_RWG_mod: bistatic_scattering_cross_section:' + print *, ' Incoming E-field should propagate in the positive', & + ' z-axis' + stop 2 + end if + else + print *, 'Error: PMCHW_RWG_mod: bistatic_scattering_cross_section:' + print *, ' Matrix equation must be solved ...' + stop 2 + end if + + allocate(scattered_E_field(SPATIAL_DIM, this%num_q_vectors)) + allocate(scattered_H_field(SPATIAL_DIM, this%num_q_vectors)) + + r1 = arc_radius*sin(scattering_angle) + r2 = 0._wp + r3 = arc_radius*cos(scattering_angle) + + select case (phi) + case (1) + ! Parallel scattering + r = [r1, r2, r3] + case (2) + ! Orthogonal scattering + r = [r2, r1, r3] + end select + + if (BBB) then + call this%E_and_H_field_at_obs_pnt_BBB(& + scattered_E_field , & + scattered_H_field , & + r , & + gauss_quad_formula, & + OUTER_REGION_IDX , & + scattered=.true.) + else + call this%E_and_H_field_at_obs_pnt(& + scattered_E_field , & + scattered_H_field , & + r , & + gauss_quad_formula, & + OUTER_REGION_IDX , & + scattered=.true.) + end if + + call this%inc_E_and_H_field_at_obs_pnt(& + incoming_E_field, & + incoming_H_field, & + q_vector_idx , & + r) + + + scat_E_field_magn_sqrd = ZERO + inc_E_field_magn_sqrd = ZERO + + do l = 1, SPATIAL_DIM + inc_E_field_magn_sqrd = inc_E_field_magn_sqrd & + + incoming_E_field(l)%re**2 & + + incoming_E_field(l)%im**2 + scat_E_field_magn_sqrd = scat_E_field_magn_sqrd & + + scattered_E_field(l, q_vector_idx)%re**2 & + + scattered_E_field(l, q_vector_idx)%im**2 + end do + res = 4._wp*PI*arc_radius**2*scat_E_field_magn_sqrd/inc_E_field_magn_sqrd + end function bistatic_scattering_cross_section + + !!---------------------------------------------------------------------------- + + function face_centroid(& + this , & + face_idx, & + num_intgr_pnts, & + intgr_pnts) & + result(res) + class (PMCHW_RWG_type) , intent(in) :: this + integer , intent(in) :: face_idx + integer , intent(in) :: num_intgr_pnts + real(wp), dimension(:, :), intent(in) :: intgr_pnts + real(wp), dimension(SPATIAL_DIM) :: res + ! Variables for internal use ----------------------------------------------- + + if (num_intgr_pnts == 4 .or. & + num_intgr_pnts == 7 .or. & + num_intgr_pnts == 13) then + res = intgr_pnts(1, :) + else + res = this%RWG_basis%mesh%face_centroid(face_idx) + end if + end function face_centroid + + !!---------------------------------------------------------------------------- + + subroutine write_solutions(this, q_vector_idx, filename) + class (PMCHW_RWG_type), intent(in) :: this + integer , intent(in) :: q_vector_idx + character(*) , intent(in) :: filename + ! Variables for internal use ----------------------------------------------- + integer , parameter :: num_columns = 4 + real(wp), dimension(this%RWG_basis%num_bases, num_columns) :: table + integer :: n + + if (.not. allocated(this%PMCHW_matrix) .or. & + .not. allocated(this%q_vectors)) then + print *, 'Error: PMCHW_RWG_mod: E_and_H_field_at_obs_pnt:' + print *, ' Object must be initialised, PMCHW_matrix and ', & + ' q_vectors must be set, and matrix equation must be ', & + ' solved.' + stop 2 + else if (.not. allocated(this%expansion_coeff_alpha) .or. & + .not. allocated(this%expansion_coeff_beta)) then + print *, 'Error: PMCHW_RWG_mod: E_and_H_field_at_obs_pnt:' + print *, ' Matrix equation for current PMCHW_matrix and ', & + 'q_vectors has not been solved' + stop 2 + end if + + table(:, 1) = this%expansion_coeff_alpha(:, q_vector_idx)%re + table(:, 2) = this%expansion_coeff_alpha(:, q_vector_idx)%im + table(:, 3) = this%expansion_coeff_beta(:, q_vector_idx)%re + table(:, 4) = this%expansion_coeff_beta(:, q_vector_idx)%im + + if (wp == real64) then + call r8mat_write(filename, this%RWG_basis%num_bases, num_columns, table) + else + print *, 'No write routine for current precision.' + end if + end subroutine write_solutions + + !!==================!! + ! Public procedures ! + !====================!======================================================== + + subroutine eval_outer_integrals(& + EFIE_integrals , & + MFIE_integrals , & + outer_intgr_pnts , & + inner_intgr_pnts , & + gauss_quad_formula, & + faces_are_close , & + p , & + q , & + wavenumber) + complex(wp), dimension(:) , intent(inout) :: EFIE_integrals + complex(wp), dimension(:) , intent(inout) :: MFIE_integrals + real(wp) , dimension(:, :), intent(in) :: outer_intgr_pnts + real(wp) , dimension(:, :), intent(in) :: inner_intgr_pnts + real(wp) , dimension(:, :), intent(in) :: gauss_quad_formula + logical , intent(in) :: faces_are_close + integer , intent(in) :: p + integer , intent(in) :: q + complex(wp) , intent(in) :: wavenumber + ! Variables for internal use ----------------------------------------------- + complex(wp), dimension(:), allocatable :: EFIE_inner_intgr_xi + complex(wp), dimension(:), allocatable :: EFIE_inner_intgr_eta + complex(wp), dimension(:), allocatable :: EFIE_inner_intgr_ + complex(wp), dimension(:), allocatable :: MFIE_inner_intgr_xi + complex(wp), dimension(:), allocatable :: MFIE_inner_intgr_eta + complex(wp), dimension(:), allocatable :: MFIE_inner_intgr_ + real(wp) , dimension(3) :: observation_pnt + integer, parameter :: NUM_EFIE_INTEGRALS = 9 + integer, parameter :: NUM_MFIE_INTEGRALS = 18 + integer :: num_inner_quad_pnts + integer :: num_outer_quad_pnts + real(wp) :: weight_j + real(wp) :: alpha_j + real(wp) :: beta_j + integer :: j + integer :: o + + if ((size(EFIE_integrals) /= NUM_EFIE_INTEGRALS) .or. & + (size(MFIE_integrals) /= NUM_MFIE_INTEGRALS)) then + print *, 'Error: RWG_basis_mod.f90: eval_outer_integrals:' + print *, ' Size of inout-matrices incorrect ...' + stop 1 + end if + EFIE_integrals = ZERO_CMPLX + MFIE_integrals = ZERO_CMPLX + + num_inner_quad_pnts = size(gauss_quad_formula, dim=1) + if (faces_are_close) then + num_outer_quad_pnts = num_inner_quad_pnts + else + ! Implement functionality that chooses 3-point quadrature with + ! degree of precision 2 and does not re-calulate the quadrature + ! points if gauss_quad_formula is already 3-point with degree 2. + num_outer_quad_pnts = num_inner_quad_pnts + end if + + ! As of now, there are no reason to store all inner intgrals per quad + ! point. I.e. EFIE_inner_intgr_xi etc. could be scalars + allocate(EFIE_inner_intgr_xi(num_outer_quad_pnts)) + allocate(EFIE_inner_intgr_eta(num_outer_quad_pnts)) + allocate(EFIE_inner_intgr_(num_outer_quad_pnts)) + allocate(MFIE_inner_intgr_xi(num_outer_quad_pnts)) + allocate(MFIE_inner_intgr_eta(num_outer_quad_pnts)) + allocate(MFIE_inner_intgr_(num_outer_quad_pnts)) + + do j = 1, num_outer_quad_pnts + EFIE_inner_intgr_xi(j) = ZERO_CMPLX + EFIE_inner_intgr_eta(j) = ZERO_CMPLX + EFIE_inner_intgr_(j) = ZERO_CMPLX + MFIE_inner_intgr_xi(j) = ZERO_CMPLX + MFIE_inner_intgr_eta(j) = ZERO_CMPLX + MFIE_inner_intgr_(j) = ZERO_CMPLX + ! Evaluate inner integrals + if (faces_are_close) then + observation_pnt = outer_intgr_pnts(j, :) + else + ! Implement functionality that chooses 3-point quadrature with + ! degree of precision 2 and does not re-calulate the quadrature + ! points if gauss_quad_formula is already 3-point with degree 2. + observation_pnt = outer_intgr_pnts(j, :) + + end if +!!$ print *, ' j:', j + call eval_green_func_integrals(& + EFIE_inner_intgr_xi(j), & + EFIE_inner_intgr_eta(j), & + EFIE_inner_intgr_(j) , & + MFIE_inner_intgr_xi(j), & + MFIE_inner_intgr_eta(j), & + MFIE_inner_intgr_(j) , & + observation_pnt , & + inner_intgr_pnts , & + gauss_quad_formula , & + wavenumber , & + faces_are_close , & + faces_are_in_same_plane=(p==q)) + + Weight_j = gauss_quad_formula(j, GQF_WEIGHT_IDX) + alpha_j = gauss_quad_formula(j, GQF_XI_IDX) + beta_j = gauss_quad_formula(j, GQF_ETA_IDX) + ! Evaluate EFIE face-pair integrals + EFIE_integrals(1) = EFIE_integrals(1) + weight_j*alpha_j & + *EFIE_inner_intgr_xi(j) + EFIE_integrals(2) = EFIE_integrals(2) + weight_j*alpha_j & + *EFIE_inner_intgr_eta(j) + EFIE_integrals(3) = EFIE_integrals(3) + weight_j*alpha_j & + *EFIE_inner_intgr_(j) + EFIE_integrals(4) = EFIE_integrals(4) + weight_j*beta_j & + *EFIE_inner_intgr_xi(j) + EFIE_integrals(5) = EFIE_integrals(5) + weight_j*beta_j & + *EFIE_inner_intgr_eta(j) + EFIE_integrals(6) = EFIE_integrals(6) + weight_j*beta_j & + *EFIE_inner_intgr_(j) + EFIE_integrals(7) = EFIE_integrals(7) + weight_j & + *EFIE_inner_intgr_xi(j) + EFIE_integrals(8) = EFIE_integrals(8) + weight_j & + *EFIE_inner_intgr_eta(j) + EFIE_integrals(9) = EFIE_integrals(9) + weight_j & + *EFIE_inner_intgr_(j) + ! Evaluate MFIE face-pair integrals + if (.not. p == q) then + ! No reason to waste computation time on integrals that will vanish + ! because the faces are on the same plane. Which they are if p and q + ! points at the same face. + MFIE_integrals(1) = MFIE_integrals(1) + weight_j*alpha_j & + *MFIE_inner_intgr_xi(j) + MFIE_integrals(2) = MFIE_integrals(2) + weight_j*alpha_j & + *MFIE_inner_intgr_eta(j) + MFIE_integrals(3) = MFIE_integrals(3) + weight_j*alpha_j & + *MFIE_inner_intgr_(j) + MFIE_integrals(4) = MFIE_integrals(4) + weight_j*beta_j & + *MFIE_inner_intgr_xi(j) + MFIE_integrals(5) = MFIE_integrals(5) + weight_j*beta_j & + *MFIE_inner_intgr_eta(j) + MFIE_integrals(6) = MFIE_integrals(6) + weight_j*beta_j & + *MFIE_inner_intgr_(j) + MFIE_integrals(7) = MFIE_integrals(7) + weight_j & + *MFIE_inner_intgr_xi(j) + MFIE_integrals(8) = MFIE_integrals(8) + weight_j & + *MFIE_inner_intgr_eta(j) + MFIE_integrals(9) = MFIE_integrals(9) + weight_j & + *MFIE_inner_intgr_(j) + MFIE_integrals(10) = MFIE_integrals(10) + weight_j*alpha_j*alpha_j & + *MFIE_inner_intgr_xi(j) + MFIE_integrals(11) = MFIE_integrals(11) + weight_j*alpha_j*alpha_j & + *MFIE_inner_intgr_eta(j) + MFIE_integrals(12) = MFIE_integrals(12) + weight_j*alpha_j*alpha_j & + *MFIE_inner_intgr_(j) + MFIE_integrals(13) = MFIE_integrals(13) + weight_j*beta_j*beta_j & + *MFIE_inner_intgr_xi(j) + MFIE_integrals(14) = MFIE_integrals(14) + weight_j*beta_j*beta_j & + *MFIE_inner_intgr_eta(j) + MFIE_integrals(15) = MFIE_integrals(15) + weight_j*beta_j*beta_j & + *MFIE_inner_intgr_(j) + MFIE_integrals(16) = MFIE_integrals(16) + weight_j*alpha_j*beta_j & + *MFIE_inner_intgr_xi(j) + MFIE_integrals(17) = MFIE_integrals(17) + weight_j*alpha_j*beta_j & + *MFIE_inner_intgr_eta(j) + MFIE_integrals(18) = MFIE_integrals(18) + weight_j*alpha_j*beta_j & + *MFIE_inner_intgr_(j) + end if + end do ! j + end subroutine eval_outer_integrals + + !!---------------------------------------------------------------------------- + + subroutine eval_green_func_integrals(& + green_func_intgr_xi , & + green_func_intgr_eta , & + green_func_intgr_ , & + grad_of_green_func_intgr_xi, & + grad_of_green_func_intgr_eta, & + grad_of_green_func_intgr_ , & + observation_pnt , & + quad_pnts , & + gauss_quad_formula , & + wavenumber , & + obs_pnt_and_src_are_close , & + faces_are_in_same_plane) + complex(wp) , intent(inout) :: green_func_intgr_xi + complex(wp) , intent(inout) :: green_func_intgr_eta + complex(wp) , intent(inout) :: green_func_intgr_ + complex(wp) , intent(inout) :: grad_of_green_func_intgr_xi + complex(wp) , intent(inout) :: grad_of_green_func_intgr_eta + complex(wp) , intent(inout) :: grad_of_green_func_intgr_ + real(wp), dimension(3) , intent(in) :: observation_pnt + real(wp), dimension(:, :), intent(in) :: quad_pnts + real(wp), dimension(:, :), intent(in) :: gauss_quad_formula + complex(wp) , intent(in) :: wavenumber + logical , intent(in) :: obs_pnt_and_src_are_close + logical , intent(in) :: faces_are_in_same_plane + ! Variables for internal use ----------------------------------------------- + integer, parameter :: GQF_WEIGHT_IDX = 1 + integer, parameter :: GQF_XI_IDX = 2 + integer, parameter :: GQF_ETA_IDX = 3 + real(wp) :: weight_k + real(wp) :: xi + real(wp) :: eta + real(wp) :: R + real(wp) :: R_inv + complex(wp) :: green_func + complex(wp) :: grad_of_green_func + complex(wp) :: kR + integer :: num_quad_pnts + integer :: k + + ! Add error handling if quad_pnts and gauss_quad_formula is now same size + num_quad_pnts = size(quad_pnts, dim=1) + + green_func_intgr_xi = ZERO_CMPLX + green_func_intgr_eta = ZERO_CMPLX + green_func_intgr_ = ZERO_CMPLX + grad_of_green_func_intgr_xi = ZERO_CMPLX + grad_of_green_func_intgr_eta = ZERO_CMPLX + grad_of_green_func_intgr_ = ZERO_CMPLX + do k = 1, num_quad_pnts + R = norm2(observation_pnt & + - quad_pnts(k, :)) + kR = wavenumber*R + if (obs_pnt_and_src_are_close) then + if (CAUCHY) then + ! Cauchy Principal value for singularity in green's function + call Cauchy_principal_value(& + green_func , & + grad_of_green_func, & + wavenumber , & + kR , & + R) + if (isnan(green_func%re)) then + print *, 'Cauchy - green_func is nan' + end if + if (isnan(grad_of_green_func%re)) then + print *, 'Cauchy - grad_of_green_func is nan' + end if + else + ! Singularity abstraction + call green_func_smoothened(& + green_func , & + grad_of_green_func, & + wavenumber , & + kR , & + R , & + faces_are_in_same_plane) + end if + else + R_inv = 1._wp/R + green_func = calc_green_func(wavenumber, kR, R_inv) + if (.not. faces_are_in_same_plane) then + ! No reason to waste computation time on integrals that will vanish + ! because the faces are on the same plane. Which they are if p and q + ! points are the same face. + grad_of_green_func = calc_grad_of_green_func(& + wavenumber, & + kR , & + R_inv , & + green_func=green_func) + end if + end if + + weight_k = gauss_quad_formula(k, GQF_WEIGHT_IDX) + xi = gauss_quad_formula(k, GQF_XI_IDX) + eta = gauss_quad_formula(k, GQF_ETA_IDX) + ! EFIE + green_func_intgr_xi = green_func_intgr_xi + weight_k*xi*green_func + green_func_intgr_eta = green_func_intgr_eta + weight_k*eta*green_func + green_func_intgr_ = green_func_intgr_ + weight_k*green_func + ! MFIE + if (.not. faces_are_in_same_plane) then + ! No reason to waste computation time on integrals that will vanish + ! because the faces are on the same plane. Which they are if p and q + ! are equal + grad_of_green_func_intgr_xi = grad_of_green_func_intgr_xi & + + weight_k*xi*grad_of_green_func + grad_of_green_func_intgr_eta = grad_of_green_func_intgr_eta & + + weight_k*eta*grad_of_green_func + grad_of_green_func_intgr_ = grad_of_green_func_intgr_ & + + weight_k*grad_of_green_func + end if + end do ! k + end subroutine eval_green_func_integrals + + !!---------------------------------------------------------------------------- + + function face_pair_integral_EFIE(& + r1_obs , & + r2_obs , & + r3_obs , & + r1_src , & + r2_src , & + r3_src , & + p_m , & + p_n , & + wavenumber, & + EFIE_integrals) & + result(return_value) + real(wp) , dimension(3), intent(in) :: r1_obs + real(wp) , dimension(3), intent(in) :: r2_obs + real(wp) , dimension(3), intent(in) :: r3_obs + real(wp) , dimension(3), intent(in) :: r1_src + real(wp) , dimension(3), intent(in) :: r2_src + real(wp) , dimension(3), intent(in) :: r3_src + real(wp) , dimension(3), intent(in) :: p_m + real(wp) , dimension(3), intent(in) :: p_n + complex(wp) , intent(in) :: wavenumber + complex(wp), dimension(:), intent(in) :: EFIE_integrals + complex(wp) :: return_value + ! Variables for internal use ----------------------------------------------- + complex(wp) :: int_xi_I_zeta + complex(wp) :: int_eta_I_zeta + complex(wp) :: int_I_zeta + complex(wp) :: term1 + complex(wp) :: term2 + + ! Integral of divergence of the basis-function f(r) + term1 = -4._wp/wavenumber**2*EFIE_integrals(9) + + ! Integral of basis-function + int_xi_I_zeta = & + + EFIE_integrals(3) & + - EFIE_integrals(1) & + - EFIE_integrals(2) + int_eta_I_zeta = & + + EFIE_integrals(6) & + - EFIE_integrals(4) & + - EFIE_integrals(5) + int_I_zeta = & + + EFIE_integrals(9) & + - EFIE_integrals(7) & + - EFIE_integrals(8) + + term2 = & + + dot_product(r1_obs, r1_src)*EFIE_integrals(1) & + + dot_product(r1_obs, r2_src)*EFIE_integrals(2) & + - dot_product(r1_obs, p_n) *EFIE_integrals(3) & + + dot_product(r2_obs, r1_src)*EFIE_integrals(4) & + + dot_product(r2_obs, r2_src)*EFIE_integrals(5) & + - dot_product(r2_obs, p_n) *EFIE_integrals(6) & + - dot_product(p_m , r1_src)*EFIE_integrals(7) & + - dot_product(p_m , r2_src)*EFIE_integrals(8) & + + dot_product(p_m , p_n) *EFIE_integrals(9) & + + dot_product(r1_obs, r3_src)*int_xi_I_zeta & + + dot_product(r2_obs, r3_src)*int_eta_I_zeta & + + dot_product(r3_obs, r3_src)*( & + + int_I_zeta & + - int_eta_I_zeta & + - int_xi_I_zeta ) & + - dot_product(p_m , r3_src)*int_I_zeta & + + dot_product(r3_obs, r1_src) & + *(EFIE_integrals(7) & + - EFIE_integrals(1) & + - EFIE_integrals(4)) & + + dot_product(r3_obs, r2_src) & + *(EFIE_integrals(8) & + - EFIE_integrals(2) & + - EFIE_integrals(5)) & + - dot_product(r3_obs, p_n) & + *(EFIE_integrals(9) & + - EFIE_integrals(3) & + - EFIE_integrals(6)) + return_value = term1 + term2 + end function face_pair_integral_EFIE + + !!---------------------------------------------------------------------------- + + function face_pair_integral_MFIE(& + r1_obs, & + r2_obs, & + r3_obs, & + r1_src, & + r2_src, & + r3_src, & + p_m , & + p_n , & + MFIE_integrals) & + result(res) + real(wp) , dimension(SPATIAL_DIM), intent(in) :: r1_obs + real(wp) , dimension(SPATIAL_DIM), intent(in) :: r2_obs + real(wp) , dimension(SPATIAL_DIM), intent(in) :: r3_obs + real(wp) , dimension(SPATIAL_DIM), intent(in) :: r1_src + real(wp) , dimension(SPATIAL_DIM), intent(in) :: r2_src + real(wp) , dimension(SPATIAL_DIM), intent(in) :: r3_src + real(wp) , dimension(SPATIAL_DIM), intent(in) :: p_m + real(wp) , dimension(SPATIAL_DIM), intent(in) :: p_n + complex(wp), dimension(:) , intent(in) :: MFIE_integrals + complex(wp) :: res + ! Variables for internal use ----------------------------------------------- + complex(wp) :: int_xi_I_zeta + complex(wp) :: int_eta_I_zeta + complex(wp) :: int_zeta_I_zeta + complex(wp) :: int_I_zeta + complex(wp) :: int_zeta_I_xi + complex(wp) :: int_zeta_I_eta + complex(wp) :: int_zeta_I_1 + complex(wp) :: int_xi_zeta_I_xi + complex(wp) :: int_xi_zeta_I_eta + complex(wp) :: int_xi_zeta_I_zeta + complex(wp) :: int_xi_zeta_I_1 + complex(wp) :: int_eta_zeta_I_xi + complex(wp) :: int_eta_zeta_I_eta + complex(wp) :: int_eta_zeta_I_zeta + complex(wp) :: int_eta_zeta_I_1 + complex(wp) :: int_zeta_zeta_I_xi + complex(wp) :: int_zeta_zeta_I_eta + complex(wp) :: int_zeta_zeta_I_1 + complex(wp) :: int_xi_xi_I_zeta + complex(wp) :: int_eta_eta_I_zeta + complex(wp) :: int_zeta_zeta_I_zeta + complex(wp) :: int_xi_eta_I_zeta + + ! Integral of the curl of the gradient of the Green's function + ! and the basis function f(r) + ! Firstly follows temporary variables to avoid repeating identical + ! summations, and to make the code more readable for debugging the + ! mathematical expressions. + int_xi_I_zeta = & + + MFIE_integrals(3) & + - MFIE_integrals(1) & + - MFIE_integrals(2) + int_eta_I_zeta = & + + MFIE_integrals(6) & + - MFIE_integrals(4) & + - MFIE_integrals(5) + int_I_zeta = & + + MFIE_integrals(9) & + - MFIE_integrals(7) & + - MFIE_integrals(8) + int_zeta_I_zeta = & + + int_I_zeta & + - int_xi_I_zeta & + - int_eta_I_zeta + int_zeta_I_xi = & + + MFIE_integrals(7) & + - MFIE_integrals(1) & + - MFIE_integrals(4) + int_zeta_I_eta = & + + MFIE_integrals(8) & + - MFIE_integrals(2) & + - MFIE_integrals(5) + int_zeta_I_1 = & + + MFIE_integrals(9) & + - MFIE_integrals(3) & + - MFIE_integrals(6) + int_xi_zeta_I_xi = & + + MFIE_integrals(1) & + - MFIE_integrals(10) & + - MFIE_integrals(16) + int_eta_zeta_I_xi = & + + MFIE_integrals(4) & + - MFIE_integrals(16) & + - MFIE_integrals(13) + int_zeta_zeta_I_xi = & + + int_zeta_I_xi & + - int_xi_zeta_I_xi & + - int_eta_zeta_I_xi + int_xi_zeta_I_eta = & + + MFIE_integrals(2) & + - MFIE_integrals(11) & + - MFIE_integrals(17) + int_eta_zeta_I_eta = & + + MFIE_integrals(5) & + - MFIE_integrals(14) & + - MFIE_integrals(17) + int_zeta_zeta_I_eta = & + + int_zeta_I_eta & + - int_xi_zeta_I_eta & + - int_eta_zeta_I_eta + int_xi_xi_I_zeta = & + + MFIE_integrals(12) & + - MFIE_integrals(10) & + - MFIE_integrals(11) + int_xi_eta_I_zeta = & + + MFIE_integrals(18) & + - MFIE_integrals(16) & + - MFIE_integrals(17) + int_eta_eta_I_zeta = & + + MFIE_integrals(15) & + - MFIE_integrals(14) & + - MFIE_integrals(13) + int_xi_zeta_I_zeta = & + + int_xi_I_zeta & + - int_xi_xi_I_zeta & + - int_xi_eta_I_zeta + int_eta_zeta_I_zeta = & + + int_eta_I_zeta & + - int_xi_eta_I_zeta & + - int_eta_eta_I_zeta + int_zeta_zeta_I_1 = & + + int_zeta_I_1 & + - int_xi_zeta_I_1 & + - int_eta_zeta_I_1 + int_xi_zeta_I_1 = & + + MFIE_integrals(3) & + - MFIE_integrals(12) & + - MFIE_integrals(18) + int_eta_zeta_I_1 = & + + MFIE_integrals(6) & + - MFIE_integrals(15) & + - MFIE_integrals(18) + int_zeta_zeta_I_zeta = & + + int_zeta_zeta_I_1 & + - int_zeta_zeta_I_xi & + - int_zeta_zeta_I_eta + + if (.false.) then + write (*,*) int_xi_eta_I_zeta + end if + res = ZERO_CMPLX + & + ! Cross product including p_n at RHS + dot_product(cross_prod_3D(r1_src, p_n), ( & + MFIE_integrals(1)*r1_obs & + + MFIE_integrals(4)*r2_obs & + + int_zeta_I_xi*r3_obs & + - MFIE_integrals(7)*p_m )) & + + dot_product(cross_prod_3D(r2_src, p_n), ( & + MFIE_integrals(2)*r1_obs & + + MFIE_integrals(5)*r2_obs & + + int_zeta_I_eta*r3_obs & + - MFIE_integrals(8)*p_m )) & + + dot_product(cross_prod_3D(r3_src, p_n), ( & + int_xi_I_zeta*r1_obs & + + int_eta_I_zeta*r2_obs & + + int_zeta_I_zeta*r3_obs & + - int_I_zeta*p_m )) & + ! Cross product including r1_src at RHS + + dot_product(cross_prod_3D(r1_obs, r1_src), ( & + MFIE_integrals(10)*r1_obs & + + MFIE_integrals(16)*r2_obs & + + int_xi_zeta_I_xi*r3_obs & + - MFIE_integrals(1)*p_m )) & + + dot_product(cross_prod_3D(r2_obs, r1_src), ( & + MFIE_integrals(16)*r1_obs & + + MFIE_integrals(13)*r2_obs & + + int_eta_zeta_I_xi*r3_obs & + - MFIE_integrals(4)*p_m )) & + + dot_product(cross_prod_3D(r3_obs, r1_src), ( & + int_xi_zeta_I_xi*r1_obs & + + int_eta_zeta_I_xi*r2_obs & + - int_zeta_I_xi*p_m & + + int_zeta_zeta_I_xi*r3_obs )) & + ! Cross product including r2_src at RHS + + dot_product(cross_prod_3D(r1_obs, r2_src), ( & + MFIE_integrals(11)*r1_obs & + + MFIE_integrals(17)*r2_obs & + + int_xi_zeta_I_eta*r3_obs & + - MFIE_integrals(2)*p_m )) & + + dot_product(cross_prod_3D(r2_obs, r2_src), ( & + MFIE_integrals(17)*r1_obs & + + MFIE_integrals(14)*r2_obs & + + int_eta_zeta_I_eta*r3_obs & + - MFIE_integrals(5)*p_m )) & + + dot_product(cross_prod_3D(r3_obs, r2_src), ( & + int_xi_zeta_I_eta*r1_obs & + + int_eta_zeta_I_eta*r2_obs & + - int_zeta_I_eta*p_m & + + int_zeta_zeta_I_eta*r3_obs )) & + ! Cross product including r3_src at RHS + + dot_product(cross_prod_3D(r1_obs, r3_src), ( & + int_xi_xi_I_zeta*r1_obs & + + int_xi_eta_I_zeta*r2_obs & + + int_xi_zeta_I_zeta*r3_obs & + - int_xi_I_zeta*p_m )) & + + dot_product(cross_prod_3D(r2_obs, r3_src), ( & + int_xi_eta_I_zeta*r1_obs & + + int_eta_eta_I_zeta*r2_obs & + + int_eta_zeta_I_zeta*r3_obs & + - int_eta_I_zeta*p_m )) & + + dot_product(cross_prod_3D(r3_obs, r3_src), ( & + int_xi_zeta_I_zeta*r1_obs & + + int_eta_zeta_I_zeta*r2_obs & + + int_zeta_zeta_I_zeta*r3_obs & + - int_zeta_I_zeta*p_m )) & + ! Cross product including p_n at RHS + - dot_product(cross_prod_3D(r1_obs, p_n), ( & + MFIE_integrals(12)*r1_obs & + + MFIE_integrals(18)*r2_obs & + + int_xi_zeta_I_1*r3_obs & + - MFIE_integrals(3)*p_m )) & + - dot_product(cross_prod_3D(r2_obs, p_n), ( & + MFIE_integrals(18)*r1_obs & + + MFIE_integrals(15)*r2_obs & + + int_eta_zeta_I_1*r3_obs & + - MFIE_integrals(6)*p_m )) & + - dot_product(cross_prod_3D(r3_obs, p_n), ( & + int_xi_zeta_I_1*r1_obs & + + int_eta_zeta_I_1*r2_obs & + + int_zeta_zeta_I_1*r3_obs & + - int_zeta_I_1*p_m )) + + end function face_pair_integral_MFIE + + !!---------------------------------------------------------------------------- + + function are_obs_pnt_and_src_close(& + this , & + obs_pnt , & + src , & + wavenumber, & + p , & + q) & + result(res) + class(PMCHW_RWG_type) , intent(in) :: this + real(wp), dimension(SPATIAL_DIM), intent(in) :: obs_pnt + real(wp), dimension(SPATIAL_DIM), intent(in) :: src + complex(wp) , intent(in) :: wavenumber + integer , optional , intent(in) :: p + integer , optional , intent(in) :: q + logical :: res + ! Variables for internal use ----------------------------------------------- + real(wp) :: seperation_dist + integer, dimension(NUM_FACE_VERTICES) :: vertices_of_p + integer, dimension(NUM_FACE_VERTICES) :: vertices_of_q + seperation_dist = norm2(obs_pnt - src) + if (present(p) .and. present(q)) then + vertices_of_p = this%RWG_basis%mesh%get_vertices_of_face(p) + vertices_of_q = this%RWG_basis%mesh%get_vertices_of_face(q) + if (p == q) then + res = .true. + else if ( any(vertices_of_p == vertices_of_q(1)) .or. & + any(vertices_of_p == vertices_of_q(2)) .or. & + any(vertices_of_p == vertices_of_q(3)) ) then + res = .true. + else if (seperation_dist < & + PROP_CONST_OBS_PNT_SRC_CLOSE*2*PI/wavenumber%re) then + res = .true. + else + res = .false. + end if + else if (seperation_dist < & + PROP_CONST_OBS_PNT_SRC_CLOSE*2*PI/wavenumber%re) then + res = .true. + else + res = .false. + end if + end function are_obs_pnt_and_src_close + + !!---------------------------------------------------------------------------- + + function dbl_singularity_intgr(& + p , & + q , & + r1_obs , & + r2_obs , & + r3_obs , & + r1_src , & + r2_src , & + r3_src , & + p_m , & + p_n , & + face_area_p , & + face_area_q , & + face_unit_normal_p , & + face_unit_normal_q , & + edge_lengths_p , & + edge_lengths_q , & + edge_unit_normals_p, & + edge_unit_normals_q, & + free_vertice_diff) & + result(res) + integer , intent(in) :: p + integer , intent(in) :: q + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r1_obs + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r2_obs + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r3_obs + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r1_src + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r2_src + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r3_src + real(wp), dimension(SPATIAL_DIM) , intent(in) :: p_m + real(wp), dimension(SPATIAL_DIM) , intent(in) :: p_n + real(wp), dimension(NUM_FACE_VERTICES, SPATIAL_DIM) & + , intent(in) :: edge_unit_normals_p + real(wp), dimension(NUM_FACE_VERTICES, SPATIAL_DIM) & + , intent(in) :: edge_unit_normals_q + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: edge_lengths_p + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: edge_lengths_q + real(wp), dimension(SPATIAL_DIM) , intent(in) :: face_unit_normal_p + real(wp), dimension(SPATIAL_DIM) , intent(in) :: face_unit_normal_q + real(wp), dimension(SPATIAL_DIM) , intent(in) :: free_vertice_diff + real(wp) , intent(in) :: face_area_p + real(wp) , intent(in) :: face_area_q + complex(wp) :: res + ! Variables for internal use ----------------------------------------------- + real(wp) :: line_integral + real(wp) :: X1_minus_1 + real(wp) :: X1_plus_1 + real(wp), dimension(:, :), allocatable :: gauss_quad_formula + real(wp) , dimension(SPATIAL_DIM) :: hnX1_minus_3 + real(wp) , dimension(SPATIAL_DIM) :: X2_minus_1 + real(wp) , dimension(SPATIAL_DIM) :: X2_plus_1 + real(wp) , dimension(SPATIAL_DIM) :: X3_minus_1 + real(wp) , dimension(SPATIAL_DIM) :: X3_plus_1 + real(wp) , dimension(SPATIAL_DIM) :: X4_minus_1 + real(wp) , dimension(SPATIAL_DIM) :: X4_plus_1 + real(wp) , dimension(SPATIAL_DIM) :: edge1 + real(wp) , dimension(SPATIAL_DIM) :: edge2 + real(wp) , dimension(SPATIAL_DIM) :: edge3 + real(wp) , dimension(SPATIAL_DIM) :: temp1 + real(wp) , dimension(SPATIAL_DIM) :: source_pnt + real(wp) :: weight + real(wp) :: abscissa + integer , dimension(NUM_FACE_VERTICES) :: face_edges + integer :: num_quad_pnts + integer :: l + integer :: j + logical , parameter :: X2_minus_only = .true. + + ! Using Gauss-Legendre 5-point formula for line integrals over triangle + ! edges. + allocate(gauss_quad_formula, source=GQF_Legendre_5pnt) + num_quad_pnts = size(GQF_Legendre_5pnt, dim=1) + edge1 = r3_src - r2_src + edge2 = r1_src - r3_src + edge3 = r2_src - r1_src + res = ZERO_CMPLX + do l = 1, NUM_FACE_VERTICES + line_integral = ZERO + ! This quantity is only dependent on the edge, not the explicit value + ! of the source point r' + temp1 = cross_prod_3D(free_vertice_diff, edge_unit_normals_q(l, :)) + do j = 1, num_quad_pnts + weight = gauss_quad_formula(j, GQF_WEIGHT_IDX) + source_pnt = map_GLQF_pnt_to_triangle_edge(& + gauss_quad_formula, & + edge1 , & + edge2 , & + edge3 , & + r1_src , & + r2_src , & + r3_src , & + j , & + l) + ! Evaluate inner integral + call inner_intgr_of_subtr_terms(& + hnX1_minus_3 , & + X1_minus_1 , & + X1_plus_1 , & + X2_minus_1 , & + X2_plus_1 , & + X3_minus_1 , & + X3_plus_1 , & + X4_minus_1 , & + X4_plus_1 , & + X2_minus_only , & + source_pnt , & + r1_obs , & + r2_obs , & + r3_obs , & + p_m , & + face_area_p , & + face_unit_normal_p, & + edge_lengths_p , & + edge_unit_normals_p) + ! Calculate the integrand of the outer test integral and use it in + ! the quadrature sum + line_integral = line_integral + weight*dot_product(temp1, X2_minus_1) + end do ! j + select case (l) + case (1) + res = res + 0.5_wp*norm2(edge1)*line_integral + case (2) + res = res + 0.5_wp*norm2(edge2)*line_integral + case (3) + res = res + 0.5_wp*norm2(edge3)*line_integral + end select + end do ! l + res = res*0.5_wp*PI4_INV/(face_area_q*face_area_p) + + end function dbl_singularity_intgr + + !!---------------------------------------------------------------------------- + + subroutine eval_subtracted_terms(& + subtr_terms_D , & + subtr_terms_K , & + wavenumber , & + r1_obs , & + r2_obs , & + r3_obs , & + r1_src , & + r2_src , & + r3_src , & + p_m , & + p_n , & + gauss_quad_formula, & + p , & + q , & + face_area_p , & + face_area_q , & + face_unit_normal_p , & + face_unit_normal_q , & + edge_lengths_p , & + edge_lengths_q , & + edge_unit_normals_p, & + edge_unit_normals_q) + complex(wp) , intent(inout) :: subtr_terms_D + complex(wp) , intent(inout) :: subtr_terms_K + complex(wp) , intent(in) :: wavenumber + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r1_obs + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r2_obs + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r3_obs + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r1_src + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r2_src + real(wp), dimension(SPATIAL_DIM) , intent(in) :: r3_src + real(wp), dimension(SPATIAL_DIM) , intent(in) :: p_m + real(wp), dimension(SPATIAL_DIM) , intent(in) :: p_n + real(wp), dimension(:, :) , intent(in) :: gauss_quad_formula + integer , intent(in) :: p + integer , intent(in) :: q + real(wp), dimension(NUM_FACE_VERTICES, SPATIAL_DIM) & + , intent(in) :: edge_unit_normals_p + real(wp), dimension(NUM_FACE_VERTICES, SPATIAL_DIM) & + , intent(in) :: edge_unit_normals_q + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: edge_lengths_p + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: edge_lengths_q + real(wp), dimension(SPATIAL_DIM) , intent(in) :: face_unit_normal_p + real(wp), dimension(SPATIAL_DIM) , intent(in) :: face_unit_normal_q + real(wp) , intent(in) :: face_area_p + real(wp) , intent(in) :: face_area_q + ! Variables for internal use ----------------------------------------------- + complex(wp), dimension(SPATIAL_DIM) :: X2 + complex(wp), dimension(SPATIAL_DIM) :: X4 + complex(wp) :: X1 + complex(wp) :: Q_hnX1_minus_3 + complex(wp) :: Q_X1 + complex(wp) :: Q_X2 + complex(wp) :: Q_X4 + complex(wp) :: k2 + complex(wp) :: half_of_k2 + real(wp) , dimension(SPATIAL_DIM) :: hnX1_minus_3 + real(wp) , dimension(SPATIAL_DIM) :: X2_minus_1 + real(wp) , dimension(SPATIAL_DIM) :: X2_plus_1 + real(wp) , dimension(SPATIAL_DIM) :: X3_minus_1 + real(wp) , dimension(SPATIAL_DIM) :: X3_plus_1 + real(wp) , dimension(SPATIAL_DIM) :: X4_minus_1 + real(wp) , dimension(SPATIAL_DIM) :: X4_plus_1 + real(wp) , dimension(SPATIAL_DIM) :: observation_pnt + real(wp) , dimension(SPATIAL_DIM) :: free_vertice_diff + real(wp) , dimension(SPATIAL_DIM) :: temp_vec + real(wp) :: X1_minus_1 + real(wp) :: X1_plus_1 + real(wp) :: weight + real(wp) :: alpha + real(wp) :: beta + real(wp) :: gamma + integer , dimension(NUM_FACE_VERTICES) :: face_edges + integer :: num_intgr_pnts + integer :: k + + k2 = wavenumber**2 + half_of_k2 = k2*0.5_wp + free_vertice_diff = p_m - p_n + + Q_hnX1_minus_3 = ZERO_CMPLX + Q_X1 = ZERO_CMPLX + Q_X2 = ZERO_CMPLX + Q_X4 = ZERO_CMPLX + + num_intgr_pnts = size(gauss_quad_formula, dim=1) + + do k = 1, num_intgr_pnts + weight = gauss_quad_formula(k, GQF_WEIGHT_IDX) + alpha = gauss_quad_formula(k, GQF_XI_IDX) + beta = gauss_quad_formula(k, GQF_ETA_IDX) + gamma = gauss_quad_formula(k, GQF_ZETA_IDX) + observation_pnt = alpha*r1_obs + beta*r2_obs + gamma*r3_obs + !observation_pnt = outer_intgr_pnts(k, :) + + ! + ! X1, X2, and X4 symbolises the three variations of inner integrals + ! necessary to evaluate emerging from having subtracted terms + ! in the inner integrands + ! + ! X1_minus_1: integral of 1/R times the divergence of f(r') + ! X1_plus_1: integral of R times the divergence of f(r') + ! X2_minus_1: integral of 1/R times f(r') + ! X2_plus_1: integral of R times f(r') + ! X4_minus_1: integral of grad 1/R crossed with f(r') + ! X4_plus_1: integral of grad R crossed with f(r') + ! + ! Subtracted terms: + ! 1/(4*PI)(1/R - k*R/2) + + call inner_intgr_of_subtr_terms(& + hnX1_minus_3 , & + X1_minus_1 , & + X1_plus_1 , & + X2_minus_1 , & + X2_plus_1 , & + X3_minus_1 , & + X3_plus_1 , & + X4_minus_1 , & + X4_plus_1 , & + .false. , & + observation_pnt , & + r1_src , & + r2_src , & + r3_src , & + p_n , & + face_area_q , & + face_unit_normal_q, & + edge_lengths_q , & + edge_unit_normals_q) + + if (isnan(X1_minus_1)) then + print *, 'X1_minus_1 is NaN' + end if + if (isnan(X1_plus_1)) then + print *, 'X1_plus_1 is NaN' + end if + if (any(isnan(X2_minus_1))) then + print *, 'X2_minus_1 is NaN' + end if + if (any(isnan(X2_plus_1))) then + print *, 'X2_plus_1 is NaN' + end if + if (any(isnan(X4_minus_1))) then + print *, 'X4_minus_1 is NaN' + end if + if (any(isnan(X4_plus_1))) then + print *, 'X4_plus_1 is NaN' + end if + + X1 = X1_minus_1 - half_of_k2*X1_plus_1 + X2 = X2_minus_1 - half_of_k2*X2_plus_1 + X4 = -half_of_k2*X4_plus_1 !+ X4_minus_1 + + temp_vec = observation_pnt - p_m + Q_hnX1_minus_3 = Q_hnX1_minus_3 + weight*dot_product(temp_vec, & + cross_prod_3D(free_vertice_diff, hnX1_minus_3)) + Q_X1 = Q_X1 + weight*X1 + Q_X2 = Q_X2 + weight*dot_product(temp_vec, X2) ! Be aware of + Q_X4 = Q_X4 + weight*dot_product(temp_vec, X4) ! cmplx conjugate + end do ! k + + subtr_terms_D = PI4_inv/face_area_q*(-4._wp/k2*Q_X1 + Q_X2) + subtr_terms_K = PI4_inv/face_area_q*( Q_X4 & + - Q_hnX1_minus_3 ) & + - dbl_singularity_intgr(& + p , & + q , & + r1_obs , & + r2_obs , & + r3_obs , & + r1_src , & + r2_src , & + r3_src , & + p_m , & + p_n , & + face_area_p , & + face_area_q , & + face_unit_normal_p , & + face_unit_normal_q , & + edge_lengths_p , & + edge_lengths_q , & + edge_unit_normals_p, & + edge_unit_normals_q, & + free_vertice_diff) + + + end subroutine eval_subtracted_terms + + !!---------------------------------------------------------------------------- + + subroutine green_func_smoothened(& + G_subtracted , & + grad_of_G_subtracted, & + wavenumber , & + kR , & + R , & + faces_are_on_same_plane) + complex(wp), intent(inout) :: G_subtracted + complex(wp), intent(inout) :: grad_of_G_subtracted + complex(wp), intent(in) :: wavenumber + complex(wp), intent(in) :: kR + real(wp) , intent(in) :: R + logical , intent(in) :: faces_are_on_same_plane + ! Variables for internal use ----------------------------------------------- + complex(wp) :: exponential + complex(wp) :: G + complex(wp) :: k2 + complex(wp) :: k2R + complex(wp) :: half_of_k2 + real(wp) :: R_inv + + k2 = wavenumber**2 + + if (is_close(R, ZERO)) then + G_subtracted = I_IMAG*wavenumber*PI4_INV + grad_of_G_subtracted = I_IMAG*k2*wavenumber*PI4_INV/3._wp + else + ! Helping variables defined to avoid calculating the same quantity twice + R_inv = 1._wp/R + k2R = k2*R + half_of_k2 = k2/2._wp + if (is_close(wavenumber%im, 0._wp)) then + exponential = cmplx(cos(kR%re), sin(kR%re)) + else + exponential = exp(I_IMAG*kR) + end if + G = exponential*R_inv + + G_subtracted = ( G - (R_inv - R*half_of_k2) )*PI4_INV + + if (.not. faces_are_on_same_plane) then + ! No reason to waste computation time on integrals that will vanish + ! because the faces are on the same plane. Which they are if p and q + ! points at the same face. + grad_of_G_subtracted = ( G*(R_inv - I_IMAG*wavenumber) & + - R_inv**2 - half_of_k2 )*PI4_INV*R_inv + end if + end if + + end subroutine green_func_smoothened + + !!---------------------------------------------------------------------------- + + subroutine inner_intgr_of_subtr_terms(& + hnX1_minus_3 , & + X1_minus_1 , & + X1_plus_1 , & + X2_minus_1 , & + X2_plus_1 , & + X3_minus_1 , & + X3_plus_1 , & + X4_minus_1 , & + X4_plus_1 , & + X2_minus_only , & + observation_pnt , & + r1_src , & + r2_src , & + r3_src , & + p_vec , & + face_area , & + face_unit_normal, & + edge_lengths , & + edge_unit_normals) + + ! X1, X2, and X3 symbolises the three variations of inner integrals + ! necessary to evaluate emerging from having subtracted terms + ! in the inner integrands + ! + ! X1_minus_1: integral of 1/R times the divergence of f(r') + ! X1_plus_1: integral of R times the divergence of f(r') + ! X2_minus_1: integral of 1/R times f(r') + ! X2_plus_1: integral of R times f(r') + ! X3_minus_1: integral of grad 1/R + ! X3_plus_1: integral of grad R + ! X4_minus_1: integral of grad 1/R crossed with f(r') + ! X4_plus_1: integral of grad R crossed with f(r') + ! + ! Subtracted terms: + ! 1/(4*PI)(1/R - k*R/2) + real(wp) , intent(inout) :: X1_minus_1 + real(wp) , intent(inout) :: X1_plus_1 + real(wp) , dimension(SPATIAL_DIM), intent(inout) :: hnX1_minus_3 + real(wp) , dimension(SPATIAL_DIM), intent(inout) :: X2_minus_1 + real(wp) , dimension(SPATIAL_DIM), intent(inout) :: X2_plus_1 + real(wp) , dimension(SPATIAL_DIM), intent(inout) :: X3_minus_1 + real(wp) , dimension(SPATIAL_DIM), intent(inout) :: X3_plus_1 + real(wp) , dimension(SPATIAL_DIM), intent(inout) :: X4_minus_1 + real(wp) , dimension(SPATIAL_DIM), intent(inout) :: X4_plus_1 + real(wp) , dimension(SPATIAL_DIM), intent(in) :: observation_pnt + real(wp) , dimension(SPATIAL_DIM), intent(in) :: r1_src + real(wp) , dimension(SPATIAL_DIM), intent(in) :: r2_src + real(wp) , dimension(SPATIAL_DIM), intent(in) :: r3_src + real(wp) , dimension(SPATIAL_DIM), intent(in) :: p_vec + real(wp) , intent(in) :: face_area + real(wp) , dimension(SPATIAL_DIM), intent(in) :: face_unit_normal + real(wp) , dimension(SPATIAL_DIM), intent(in) :: edge_lengths + real(wp) , dimension(:, :) , intent(in) :: edge_unit_normals + logical , intent(in) :: X2_minus_only + ! Variables for internal use ----------------------------------------------- + real(wp), dimension(SPATIAL_DIM) :: temp1 + real(wp), dimension(SPATIAL_DIM) :: temp2 + real(wp), dimension(SPATIAL_DIM) :: temp3 + integer :: l + ! Variables for representing triangle transformed to an orthogonal basis --- + real(wp), dimension(NUM_FACE_VERTICES) :: R_plus + real(wp), dimension(NUM_FACE_VERTICES) :: R_minus + real(wp), dimension(NUM_FACE_VERTICES) :: R_0 + real(wp), dimension(NUM_FACE_VERTICES) :: s_plus + real(wp), dimension(NUM_FACE_VERTICES) :: s_minus + real(wp), dimension(NUM_FACE_VERTICES) :: t + real(wp), dimension(SPATIAL_DIM) :: rho + real(wp), dimension(SPATIAL_DIM) :: u + real(wp), dimension(SPATIAL_DIM) :: v + real(wp) :: h + real(wp) :: u_3 + real(wp) :: v_3 + real(wp) :: u_0 + real(wp) :: v_0 + ! Variables for storing part of solutions (iterative values) --------------- + real(wp), dimension(NUM_FACE_VERTICES) :: I_l_minus_1 + real(wp), dimension(NUM_FACE_VERTICES) :: I_l_plus_1 + real(wp), dimension(NUM_FACE_VERTICES) :: I_l_plus_3 + real(wp) :: I_S_minus_3 + real(wp) :: I_S_minus_1 + real(wp) :: I_S_plus_1 + real(wp), dimension(SPATIAL_DIM) :: hn + real(wp), dimension(SPATIAL_DIM) :: edge_unit_normal_sum + + + temp1 = observation_pnt - r1_src + temp3 = observation_pnt - p_vec + + ! Notations for analytical formulas of integrals on triangles + u = (r2_src - r1_src)/edge_lengths(3) + v = -edge_unit_normals(3, :) + ! Error check + if (.not. is_close(norm2(u), 1._wp)) then + print *, 'Error: PMCHW_RWG_mod: inner_intgr_of_subtr_terms:' + print *, ' The vector "u" should be a unit vector.' + stop 2 + else if (.not. is_close(norm2(u), 1._wp)) then + print *, 'Error: PMCHW_RWG_mod: inner_intgr_of_subtr_terms:' + print *, ' The vector "u" should be a unit vector.' + stop 2 + else if (.not. is_close(norm2(face_unit_normal), 1._wp)) then + print *, 'Error: PMCHW_RWG_mod: inner_intgr_of_subtr_terms:' + print *, ' The face_unit_normal should be a unit vector.' + stop 2 + else if (.not. is_close(norm2(edge_unit_normals(1, :)), 1._wp)) then + print *, 'Error: PMCHW_RWG_mod: inner_intgr_of_subtr_terms:' + print *, ' The edge_unit_normals(1, :) should be a unit vector.' + stop 2 + else if (.not. is_close(norm2(edge_unit_normals(2, :)), 1._wp)) then + print *, 'Error: PMCHW_RWG_mod: inner_intgr_of_subtr_terms:' + print *, ' The edge_unit_normals(2, :) should be a unit vector.' + stop 2 + else if (.not. is_close(norm2(edge_unit_normals(3, :)), 1._wp)) then + print *, 'Error: PMCHW_RWG_mod: inner_intgr_of_subtr_terms:' + print *, ' The edge_unit_normals(3, :) should be a unit vector.' + stop 2 + end if + R_plus(1) = norm2(observation_pnt - r3_src) + R_plus(2) = norm2(temp1) + R_plus(3) = norm2(observation_pnt - r2_src) + R_minus(2) = R_plus(1) + R_minus(3) = R_plus(2) + R_minus(1) = R_plus(3) + h = dot_product(face_unit_normal, temp1) + hn = h*face_unit_normal + rho = observation_pnt - h*face_unit_normal + u_3 = dot_product((r3_src - r1_src), u) + v_3 = 2*face_area/edge_lengths(3) + u_0 = dot_product(temp1, u) + v_0 = dot_product(temp1, v) + s_minus(1) = -( (edge_lengths(3) - u_0)*(edge_lengths(3) - u_3) + v_0*v_3 )& + /edge_lengths(1) + s_minus(2) = -( u_3*(u_3 - u_0) + v_3*(v_3 - v_0) )/edge_lengths(2) + s_minus(3) = -u_0 + s_plus(1) = s_minus(1) + edge_lengths(1) + s_plus(2) = s_minus(2) + edge_lengths(2) + s_plus(3) = s_minus(3) + edge_lengths(3) + t(1) = ( v_0*(u_3 - edge_lengths(3)) + v_3*(edge_lengths(3) - u_0) ) & + /edge_lengths(1) + t(2) = ( u_0*v_3 - v_0*u_3 )/edge_lengths(2) + t(3) = v_0 + do l = 1, NUM_FACE_VERTICES + R_0(l) = sqrt(t(l)**2 + h**2) + end do + + ! Additional helping quantities + temp2 = rho - p_vec + + ! Calculate I^l_-1, I^l_1, and I^l_3 prior to assignment of X1, X2, and X3 + ! If R_0 = 0, do not calculate I_minus_1, but set it equal to zero + do l = 1, NUM_FACE_VERTICES + if (is_close(R_0(l), 0._wp)) then + I_l_minus_1(l) = 0._wp + I_l_plus_1(l) = 0.5_wp*(s_plus(l)*R_plus(l) - s_minus(l)*R_minus(l)) + else + I_l_minus_1(l) = line_intgr_solution(& + R_plus(l) , & + R_minus(l), & + s_plus(l) , & + s_minus(l)) + I_l_plus_1(l) = 0.5_wp*( & + R_0(l)**2*I_l_minus_1(l) + s_plus(l)*R_plus(l) - & + s_minus(l)*R_minus(l) ) + ! Variables for internal use ----------------------------------------------- + end if + if (isnan(I_l_minus_1(l))) then + print *, 'I_l_minus_1(l) is NaN: l, R_0', l, R_0(l) + end if + if (isnan(I_l_plus_1(l))) then + print *, 'I_l_plus_1(l) is NaN', l + end if + if (.not. X2_minus_only) then + I_l_plus_3(l) = 0.25_wp*( 3._wp*R_0(l)**2*I_l_plus_1(l) & + + s_plus(l)*R_plus(l)**3 - s_minus(l)*R_minus(l)**3 ) + end if + if (isnan(I_l_plus_3(l))) then + print *, 'I_l_plus_3(l) is NaN', l + end if + end do + ! Calculate I^S_-3, I^S_-1, and I^S_1 prior to assignment of X1, X2 and X3 + ! If h = 0 (i.e. is on the plane formed by the face) do not calculate + ! I_(q-2), but set it equal to zero. + if (is_close(h, 0._wp)) then + I_S_minus_3 = 0._wp + I_S_minus_1 = 0._wp + else + I_S_minus_3 = surface_intgr_solution(& + h , & + t , & + R_0 , & + R_plus , & + R_minus, & + s_plus , & + s_minus) + I_S_minus_1 = -h**2*I_S_minus_3 + if (isnan(I_S_minus_3)) then + print *, 'I_S_minus_3 is NaN' + end if + end if + do l = 1, NUM_FACE_VERTICES + I_S_minus_1 = I_S_minus_1 + t(l)*I_l_minus_1(l) + end do + if (isnan(I_S_minus_1)) then + print *, 'I_S_minus_1 is NaN' + stop 2 + end if + ! I^S_1 + if (.not. X2_minus_only) then + I_S_plus_1 = h**2*I_S_minus_1 + do l = 1, NUM_FACE_VERTICES + I_S_plus_1 = I_S_plus_1 + t(l)*I_l_plus_1(l) + end do + I_S_plus_1 = 1._wp/3._wp*I_S_plus_1 + end if + ! Other helping quantities + edge_unit_normal_sum = 0._wp + do l = 1, NUM_FACE_VERTICES + edge_unit_normal_sum = edge_unit_normal_sum & + + edge_unit_normals(l, :)*I_l_plus_1(l) + end do + + if (isnan(h)) then + print *, 'h is NaN' + end if + if (any(isnan(t))) then + print *, 't is NaN' + end if + if (any(isnan(R_0))) then + print *, 'R_0 is NaN' + end if + if (any(isnan(R_plus))) then + print *, 'R_plus is NaN' + end if + if (any(isnan(R_minus))) then + print *, 'R_minus is NaN' + end if + if (any(isnan(s_plus))) then + print *, 's_plus is NaN' + end if + if (any(isnan(s_minus))) then + print *, 's_minus is NaN' + end if + + !--------! + !-- X1 --! + !--------! + if (.not. X2_minus_only) then + hnX1_minus_3 = hn*I_S_minus_3 + X1_minus_1 = I_S_minus_1 + X1_plus_1 = I_S_plus_1 + end if + + !--------! + !-- X2 --! + !--------! + ! X2: 1/R + X2_minus_1 = I_S_minus_1*temp2 + edge_unit_normal_sum + ! X2: R + if (.not. X2_minus_only) then + X2_plus_1 = temp2*I_S_plus_1 + do l = 1, NUM_FACE_VERTICES + X2_plus_1 = X2_plus_1 + 1._wp/3._wp*edge_unit_normals(l, :)*I_l_plus_3(l) + end do + + !--------! + !-- X3 --! + !--------! + X3_minus_1 = -hn*I_S_minus_3 + do l = 1, NUM_FACE_VERTICES + X3_minus_1 = X3_minus_1 - edge_unit_normals(l, :)*I_l_minus_1(l) + end do + X3_plus_1 = edge_unit_normal_sum - hn*I_S_minus_1 + + !--------! + !-- X4 --! + !--------! + X4_minus_1 = -cross_prod_3D(temp3, X3_minus_1) + X4_plus_1 = -cross_prod_3D(temp3, X3_plus_1) + end if + + end subroutine inner_intgr_of_subtr_terms + + !!---------------------------------------------------------------------------- + + function surface_intgr_solution(& + h , & + t , & + R_0 , & + R_plus , & + R_minus, & + s_plus , & + s_minus) & + result(res) + real(wp) , intent(in) :: h + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: t + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: R_0 + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: R_plus + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: R_minus + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: s_plus + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: s_minus + real(wp) :: res + ! Variables for internal use ----------------------------------------------- + real(wp) :: abs_h + integer :: l + + abs_h = abs(h) + res = 0._wp + do l = 1, NUM_FACE_VERTICES + res = res + atan( t(l)*s_plus(l)/(R_0(l)**2 + abs_h*R_plus(l)) ) & + - atan( t(l)*s_minus(l)/(R_0(l)**2 + abs_h*R_minus(l)) ) + end do + res = res/abs_h + end function surface_intgr_solution + + !!---------------------------------------------------------------------------- + + function line_intgr_solution(& + R_plus , & + R_minus, & + s_plus , & + s_minus) & + result(res) + real(wp), intent(in) :: R_plus + real(wp), intent(in) :: R_minus + real(wp), intent(in) :: s_plus + real(wp), intent(in) :: s_minus + real(wp) :: res + ! Variables for internal use ----------------------------------------------- + real(wp) :: denom1 + real(wp) :: denom2 + denom1 = R_minus + s_minus + denom2 = R_plus - s_plus + ! For better numerical accuracy, use the denominator which has the greatest + ! absolute value + if (abs(denom1) >= abs(denom2)) then + res = log( (R_plus + s_plus)/denom1 ) + else + res = log( (R_minus - s_minus)/denom2 ) + end if + if (isnan(res)) then + print *, 'Error' + print *, 'res is NaN : R+, R-, s+, s-:', R_plus, R_minus, s_plus, s_minus + end if + end function line_intgr_solution + + !!---------------------------------------------------------------------------- + + function get_edge_lengths(& + this , & + face_idx) & + result(res) + class (PMCHW_RWG_type), intent(in) :: this + integer :: face_idx + real(wp), dimension(NUM_FACE_VERTICES) :: res + ! Variables for internal use ----------------------------------------------- + integer, dimension(NUM_FACE_VERTICES) :: face_edges + integer :: l + + face_edges = this%RWG_basis%mesh%get_edges_on_face(face_idx) + ! Edge length nr. l needs to be opposite to vertex nr. l + do l = 1, NUM_FACE_VERTICES + if (l == NUM_FACE_VERTICES) then + res(l) = this%RWG_basis%& + mesh%edge_length(face_edges(1)) + else + res(l) = this%RWG_basis%& + mesh%edge_length(face_edges(l + 1)) + end if + end do + end function get_edge_lengths + + !!---------------------------------------------------------------------------- + + Function calc_edge_unit_normals(& + edge_lengths , & + face_unit_normal, & + vertex1 , & + vertex2 , & + vertex3) & + result(res) + real(wp), dimension(NUM_FACE_VERTICES), intent(in) :: edge_lengths + real(wp), dimension(SPATIAL_DIM) , intent(in) :: face_unit_normal + real(wp), dimension(SPATIAL_DIM) , intent(in) :: vertex1 + real(wp), dimension(SPATIAL_DIM) , intent(in) :: vertex2 + real(wp), dimension(SPATIAL_DIM) , intent(in) :: vertex3 + real(wp), dimension(NUM_FACE_VERTICES, SPATIAL_DIM) :: res + ! Variables for internal use ----------------------------------------------- + + res(1, :) = cross_prod_3D(vertex3 - vertex2, & + face_unit_normal)/edge_lengths(1) + res(2, :) = cross_prod_3D(vertex1 - vertex3, & + face_unit_normal)/edge_lengths(2) + res(3, :) = cross_prod_3D(vertex2 - vertex1, & + face_unit_normal)/edge_lengths(3) + end function calc_edge_unit_normals + + !!---------------------------------------------------------------------------- + + function map_GLQF_pnt_to_triangle_edge(& + GLQF , & + edge1 , & + edge2 , & + edge3 , & + vertex1 , & + vertex2 , & + vertex3 , & + quad_pnt_nr, & + edge_idx) & + result(res) + real(wp), dimension(:, :) , intent(in) :: GLQF + real(wp), dimension(SPATIAL_DIM), intent(in) :: edge1 + real(wp), dimension(SPATIAL_DIM), intent(in) :: edge2 + real(wp), dimension(SPATIAL_DIM), intent(in) :: edge3 + real(wp), dimension(SPATIAL_DIM), intent(in) :: vertex1 + real(wp), dimension(SPATIAL_DIM), intent(in) :: vertex2 + real(wp), dimension(SPATIAL_DIM), intent(in) :: vertex3 + integer , intent(in) :: quad_pnt_nr + integer , intent(in) :: edge_idx + ! Variables to be returned ------------------------------------------------- + real(wp), dimension(SPATIAL_DIM) :: res + ! Variables for internal use ----------------------------------------------- + real(wp) :: variable_substitute + real(wp) :: mapping_factor + integer :: l + !__________________________________________________________________________! + !/\_/\_/\_/\_/\_/\_/\_/\_/\_/\__DOCSTRING__/\_/\_/\_/\_/\_/\_/\_/\_/\_/\_/\! + ! A Gauss-Legendre quadrature formula point is mapped from the interval + ! (-1, 1) onto a specified edge on a triangle. + ! Arguments: + ! GLQF - The Gauss-Legendre quadrature formula as a matrix + ! vertex1, vertex2, vertex3 - Cartesian coordinates to the vertices of + ! the triangle to be mapped to. + ! quad_pnt_nr - Index of the quadrature point to be mapped. + ! edge_idx - Index specifying which edge to map to. + ! Result: + ! Cartesian coordinates of the point mapped onto the triangle edge. + !__________________________________________________________________________! + variable_substitute = 0.5_wp*GLQF(quad_pnt_nr, GQF_LEGENDRE_POINT_IDX) + select case (edge_idx) + case (1) + res = variable_substitute*edge1 + 0.5_wp*(vertex3 + vertex2) + case (2) + res = variable_substitute*edge2 + 0.5_wp*(vertex1 + vertex3) + case (3) + res = variable_substitute*edge3 + 0.5_wp*(vertex2 + vertex1) + end select + + end function map_GLQF_pnt_to_triangle_edge + + !!---------------------------------------------------------------------------- + + function calc_green_func(wavenumber, kR, R_inv) result(res) + complex(wp), intent(in) :: wavenumber + complex(wp), intent(in) :: kR + real(wp) , intent(in) :: R_inv + complex(wp) :: res + + if (is_close(wavenumber%im, 0._wp)) then + res = cmplx(cos(kR%re), sin(kR%re)) + else + res = exp(I_IMAG*kR) + end if + res = res*R_inv*PI4_INV + end function calc_green_func + + !!---------------------------------------------------------------------------- + + function calc_grad_of_green_func(wavenumber, kR, R_inv, green_func) & + result(res) + complex(wp), intent(in) :: wavenumber + complex(wp), intent(in) :: kR + real(wp) , intent(in) :: R_inv + complex(wp), optional, intent(in) :: green_func + complex(wp) :: res + ! Variables for internal use ----------------------------------------------- + complex(wp) :: exponential + + if (present(green_func)) then + res = green_func*R_inv*(R_inv - I_IMAG*wavenumber) + else + if (is_close(wavenumber%im, 0._wp)) then + exponential = cmplx(cos(kR%re), sin(kR%re)) + else + exponential = exp(I_IMAG*kR) + end if + res = exponential*R_inv**2*PI4_INV*(R_inv - I_IMAG*wavenumber) + end if + end function calc_grad_of_green_func + + !!---------------------------------------------------------------------------- + + subroutine Cauchy_principal_value(& + green_func , & + grad_of_green_func, & + wavenumber , & + kR , & + R) + complex(wp), intent(inout) :: green_func + complex(wp), intent(inout) :: grad_of_green_func + complex(wp), intent(in) :: wavenumber + complex(wp), intent(in) :: kR + real(wp) , intent(in) :: R + ! Variables for internal use ----------------------------------------------- + real(wp) :: R_inv + + if (is_close(R, ZERO)) then +!!$ if (.true.) then + green_func = ZERO_CMPLX + grad_of_green_func = ZERO_CMPLX + else + R_inv = 1._wp/R + green_func = calc_green_func(wavenumber, kR, R_inv) + grad_of_green_func = calc_grad_of_green_func(& + wavenumber, & + kR , & + R_inv , & + green_func=green_func) + end if + end subroutine Cauchy_principal_value + + !!---------------------------------------------------------------------------- + + !=================================!==========================================! +end module PMCHW_RWG_mod diff --git a/MoM/RWG_basis_mod.f90 b/MoM/RWG_basis_mod.f90 new file mode 100644 index 00000000..262356d2 --- /dev/null +++ b/MoM/RWG_basis_mod.f90 @@ -0,0 +1,487 @@ +module RWG_basis_mod +!!============================================================================== +! This module defines the RWG basis type, which inherits the mesh_mod_type +! from mesh_mod.f90 and represents an RWG basis function mapping of a +! surface mesh. +! +! Abbreviations: +! CS - Closed Surface +! OS - Open Surface +! GQ - Gaussian Quadrature +! +! Last edited: March 7th 2021. +!!============================================================================== + + !!==============!! + ! Use statements ! + !================!============================================================ + use working_precision, only: wp + use iso_fortran_env , only: real64 + use mesh_mod , only: mesh_type + use math_funcs_mod , only: cross_prod_3D + use is_close_mod , only: is_close + use constants_mod , only: PI + use io_mod , only: r8mat_write + + implicit none + + !!===================!! + ! External procedures ! + !=====================!======================================================= + + + !!=================================!! + ! Public types/procedures/constants ! + !===================================!========================================= + public :: RWG_basis_type ! Main type + + ! Constants + integer, parameter, public :: SPATIAL_DIM = 3 + integer, parameter, public :: NUM_FACES_IN_BASIS = 2 + integer, parameter, public :: NUM_FACE_VERTICES = 3 + character(*), parameter, public :: MODULE_NAME = 'RWG_basis_mod' + + + !!==================================!! + ! Private types/procedures/constants ! + !====================================!======================================== + private + + !!------------------------!! + ! Derived type definitions ! + !--------------------------!-------------------------------------------------- + + + !!---------!! + ! Main type ! + !-----------!----------------------------------------------------------------- + type RWG_basis_type + type (mesh_type) :: mesh + integer :: num_bases + integer , dimension(:) , allocatable :: basis_edges + integer , dimension(:, :) , allocatable :: adjacent_faces + real(wp), dimension(:) , allocatable :: basis_edge_length + contains + ! Initialisers + procedure, pass(this), public :: initialise + ! Deallocation + procedure, pass(this), public :: deallocate_attributes + ! Get-functions + procedure, pass(this), public :: get_num_bases + procedure, pass(this), public :: get_free_vertices + procedure, pass(this), public :: get_basis_edge_coords + procedure, pass(this), public :: get_basis_edge_length + procedure, pass(this), public :: get_adjacent_faces + ! Calculations + procedure, pass(this), public :: integrate_tested_func + ! Validations + procedure, pass(this), public :: validate_current_direction + ! Write procedures + procedure, pass(this), public :: write_RWG_basis + + end type RWG_basis_type + + + !=======!=========================!==========================================! +contains ! /\/\/\/\/\/\/\/\/\/\/\/\!/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\! + !=======!=========================!==========================================! + + + !!==================================!! + ! RWG_basis_type internal procedures ! + !====================================!======================================== + !!------------!! + ! Initialisers ! + !--------------!-------------------------------------------------------------- + subroutine initialise(this, mesh) + class (RWG_basis_type), intent(inout) :: this + type (mesh_type), intent(in) :: mesh + ! Variables for internal use ----------------------------------------------- + character(:), allocatable :: msg + logical :: closed_surface + integer :: edge_order + integer :: num_face_vertices + integer :: num_handles + integer :: num_apertures + integer :: num_boundary_edges + integer :: num_faces + integer :: num_edges + integer :: num_vertices + integer :: num_bases + integer, dimension(2) :: adjacent_faces + integer :: boundary_edges_count + integer :: num_bases_created + integer :: edge_occurence + integer, dimension(3) :: vertices + real(wp) :: area + real(wp) :: length + integer :: error_nr + integer :: i + integer :: j + integer :: k + + call mesh%get_topology(& + num_handles , & + num_apertures , & + num_boundary_edges, & + num_faces , & + num_edges , & + num_vertices) + + edge_order = mesh%get_edge_order() + num_face_vertices = mesh%get_face_order() + if (num_face_vertices /= 3) then + print *, 'Error: RWG_basis_mod.f90: RWG_basis_type_:' + print *, ' RWG basis construction needs a triangulated surface.' + stop 1 + end if + num_bases = num_edges - num_boundary_edges + this%mesh = mesh + this%num_bases = num_bases + allocate(this%basis_edges(num_bases)) + allocate(this%basis_edge_length(num_bases)) + allocate(this%adjacent_faces(num_bases, 2)) + + ! Find basis edges and assign adjacent faces. + ! A boundary edge has only one adjacent face + boundary_edges_count = 0 + num_bases_created = 0 + do i = 1, num_edges + edge_occurence = 0 + do j = 1, num_faces + do k = 1, num_face_vertices + if (mesh%faces(j)%edges(k) == i) then + if (edge_occurence == 0) then + adjacent_faces(1) = j + edge_occurence = edge_occurence + 1 + else if (edge_occurence == 1) then + adjacent_faces(2) = j + edge_occurence = edge_occurence + 1 + end if + exit + end if + end do + if (edge_occurence == 2) then + exit + end if + end do + if (edge_occurence == 2) then + num_bases_created = num_bases_created + 1 + this%basis_edges(num_bases_created) = i + this%adjacent_faces(num_bases_created, :) & + = adjacent_faces + else if (edge_occurence == 1) then + boundary_edges_count = boundary_edges_count + 1 + else + print *, 'Error: RWG_basis_mod.f90: RWG_basis_type_:' + print *, ' Edge has no adjacent faces.' + print *, ' edge:', i + stop 1 + end if + end do + + if (boundary_edges_count /= num_boundary_edges) then + print *, 'Error: RWG_basis_mod.f90: RWG_basis_type_:' + print *, ' Counted boundary edges is not correct' + print *, ' Count:', boundary_edges_count + stop 1 + else if (num_bases_created /= num_bases) then + print *, 'Error: RWG_basis_mod.f90: RWG_basis_type_:' + print *, ' Created too few bases.' + print *, ' Count:', num_bases_created + stop 1 + end if + + ! Calculate basis constants + do i = 1, num_bases + length = this%mesh%edge_length(& + this%basis_edges(i)) + this%basis_edge_length(i) = length + end do + + ! Validate the orientation of the basis edges with the orientation of + ! the faces, i.e. validate the current orientation on the basis. + call this%validate_current_direction(error_nr) + if (error_nr /= 0) then + print *, error_nr + write (msg, "(A50, I2, A8)") 'Current direction validation basis nr. ' & + , error_nr, ' failed.' + print *, '' + print *, 'Error: ', MODULE_NAME, ': ', 'initialise', ':' + print *, ' ', msg + end if + + + end subroutine initialise + + !!---------------------------------------------------------------------------- + + subroutine deallocate_attributes(this) + class (RWG_basis_type), intent(inout) :: this + deallocate(this%basis_edges) + deallocate(this%basis_edge_length) + deallocate(this%adjacent_faces) + end subroutine deallocate_attributes + + + !!-------------!! + ! Get-functions ! + !---------------!------------------------------------------------------------- + function get_num_bases(this) result(return_value) + class (RWG_basis_type), intent(in) :: this + integer :: return_value + return_value = this%num_bases + end function get_num_bases + + !!---------------------------------------------------------------------------- + + function get_basis_edge_coords(this, basis_idx) result(return_value) + class (RWG_basis_type), intent(in) :: this + integer , intent(in) :: basis_idx + real(wp), dimension(2, this%mesh%spatial_dim) :: return_value + return_value = this%mesh%get_edge_coords(basis_idx) + end function get_basis_edge_coords + + !!---------------------------------------------------------------------------- + + function get_basis_edge_length(this, basis_idx) result(return_value) + class (RWG_basis_type), intent(in) :: this + integer :: basis_idx + real(wp) :: return_value + return_value = this%basis_edge_length(basis_idx) + end function get_basis_edge_length + + !!---------------------------------------------------------------------------- + function get_free_vertices(this, basis_idx) result(return_value) + class (RWG_basis_type), intent(in) :: this + integer , intent(in) :: basis_idx + integer, dimension(NUM_FACES_IN_BASIS) :: return_value + ! Variables for internal use ----------------------------------------------- + integer, dimension(NUM_FACE_VERTICES) :: face_vertices + integer :: i + integer :: j + + do i = 1, NUM_FACES_IN_BASIS + face_vertices = this%mesh%get_vertices_of_face(& + this%adjacent_faces(basis_idx, i)) + do j = 1, 3 + if (.not. any(this%mesh%edges(basis_idx)%vertices & + == face_vertices(j))) then + return_value(i) = face_vertices(j) + exit + end if + end do + end do + end function get_free_vertices + + !!---------------------------------------------------------------------------- + + function get_adjacent_faces(this, basis_idx) result(return_value) + class (RWG_basis_type), intent(in) :: this + integer :: basis_idx + integer, dimension(2) :: return_value + return_value = this%adjacent_faces(basis_idx, :) + end function get_adjacent_faces + + + !!-------------!! + ! Calculations ! + !---------------!------------------------------------------------------------- + function integrate_tested_func(this, gauss_quad_formula, func) & + result(res) + class (RWG_basis_type) , intent(in) :: this + real(wp), dimension(:, :), intent(in) :: gauss_quad_formula + interface + function func(pos_vec) result(func_value) + use working_precision, only: wp + implicit none + real(wp) , dimension(:), intent(in) :: pos_vec + complex(wp), dimension(:), allocatable :: func_value + end function func + end interface + real(wp), dimension(this%num_bases) :: res + ! Variables for internal use ----------------------------------------------- + real(wp), dimension(3, 3) :: triangle_coords + integer, dimension(2) :: free_vertices + real(wp), dimension(2, 3) :: free_vertices_coords + real(wp), dimension(3) :: r + real(wp) :: ksi + real(wp) :: eta + real(wp) :: zeta + real(wp) :: w + complex(wp), dimension(this%mesh%num_faces, 3) :: I_ksi + complex(wp), dimension(this%mesh%num_faces, 3) :: I_eta + complex(wp), dimension(this%mesh%num_faces, 3) :: I_zeta + complex(wp), dimension(this%mesh%num_faces, 3) :: I_ + integer :: m + integer :: i + integer :: p + integer :: q + + do p = 1, this%mesh%num_faces + triangle_coords = this%mesh%get_face_coords(p) + I_ksi(p, :) = cmplx(0._wp, 0._wp) + I_eta(p, :) = cmplx(0._wp, 0._wp) + I_(p, :) = cmplx(0._wp, 0._wp) + do i = 1, size(gauss_quad_formula, dim=1) + w = gauss_quad_formula(i, 1) + ksi = gauss_quad_formula(i, 2) + eta = gauss_quad_formula(i, 3) + zeta = gauss_quad_formula(i, 4) + r = ksi*triangle_coords(1, :) + eta*triangle_coords(2, :) & + + zeta*triangle_coords(3, :) + I_ksi(p, :) = I_ksi(p, :) + w*ksi*func(r) + I_eta(p, :) = I_eta(p, :) + w*eta*func(r) + I_(p, :) = I_(p, :) + w*func(r) + end do + I_zeta(p, :) = I_(p, :) - I_ksi(p, :) - I_eta(p, :) + end do + + do m = 1, this%num_bases + p = this%adjacent_faces(m, 1) + q = this%adjacent_faces(m, 2) + free_vertices = this%get_free_vertices(m) + free_vertices_coords(1, :) =this%mesh%get_vertex_coords(free_vertices(1)) + free_vertices_coords(2, :) =this%mesh%get_vertex_coords(free_vertices(2)) + triangle_coords = this%mesh%get_face_coords(p) + res(m) = & + + dot_product(triangle_coords(1, :), I_ksi(p, :)) & + + dot_product(triangle_coords(2, :), I_eta(p, :)) & + + dot_product(triangle_coords(3, :), I_zeta(p, :)) & + - dot_product(free_vertices_coords(1, :), I_(p, :)) + triangle_coords = this%mesh%get_face_coords(q) + res(m) = res(m) & + - dot_product(triangle_coords(1, :), I_ksi(q, :)) & + - dot_product(triangle_coords(2, :), I_eta(q, :)) & + - dot_product(triangle_coords(3, :), I_zeta(q, :)) & + + dot_product(free_vertices_coords(2, :), I_(q, :)) + res(m) = res(m)*this%basis_edge_length(m)/2._wp + end do + end function integrate_tested_func + + !!---------------------------------------------------------------------------- + + subroutine validate_current_direction(this, error_nr) + class (RWG_basis_type), intent(in) :: this + integer , intent(inout) :: error_nr + ! Variables for internal use ----------------------------------------------- + integer , dimension(NUM_FACE_VERTICES) :: face_vertices + integer , dimension(NUM_FACE_VERTICES) :: plus_face + integer , dimension(NUM_FACE_VERTICES) :: minus_face + integer , dimension(NUM_FACES_IN_BASIS) :: T_n + integer , dimension(NUM_FACES_IN_BASIS) :: edge_vertices + integer , dimension(NUM_FACES_IN_BASIS) :: free_vertices + integer :: plus_idx + integer :: minus_idx + integer :: n + integer :: p + integer :: i + + error_nr = 0 + do n = 1, this%num_bases + T_n = this%get_adjacent_faces(n) + free_vertices = this%get_free_vertices(n) + edge_vertices = this%mesh%get_vertices_of_edge(n) + plus_face = this%mesh%get_vertices_of_face(T_n(1)) + minus_face = this%mesh%get_vertices_of_face(T_n(2)) + + ! Check orientiation of plus face with respect to orientation of basis + ! edge + do i = 1, NUM_FACE_VERTICES + if (free_vertices(1) == plus_face(i)) then + plus_idx = i + end if + end do + select case (plus_idx) + case (1) + if ( .not. all(edge_vertices == [ plus_face(2), plus_face(3)& + ]) ) then + error_nr = n + end if + case (2) + if ( .not. all(edge_vertices == [ plus_face(3), plus_face(1)& + ]) ) then + error_nr = n + end if + case (3) + if ( .not. all(edge_vertices == [ plus_face(1), plus_face(2)& + ]) ) then + error_nr = n + end if + end select + ! Check orientiation of minus face with respect to orientation of basis + ! edge + do i = 1, NUM_FACE_VERTICES + if (free_vertices(2) == minus_face(i)) then + minus_idx = i + end if + end do + select case (minus_idx) + case (1) + if ( .not. all(edge_vertices == [ minus_face(3), minus_face(2)& + ]) ) then + error_nr = n + end if + case (2) + if ( .not. all(edge_vertices == [ minus_face(1), minus_face(3)& + ]) ) then + error_nr = n + end if + case (3) + if ( .not. all(edge_vertices == [ minus_face(2), minus_face(1)& + ]) ) then + error_nr = n + end if + end select + end do + + end subroutine validate_current_direction + + !!---------------------------------------------------------------------------- + + subroutine write_RWG_basis(this, filename) + class (RWG_basis_type), intent(in) :: this + character(len=*) , intent(in) :: filename + ! Variables for internal use ----------------------------------------------- + real(wp), dimension(:, :), allocatable :: table + real(wp), dimension(NUM_FACE_VERTICES, SPATIAL_DIM) :: plus_face_coords + real(wp), dimension(NUM_FACE_VERTICES, SPATIAL_DIM) :: minus_face_coords + real(wp), dimension(2, SPATIAL_DIM) :: edge_coords + real(wp), dimension(2, SPATIAL_DIM) :: edge_coors + integer , dimension(NUM_FACES_IN_BASIS) :: T_n + integer :: num_cols + integer :: n + integer :: j + integer :: k + + num_cols = 2*SPATIAL_DIM*NUM_FACE_VERTICES + SPATIAL_DIM*2 + allocate(table(this%num_bases, num_cols)) + do n = 1, this%num_bases + T_n = this%get_adjacent_faces(n) + plus_face_coords = this%mesh%get_face_coords(T_n(1)) + minus_face_coords = this%mesh%get_face_coords(T_n(2)) + edge_coords = this%mesh%get_edge_coords(n) + do j = 1, NUM_FACE_VERTICES + do k = 1, SPATIAL_DIM + table(n, (j - 1)*SPATIAL_DIM + k) = plus_face_coords(j, k) + table(n, (j - 1)*SPATIAL_DIM + k & + + SPATIAL_DIM*NUM_FACE_VERTICES) = minus_face_coords(j, k) + end do + end do + do j = 1, 2 + do k = 1, SPATIAL_DIM + table(n, (j - 1)*SPATIAL_DIM + 2*SPATIAL_DIM*NUM_FACE_VERTICES+k)& + = edge_coords(j, k) + end do + end do + end do + if (wp == real64) then + call r8mat_write(filename, this%num_bases, num_cols, table) + else + print *, 'No write routine for current precision.' + end if + end subroutine write_RWG_basis + + !=================================!==========================================! +end module RWG_basis_mod + diff --git a/MoM/constants_mod.f90 b/MoM/constants_mod.f90 new file mode 100644 index 00000000..f4487b5e --- /dev/null +++ b/MoM/constants_mod.f90 @@ -0,0 +1,64 @@ +module constants_mod +!!============================================================================== +! This module defines various mathematical constants +! +! +! Last edited: November 27th 2020. +!!============================================================================== + + !!==============!! + ! Use statements ! + !================!============================================================ + use working_precision, only: wp + + implicit none + + + !!=================================!! + ! Public types/procedures/constants ! + !===================================!========================================= + + ! Constants + complex(wp), parameter, public :: I_IMAG = cmplx(0._wp, 1._wp) + complex(wp), parameter, public :: ZERO_CMPLX = cmplx(0._wp, 0._wp) + real(wp) , parameter, public :: PERMEABILITY_VACUUM = 1.25663706212e-6_wp + real(wp) , parameter, public :: PERMITIVITY_VACUUM = 8.8541878128e-12_wp + real(wp) , parameter, public :: LIGHTSPEED_VACUUM = 299792458._wp + real(wp) , parameter, public :: PI = 4._wp*atan(1._wp) + real(wp) , parameter, public :: PI4_INV = 1._wp/(4._wp*PI) + real(wp) , parameter, public :: ZERO = 0._wp + real(wp) , parameter, public :: UNITY = 1._wp + + !!==================================!! + ! Private types/procedures/constants ! + !====================================!======================================== + private + + !!------------------------!! + ! Derived type definitions ! + !--------------------------!-------------------------------------------------- + + + !=======!=========================!==========================================! +contains ! /\/\/\/\/\/\/\/\/\/\/\/\!/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\! + !=======!=========================!==========================================! + + + !!=================!! + ! Public procedures ! + !===================!========================================================= + + + !!------------!! + ! Constructors ! + !--------------!-------------------------------------------------------------- + + + !!==================================!! + ! RWG_basis_type internal procedures ! + !====================================!======================================== + !!------------!! + ! Initialisers ! + !--------------!-------------------------------------------------------------- + +end module constants_mod diff --git a/MoM/gauss_quad_formulas_mod.f90 b/MoM/gauss_quad_formulas_mod.f90 new file mode 100644 index 00000000..6415e03e --- /dev/null +++ b/MoM/gauss_quad_formulas_mod.f90 @@ -0,0 +1,3059 @@ +module gauss_quad_formulas_mod +!!============================================================================== +! This module defines Gaussian quadrature formulas. +! +! An n-point formula for triangles is given as a nx4 dimensioned array on the +! format: +! +! weight_1 ksi_1 eta_1 zeta_1 +! weight_2 ksi_2 eta_2 zeta_2 +! . . . . +! . . . . +! . . . . +! weight_n ksi_n eta_n zeta_n +! +! Where ksi_i, eta_i, and zeta_i are normalised area coordinates. +! +! Abbreviations: +! GQ - Gaussian Quadrature +! GQF - Gaussian Quadrature Formula +! +! Last edited: November 9th 2020. +!!============================================================================== + + !!==============!! + ! Use statements ! + !================!============================================================ + use working_precision, only: wp + + implicit none + + + !!=================================!! + ! Public types/procedures/constants ! + !===================================!========================================= + + !----------------------------------------------------------------------------- + ! Lebedev quadrature for integrating functions over a unit sphere. + ! + ! Computes and returns a Lebedev angular grid including x, y, z coordinates + ! and weight w, given its order. + ! Input: (order). Output: (x(order), y(order), z(order), w(order)) + public :: ld_by_order + ! The following orders are available through the following routines + ! LD0006 computes the 6 point Lebedev angular grid. + ! LD0014 computes the 14 point Lebedev angular grid. + ! LD0026 computes the 26 point Lebedev angular grid. + ! LD0038 computes the 38 point Lebedev angular grid. + ! LD0050 computes the 50 point Lebedev angular grid. + ! LD0074 computes the 74 point Lebedev angular grid. + ! LD0086 computes the 86 point Lebedev angular grid. + ! LD0110 computes the 110 point Lebedev angular grid. + ! LD0146 computes the 146 point Lebedev angular grid. + ! LD0170 computes the 170 point Lebedev angular grid. + ! LD0194 computes the 194 point Lebedev angular grid. + ! LD0230 computes the 230 point Lebedev angular grid. + ! LD0266 computes the 266 point Lebedev angular grid. + ! LD0302 computes the 302 point Lebedev angular grid. + ! LD0350 computes the 350 point Lebedev angular grid. + ! LD0434 computes the 434 point Lebedev angular grid. + ! LD0590 computes the 590 point Lebedev angular grid. + ! LD0770 computes the 770 point Lebedev angular grid. + ! LD0974 computes the 974 point Lebedev angular grid. + + !----------------------------------------------------------------------------- + ! Gaussian quadrature formulas for triangles + real(wp), parameter, dimension(1, 4), public :: GQF_triangle_1pnt = & + transpose(reshape([& + ! Triangle. 1-point formula. Degree of precision 1 (?) + 1._wp, 1._wp/3._wp, 1._wp/3._wp, 1._wp/3._wp ], [4, 1])) + + real(wp), parameter, dimension(3, 4), public :: GQF_triangle_3pnt = & + transpose(reshape([& + ! Triangle. 3-point formula. Degree of precision 2 + 1._wp/3._wp, 2._wp/3._wp, 1._wp/6._wp, 1._wp/6._wp, & + 1._wp/3._wp, 1._wp/6._wp, 2._wp/3._wp, 1._wp/6._wp, & + 1._wp/3._wp, 1._wp/6._wp, 1._wp/6._wp, 2._wp/3._wp ], [4, 3])) + + real(wp), parameter, dimension(4, 4), public :: GQF_triangle_4pnt = & + transpose(reshape([& + ! Triangle. 4-point formula. Degree of precision 3 + -0.5625_wp, 1._wp/3._wp, 1._wp/3._wp, 1._wp/3._wp, & + 0.520833333333333_wp, 0.6_wp, 0.2_wp, 0.2_wp, & + 0.520833333333333_wp, 0.2_wp, 0.6_wp, 0.2_wp, & + 0.520833333333333_wp, 0.2_wp, 0.2_wp, 0.6_wp ], [4, 4])) + + real(wp), parameter, dimension(6, 4), public :: GQF_triangle_6pnt = & + transpose(reshape([& + ! Triangle. 6-point formula. Degree of precision 3 +1._wp/6._wp, 0.659027622374092_wp, 0.231933368553031_wp, 0.109039009072877_wp, & +1._wp/6._wp, 0.659027622374092_wp, 0.109039009072877_wp, 0.231933368553031_wp, & +1._wp/6._wp, 0.109039009072877_wp, 0.231933368553031_wp, 0.659027622374092_wp, & +1._wp/6._wp, 0.109039009072877_wp, 0.659027622374092_wp, 0.231933368553031_wp, & +1._wp/6._wp, 0.231933368553031_wp, 0.109039009072877_wp, 0.659027622374092_wp, & +1._wp/6._wp, 0.231933368553031_wp, 0.659027622374092_wp, 0.109039009072877_wp ] & + , [4, 6])) + + real(wp), parameter, dimension(7, 4), public :: GQF_triangle_7pnt = & + transpose(reshape([& + ! Triangle. 7-point formula. Degree of precision 4 + 0.375_wp , & ! Multiplicity 1 + 1._wp/3._wp , & + 1._wp/3._wp , & + 1._wp/3._wp , & + ! + ! + 0.104166666666667_wp, & ! 1/6 multiplicity + 0.736712498968435_wp, & + 0.237932366472434_wp, & + 0.025355134559132_wp, & + ! + 0.104166666666667_wp, & ! 2/6 multiplicity + 0.736712498968435_wp, & + 0.025355134559132_wp, & + 0.237932366472434_wp, & + ! + 0.104166666666667_wp, & ! 3/6 multiplicity + 0.025355134559132_wp, & + 0.237932366472434_wp, & + 0.736712498968435_wp, & + ! + 0.104166666666667_wp, & ! 4/6 multiplicity + 0.025355134559132_wp, & + 0.736712498968435_wp, & + 0.237932366472434_wp, & + ! + 0.104166666666667_wp, & ! 5/6 multiplicity + 0.237932366472434_wp, & + 0.736712498968435_wp, & + 0.025355134559132_wp, & + ! + 0.104166666666667_wp, & ! 6/6 multiplicity + 0.237932366472434_wp, & + 0.025355134559132_wp, & + 0.736712498968435_wp ], [4, 7])) + + real(wp), parameter, dimension(9, 4), public :: GQF_triangle_9pnt = & + transpose(reshape([& + ! Triangle. 9-point formula. Degree of precision 5 + 0.205950504760887_wp, & ! Multiplicity 3 + 0.124949503233232_wp, & + 0.437525248383384_wp, & + 0.437525248383384_wp, & + ! + 0.205950504760887_wp, & + 0.437525248383384_wp, & + 0.124949503233232_wp, & + 0.437525248383384_wp, & + ! + 0.205950504760887_wp, & + 0.437525248383384_wp, & + 0.437525248383384_wp, & + 0.124949503233232_wp, & + ! + ! + 0.063691414286223_wp, & ! Multiplicity 6 + 0.797112651860071_wp, & + 0.165409927389841_wp, & + 0.037477420750088_wp, & + ! + 0.063691414286223_wp, & + 0.797112651860071_wp, & + 0.037477420750088_wp, & + 0.165409927389841_wp, & + ! + 0.063691414286223_wp, & + 0.037477420750088_wp, & + 0.165409927389841_wp, & + 0.797112651860071_wp, & + ! + 0.063691414286223_wp, & + 0.037477420750088_wp, & + 0.797112651860071_wp, & + 0.165409927389841_wp, & + ! + 0.063691414286223_wp, & + 0.165409927389841_wp, & + 0.797112651860071_wp, & + 0.037477420750088_wp, & + ! + 0.063691414286223_wp, & + 0.165409927389841_wp, & + 0.037477420750088_wp, & + 0.797112651860071_wp ], [4, 9])) + + real(wp), parameter, dimension(12, 4), public :: GQF_triangle_12pnt = & + transpose(reshape([& + ! Triangle. 12-point formula. Degree of precision 6 + 0.050844906370207_wp, & ! Multiplicity 3 + 0.873821971016996_wp, & + 0.063089014491502_wp, & + 0.063089014491502_wp, & + ! + 0.050844906370207_wp, & + 0.063089014491502_wp, & + 0.873821971016996_wp, & + 0.063089014491502_wp, & + ! + 0.050844906370207_wp, & + 0.063089014491502_wp, & + 0.063089014491502_wp, & + 0.873821971016996_wp, & + ! + ! + 0.116786275726379_wp, & ! Multipliciy 3 + 0.501426509658179_wp, & + 0.249286745170910_wp, & + 0.249286745170911_wp, & + ! + 0.116786275726379_wp, & + 0.249286745170910_wp, & + 0.501426509658179_wp, & + 0.249286745170911_wp, & + ! + 0.116786275726379_wp, & + 0.249286745170910_wp, & + 0.249286745170911_wp, & + 0.501426509658179_wp, & + ! + ! + 0.082851075618374_wp, & ! Multiplicity 6 + 0.636502499121399_wp, & + 0.310352451033785_wp, & + 0.053145049844816_wp, & + ! + 0.082851075618374_wp, & + 0.636502499121399_wp, & + 0.053145049844816_wp, & + 0.310352451033785_wp, & + ! + 0.082851075618374_wp, & + 0.310352451033785_wp, & + 0.636502499121399_wp, & + 0.053145049844816_wp, & + ! + 0.082851075618374_wp, & + 0.310352451033785_wp, & + 0.053145049844816_wp, & + 0.636502499121399_wp, & + ! + 0.082851075618374_wp, & + 0.053145049844816_wp, & + 0.636502499121399_wp, & + 0.310352451033785_wp, & + ! + 0.082851075618374_wp, & + 0.053145049844816_wp, & + 0.310352451033785_wp, & + 0.636502499121399_wp ], [4, 12])) + + real(wp), parameter, dimension(13, 4), public :: GQF_triangle_13pnt = & + transpose(reshape([& + ! Triangle. 13-point formula. Degree of precision 7 + -0.149570044467670_wp, & ! Multiplicity 1 + 1._wp/3._wp , & + 1._wp/3._wp , & + 1._wp/3._wp , & + ! + ! + 0.175615257433204_wp, & ! Multiplicity 3 + 0.479308067841923_wp, & + 0.260345966079038_wp, & + 0.260345966079038_wp, & + ! + 0.175615257433204_wp, & + 0.260345966079038_wp, & + 0.479308067841923_wp, & + 0.260345966079038_wp, & + ! + 0.175615257433204_wp, & + 0.260345966079038_wp, & + 0.260345966079038_wp, & + 0.479308067841923_wp, & + ! + ! + 0.053347235608839_wp, & ! Multiplicity 3 + 0.869739794195568_wp, & + 0.065130102902216_wp, & + 0.065130102902216_wp, & + ! + 0.053347235608839_wp, & + 0.065130102902216_wp, & + 0.869739794195568_wp, & + 0.065130102902216_wp, & + ! + 0.053347235608839_wp, & + 0.065130102902216_wp, & + 0.065130102902216_wp, & + 0.869739794195568_wp, & + ! + ! + 0.077113760890257_wp, & ! Multiplicity 6 + 0.638444188569809_wp, & + 0.312865496004875_wp, & + 0.048690315425316_wp, & + ! + 0.077113760890257_wp, & + 0.638444188569809_wp, & + 0.048690315425316_wp, & + 0.312865496004875_wp, & + ! + 0.077113760890257_wp, & + 0.312865496004875_wp, & + 0.638444188569809_wp, & + 0.048690315425316_wp, & + ! + 0.077113760890257_wp, & + 0.312865496004875_wp, & + 0.048690315425316_wp, & + 0.638444188569809_wp, & + ! + 0.077113760890257_wp, & + 0.048690315425316_wp, & + 0.638444188569809_wp, & + 0.312865496004875_wp, & + ! + 0.077113760890257_wp, & + 0.048690315425316_wp, & + 0.312865496004875_wp, & + 0.638444188569809_wp ], [4, 13])) + +!!$ + ! 1-dimensional Gauss Legendre formulas + real(wp), parameter, dimension(1, 2), public :: GQF_Legendre_1pnt = & + transpose(reshape([& + 2._wp, 0._wp], [2, 1])) + real(wp), parameter, dimension(2, 2), public :: GQF_Legendre_2pnt = & + transpose(reshape([& + 1._wp, -1._wp/sqrt(3._wp), & + 1._wp, 1._wp/sqrt(3._wp) ], [2, 2])) + real(wp), parameter, dimension(3, 2), public :: GQF_Legendre_3pnt = & + transpose(reshape([& + 5._wp/9._wp, -sqrt(3._wp/5._wp), & + 8._wp/9._wp, 0._wp, & + 5._wp/9._wp, sqrt(3._wp/5._wp) ], [2, 3])) + real(wp), parameter, dimension(4, 2), public :: GQF_Legendre_4pnt = & + transpose(reshape([& + 0.3478548451374539_wp, -0.8611363115940526_wp, & + 0.6521451548625462_wp, -0.3399810435848563_wp, & + 0.6521451548625462_wp, 0.3399810435848563_wp, & + 0.3478548451374539_wp, 0.8611363115940526_wp ], [2, 4])) + real(wp), parameter, dimension(5, 2), public :: GQF_Legendre_5pnt = & + transpose(reshape([& + 0.23692688505618908_wp, -0.906179845938664_wp, & + 0.47862867049936647_wp, -0.538469310105683_wp, & + 0.5688888888888889_wp , 0._wp , & + 0.47862867049936647_wp, 0.538469310105683_wp, & + 0.23692688505618908_wp, 0.906179845938664_wp ], [2, 5])) + !=======!=========================!==========================================! +contains ! /\/\/\/\/\/\/\/\/\/\/\/\!/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\! + !=======!=========================!==========================================! + + subroutine gen_oh ( code, num, a, b, v, x, y, z, w ) + + !*************************************************************************** + ! + !! GEN_OH generates points under OH symmetry. + ! + ! Discussion: + ! + ! Given a point on a sphere, specified by A and B, this routine generates + ! all the equivalent points under OH symmetry, making grid points with + ! weight V. + ! + ! The variable NUM is increased by the number of different points + ! generated. + ! + ! Depending on CODE, there are from 6 to 48 different but equivalent + ! points that are generated: + ! + ! CODE=1: (0,0,1) etc ( 6 points) + ! CODE=2: (0,A,A) etc, A=1/sqrt(2) ( 12 points) + ! CODE=3: (A,A,A) etc, A=1/sqrt(3) ( 8 points) + ! CODE=4: (A,A,B) etc, B=sqrt(1-2 A^2) ( 24 points) + ! CODE=5: (A,B,0) etc, B=sqrt(1-A^2), A input ( 24 points) + ! CODE=6: (A,B,C) etc, C=sqrt(1-A^2-B^2), A, B input ( 48 points) + ! + ! Modified: + ! + ! 11 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) CODE, selects the symmetry group. + ! + ! Input/output, integer ( kind = 4 ) NUM, presumably a counter for the + ! total number of points. It is incremented by the number of points + ! generated on this call. + ! + ! Input, real ( kind = 8 ) A, B, information that may be needed to + ! generate the coordinates of the points (for code = 5 or 6 only). + ! + ! Input, real ( kind = 8 ) V, the weight to be assigned the points. + ! + ! Output, real ( kind = 8 ) X(NUM), Y(NUM), Z(NUM), W(NUM), the coordinates + ! and weights of the symmetric points generated on this call. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + real ( kind = 8 ) c + integer ( kind = 4 ) code + integer ( kind = 4 ) num + real ( kind = 8 ) v + real ( kind = 8 ) w(*) + real ( kind = 8 ) x(*) + real ( kind = 8 ) y(*) + real ( kind = 8 ) z(*) + + if ( code == 1 ) then + + a = 1.0D+000 + x(1) = a + y(1) = 0.0D+000 + z(1) = 0.0D+000 + w(1) = v + x(2) = -a + y(2) = 0.0D+000 + z(2) = 0.0D+000 + w(2) = v + x(3) = 0.0D+000 + y(3) = a + z(3) = 0.0D+000 + w(3) = v + x(4) = 0.0D+000 + y(4) = -a + z(4) = 0.0D+000 + w(4) = v + x(5) = 0.0D+000 + y(5) = 0.0D+000 + z(5) = a + w(5) = v + x(6) = 0.0D+000 + y(6) = 0.0D+000 + z(6) = -a + w(6) = v + num = num + 6 + + else if ( code == 2 ) then + + a = sqrt ( 0.5D+000 ) + x( 1) = 0.0D+000 + y( 1) = a + z( 1) = a + w( 1) = v + x( 2) = 0.0D+000 + y( 2) = -a + z( 2) = a + w( 2) = v + x( 3) = 0.0D+000 + y( 3) = a + z( 3) = -a + w( 3) = v + x( 4) = 0.0D+000 + y( 4) = -a + z( 4) = -a + w( 4) = v + x( 5) = a + y( 5) = 0.0D+000 + z( 5) = a + w( 5) = v + x( 6) = -a + y( 6) = 0.0D+000 + z( 6) = a + w( 6) = v + x( 7) = a + y( 7) = 0.0D+000 + z( 7) = -a + w( 7) = v + x( 8) = -a + y( 8) = 0.0D+000 + z( 8) = -a + w( 8) = v + x( 9) = a + y( 9) = a + z( 9) = 0.0D+000 + w( 9) = v + x(10) = -a + y(10) = a + z(10) = 0.0D+000 + w(10) = v + x(11) = a + y(11) = -a + z(11) = 0.0D+000 + w(11) = v + x(12) = -a + y(12) = -a + z(12) = 0.0D+000 + w(12) = v + num = num + 12 + + else if ( code == 3 ) then + + a = sqrt ( 1.0D+000 / 3.0D+000 ) + x(1) = a + y(1) = a + z(1) = a + w(1) = v + x(2) = -a + y(2) = a + z(2) = a + w(2) = v + x(3) = a + y(3) = -a + z(3) = a + w(3) = v + x(4) = -a + y(4) = -a + z(4) = a + w(4) = v + x(5) = a + y(5) = a + z(5) = -a + w(5) = v + x(6) = -a + y(6) = a + z(6) = -a + w(6) = v + x(7) = a + y(7) = -a + z(7) = -a + w(7) = v + x(8) = -a + y(8) = -a + z(8) = -a + w(8) = v + num = num + 8 + + else if ( code == 4 ) then + + b = sqrt ( 1.0D+000 - 2.0D+000 * a * a ) + x( 1) = a + y( 1) = a + z( 1) = b + w( 1) = v + x( 2) = -a + y( 2) = a + z( 2) = b + w( 2) = v + x( 3) = a + y( 3) = -a + z( 3) = b + w( 3) = v + x( 4) = -a + y( 4) = -a + z( 4) = b + w( 4) = v + x( 5) = a + y( 5) = a + z( 5) = -b + w( 5) = v + x( 6) = -a + y( 6) = a + z( 6) = -b + w( 6) = v + x( 7) = a + y( 7) = -a + z( 7) = -b + w( 7) = v + x( 8) = -a + y( 8) = -a + z( 8) = -b + w( 8) = v + x( 9) = a + y( 9) = b + z( 9) = a + w( 9) = v + x(10) = -a + y(10) = b + z(10) = a + w(10) = v + x(11) = a + y(11) = -b + z(11) = a + w(11) = v + x(12) = -a + y(12) = -b + z(12) = a + w(12) = v + x(13) = a + y(13) = b + z(13) = -a + w(13) = v + x(14) = -a + y(14) = b + z(14) = -a + w(14) = v + x(15) = a + y(15) = -b + z(15) = -a + w(15) = v + x(16) = -a + y(16) = -b + z(16) = -a + w(16) = v + x(17) = b + y(17) = a + z(17) = a + w(17) = v + x(18) = -b + y(18) = a + z(18) = a + w(18) = v + x(19) = b + y(19) = -a + z(19) = a + w(19) = v + x(20) = -b + y(20) = -a + z(20) = a + w(20) = v + x(21) = b + y(21) = a + z(21) = -a + w(21) = v + x(22) = -b + y(22) = a + z(22) = -a + w(22) = v + x(23) = b + y(23) = -a + z(23) = -a + w(23) = v + x(24) = -b + y(24) = -a + z(24) = -a + w(24) = v + num = num + 24 + + else if ( code == 5 ) then + + b = sqrt ( 1.0D+000 - a * a ) + x( 1) = a + y( 1) = b + z( 1) = 0.0D+000 + w( 1) = v + x( 2) = -a + y( 2) = b + z( 2) = 0.0D+000 + w( 2) = v + x( 3) = a + y( 3) = -b + z( 3) = 0.0D+000 + w( 3) = v + x( 4) = -a + y( 4) = -b + z( 4) = 0.0D+000 + w( 4) = v + x( 5) = b + y( 5) = a + z( 5) = 0.0D+000 + w( 5) = v + x( 6) = -b + y( 6) = a + z( 6) = 0.0D+000 + w( 6) = v + x( 7) = b + y( 7) = -a + z( 7) = 0.0D+000 + w( 7) = v + x( 8) = -b + y( 8) = -a + z( 8) = 0.0D+000 + w( 8) = v + x( 9) = a + y( 9) = 0.0D+000 + z( 9) = b + w( 9) = v + x(10) = -a + y(10) = 0.0D+000 + z(10) = b + w(10) = v + x(11) = a + y(11) = 0.0D+000 + z(11) = -b + w(11) = v + x(12) = -a + y(12) = 0.0D+000 + z(12) = -b + w(12) = v + x(13) = b + y(13) = 0.0D+000 + z(13) = a + w(13) = v + x(14) = -b + y(14) = 0.0D+000 + z(14) = a + w(14) = v + x(15) = b + y(15) = 0.0D+000 + z(15) = -a + w(15) = v + x(16) = -b + y(16) = 0.0D+000 + z(16) = -a + w(16) = v + x(17) = 0.0D+000 + y(17) = a + z(17) = b + w(17) = v + x(18) = 0.0D+000 + y(18) = -a + z(18) = b + w(18) = v + x(19) = 0.0D+000 + y(19) = a + z(19) = -b + w(19) = v + x(20) = 0.0D+000 + y(20) = -a + z(20) = -b + w(20) = v + x(21) = 0.0D+000 + y(21) = b + z(21) = a + w(21) = v + x(22) = 0.0D+000 + y(22) = -b + z(22) = a + w(22) = v + x(23) = 0.0D+000 + y(23) = b + z(23) = -a + w(23) = v + x(24) = 0.0D+000 + y(24) = -b + z(24) = -a + w(24) = v + num = num + 24 + + else if ( code == 6 ) then + + c = sqrt ( 1.0D+000 - a * a - b * b ) + x( 1) = a + y( 1) = b + z( 1) = c + w( 1) = v + x( 2) = -a + y( 2) = b + z( 2) = c + w( 2) = v + x( 3) = a + y( 3) = -b + z( 3) = c + w( 3) = v + x( 4) = -a + y( 4) = -b + z( 4) = c + w( 4) = v + x( 5) = a + y( 5) = b + z( 5) = -c + w( 5) = v + x( 6) = -a + y( 6) = b + z( 6) = -c + w( 6) = v + x( 7) = a + y( 7) = -b + z( 7) = -c + w( 7) = v + x( 8) = -a + y( 8) = -b + z( 8) = -c + w( 8) = v + x( 9) = a + y( 9) = c + z( 9) = b + w( 9) = v + x(10) = -a + y(10) = c + z(10) = b + w(10) = v + x(11) = a + y(11) = -c + z(11) = b + w(11) = v + x(12) = -a + y(12) = -c + z(12) = b + w(12) = v + x(13) = a + y(13) = c + z(13) = -b + w(13) = v + x(14) = -a + y(14) = c + z(14) = -b + w(14) = v + x(15) = a + y(15) = -c + z(15) = -b + w(15) = v + x(16) = -a + y(16) = -c + z(16) = -b + w(16) = v + x(17) = b + y(17) = a + z(17) = c + w(17) = v + x(18) = -b + y(18) = a + z(18) = c + w(18) = v + x(19) = b + y(19) = -a + z(19) = c + w(19) = v + x(20) = -b + y(20) = -a + z(20) = c + w(20) = v + x(21) = b + y(21) = a + z(21) = -c + w(21) = v + x(22) = -b + y(22) = a + z(22) = -c + w(22) = v + x(23) = b + y(23) = -a + z(23) = -c + w(23) = v + x(24) = -b + y(24) = -a + z(24) = -c + w(24) = v + x(25) = b + y(25) = c + z(25) = a + w(25) = v + x(26) = -b + y(26) = c + z(26) = a + w(26) = v + x(27) = b + y(27) = -c + z(27) = a + w(27) = v + x(28) = -b + y(28) = -c + z(28) = a + w(28) = v + x(29) = b + y(29) = c + z(29) = -a + w(29) = v + x(30) = -b + y(30) = c + z(30) = -a + w(30) = v + x(31) = b + y(31) = -c + z(31) = -a + w(31) = v + x(32) = -b + y(32) = -c + z(32) = -a + w(32) = v + x(33) = c + y(33) = a + z(33) = b + w(33) = v + x(34) = -c + y(34) = a + z(34) = b + w(34) = v + x(35) = c + y(35) = -a + z(35) = b + w(35) = v + x(36) = -c + y(36) = -a + z(36) = b + w(36) = v + x(37) = c + y(37) = a + z(37) = -b + w(37) = v + x(38) = -c + y(38) = a + z(38) = -b + w(38) = v + x(39) = c + y(39) = -a + z(39) = -b + w(39) = v + x(40) = -c + y(40) = -a + z(40) = -b + w(40) = v + x(41) = c + y(41) = b + z(41) = a + w(41) = v + x(42) = -c + y(42) = b + z(42) = a + w(42) = v + x(43) = c + y(43) = -b + z(43) = a + w(43) = v + x(44) = -c + y(44) = -b + z(44) = a + w(44) = v + x(45) = c + y(45) = b + z(45) = -a + w(45) = v + x(46) = -c + y(46) = b + z(46) = -a + w(46) = v + x(47) = c + y(47) = -b + z(47) = -a + w(47) = v + x(48) = -c + y(48) = -b + z(48) = -a + w(48) = v + num = num + 48 + + else + + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GEN_OH - Fatal error!' + write ( *, '(a)' ) ' Illegal value of CODE.' + stop + + end if + + return + end subroutine gen_oh + !----------------------------------------------------------------------------- + + subroutine ld_by_order ( order, x, y, z, w ) + + !*************************************************************************** + ! + !! LD_BY_ORDER returns a Lebedev angular grid given its order. + ! + ! Discussion: + ! + ! Only a certain set of such rules are available through this function. + ! + ! Modified: + ! + ! 13 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) ORDER, the order of the rule. + ! + ! Output, real ( kind = 8 ) X(ORDER), Y(ORDER), Z(ORDER), W(ORDER), + ! the coordinates and weights of the points. + ! + implicit none + + integer ( kind = 4 ) order + + real ( kind = 8 ) w(order) + real ( kind = 8 ) x(order) + real ( kind = 8 ) y(order) + real ( kind = 8 ) z(order) + + if ( order == 6 ) then + call ld0006 ( x, y, z, w ) + else if ( order == 14 ) then + call ld0014 ( x, y, z, w ) + else if ( order == 26 ) then + call ld0026 ( x, y, z, w ) + else if ( order == 38 ) then + call ld0038 ( x, y, z, w ) + else if ( order == 50 ) then + call ld0050 ( x, y, z, w ) + else if ( order == 74 ) then + call ld0074 ( x, y, z, w ) + else if ( order == 86 ) then + call ld0086 ( x, y, z, w ) + else if ( order == 110 ) then + call ld0110 ( x, y, z, w ) + else if ( order == 146 ) then + call ld0146 ( x, y, z, w ) + else if ( order == 170 ) then + call ld0170 ( x, y, z, w ) + else if ( order == 194 ) then + call ld0194 ( x, y, z, w ) + else if ( order == 230 ) then + call ld0230 ( x, y, z, w ) + else if ( order == 266 ) then + call ld0266 ( x, y, z, w ) + else if ( order == 302 ) then + call ld0302 ( x, y, z, w ) + else if ( order == 350 ) then + call ld0350 ( x, y, z, w ) + else if ( order == 434 ) then + call ld0434 ( x, y, z, w ) + else if ( order == 590 ) then + call ld0590 ( x, y, z, w ) + else if ( order == 770 ) then + call ld0770 ( x, y, z, w ) + else if ( order == 974 ) then + call ld0974 ( x, y, z, w ) + else if ( order == 5810 ) then + call ld5810 ( x, y, z, w ) + else + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'LD_BY_ORDER - Fatal error!' + write ( *, '(a)' ) ' Unexpected value of ORDER.' + stop + end if + + return + end subroutine ld_by_order + + !----------------------------------------------------------------------------- + + subroutine ld0006 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0006 computes the 6 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(6) + real ( kind = 8 ) x(6) + real ( kind = 8 ) y(6) + real ( kind = 8 ) z(6) + + n = 1 + v = 0.1666666666666667D+00 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0006 + + !----------------------------------------------------------------------------- + + subroutine ld0014 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0014 computes the 14 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(14) + real ( kind = 8 ) x(14) + real ( kind = 8 ) y(14) + real ( kind = 8 ) z(14) + + n = 1 + v = 0.6666666666666667D-01 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.7500000000000000D-01 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0014 + subroutine ld0026 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0026 computes the 26 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(26) + real ( kind = 8 ) x(26) + real ( kind = 8 ) y(26) + real ( kind = 8 ) z(26) + + n = 1 + v = 0.4761904761904762D-01 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.3809523809523810D-01 + call gen_oh ( 2, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.3214285714285714D-01 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0026 + + !----------------------------------------------------------------------------- + + subroutine ld0038 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0038 computes the 38 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(38) + real ( kind = 8 ) x(38) + real ( kind = 8 ) y(38) + real ( kind = 8 ) z(38) + + n = 1 + v = 0.9523809523809524D-02 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.3214285714285714D-01 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4597008433809831D+00 + v = 0.2857142857142857D-01 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0038 + + !----------------------------------------------------------------------------- + + subroutine ld0050 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0050 computes the 50 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(50) + real ( kind = 8 ) x(50) + real ( kind = 8 ) y(50) + real ( kind = 8 ) z(50) + + n = 1 + v = 0.1269841269841270D-01 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.2257495590828924D-01 + call gen_oh ( 2, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.2109375000000000D-01 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3015113445777636D+00 + v = 0.2017333553791887D-01 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0050 + + !----------------------------------------------------------------------------- + + subroutine ld0074 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0074 computes the 74 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(74) + real ( kind = 8 ) x(74) + real ( kind = 8 ) y(74) + real ( kind = 8 ) z(74) + + n = 1 + v = 0.5130671797338464D-03 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.1660406956574204D-01 + call gen_oh ( 2, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = -0.2958603896103896D-01 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4803844614152614D+00 + v = 0.2657620708215946D-01 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3207726489807764D+00 + v = 0.1652217099371571D-01 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0074 + + !----------------------------------------------------------------------------- + + subroutine ld0086 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0086 computes the 86 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(86) + real ( kind = 8 ) x(86) + real ( kind = 8 ) y(86) + real ( kind = 8 ) z(86) + + n = 1 + v = 0.1154401154401154D-01 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.1194390908585628D-01 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3696028464541502D+00 + v = 0.1111055571060340D-01 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6943540066026664D+00 + v = 0.1187650129453714D-01 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3742430390903412D+00 + v = 0.1181230374690448D-01 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0086 + + !----------------------------------------------------------------------------- + + subroutine ld0110 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0110 computes the 110 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(110) + real ( kind = 8 ) x(110) + real ( kind = 8 ) y(110) + real ( kind = 8 ) z(110) + + n = 1 + v = 0.3828270494937162D-02 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.9793737512487512D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1851156353447362D+00 + v = 0.8211737283191111D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6904210483822922D+00 + v = 0.9942814891178103D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3956894730559419D+00 + v = 0.9595471336070963D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4783690288121502D+00 + v = 0.9694996361663028D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0110 + + !----------------------------------------------------------------------------- + + subroutine ld0146 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0146 computes the 146 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(146) + real ( kind = 8 ) x(146) + real ( kind = 8 ) y(146) + real ( kind = 8 ) z(146) + + n = 1 + v = 0.5996313688621381D-03 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.7372999718620756D-02 + call gen_oh ( 2, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.7210515360144488D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6764410400114264D+00 + v = 0.7116355493117555D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4174961227965453D+00 + v = 0.6753829486314477D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1574676672039082D+00 + v = 0.7574394159054034D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1403553811713183D+00 + b = 0.4493328323269557D+00 + v = 0.6991087353303262D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0146 + + !----------------------------------------------------------------------------- + + subroutine ld0170 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0170 computes the 170 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(170) + real ( kind = 8 ) x(170) + real ( kind = 8 ) y(170) + real ( kind = 8 ) z(170) + + n = 1 + v = 0.5544842902037365D-02 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.6071332770670752D-02 + call gen_oh ( 2, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.6383674773515093D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2551252621114134D+00 + v = 0.5183387587747790D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6743601460362766D+00 + v = 0.6317929009813725D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4318910696719410D+00 + v = 0.6201670006589077D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2613931360335988D+00 + v = 0.5477143385137348D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4990453161796037D+00 + b = 0.1446630744325115D+00 + v = 0.5968383987681156D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0170 + + !----------------------------------------------------------------------------- + + subroutine ld0194 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0194 computes the 194 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(194) + real ( kind = 8 ) x(194) + real ( kind = 8 ) y(194) + real ( kind = 8 ) z(194) + + n = 1 + v = 0.1782340447244611D-02 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.5716905949977102D-02 + call gen_oh ( 2, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.5573383178848738D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6712973442695226D+00 + v = 0.5608704082587997D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2892465627575439D+00 + v = 0.5158237711805383D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4446933178717437D+00 + v = 0.5518771467273614D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1299335447650067D+00 + v = 0.4106777028169394D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3457702197611283D+00 + v = 0.5051846064614808D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1590417105383530D+00 + b = 0.8360360154824589D+00 + v = 0.5530248916233094D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0194 + + !----------------------------------------------------------------------------- + + subroutine ld0230 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0230 computes the 230 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(230) + real ( kind = 8 ) x(230) + real ( kind = 8 ) y(230) + real ( kind = 8 ) z(230) + + n = 1 + v = -0.5522639919727325D-01 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.4450274607445226D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4492044687397611D+00 + v = 0.4496841067921404D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2520419490210201D+00 + v = 0.5049153450478750D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6981906658447242D+00 + v = 0.3976408018051883D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6587405243460960D+00 + v = 0.4401400650381014D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4038544050097660D-01 + v = 0.1724544350544401D-01 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5823842309715585D+00 + v = 0.4231083095357343D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3545877390518688D+00 + v = 0.5198069864064399D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2272181808998187D+00 + b = 0.4864661535886647D+00 + v = 0.4695720972568883D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0230 + + !----------------------------------------------------------------------------- + + subroutine ld0266 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0266 computes the 266 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(266) + real ( kind = 8 ) x(266) + real ( kind = 8 ) y(266) + real ( kind = 8 ) z(266) + + n = 1 + v = -0.1313769127326952D-02 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = -0.2522728704859336D-02 + call gen_oh ( 2, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.4186853881700583D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7039373391585475D+00 + v = 0.5315167977810885D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1012526248572414D+00 + v = 0.4047142377086219D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4647448726420539D+00 + v = 0.4112482394406990D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3277420654971629D+00 + v = 0.3595584899758782D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6620338663699974D+00 + v = 0.4256131351428158D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.8506508083520399D+00 + v = 0.4229582700647240D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3233484542692899D+00 + b = 0.1153112011009701D+00 + v = 0.4080914225780505D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2314790158712601D+00 + b = 0.5244939240922365D+00 + v = 0.4071467593830964D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0266 + + !----------------------------------------------------------------------------- + + subroutine ld0302 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0302 computes the 302 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(302) + real ( kind = 8 ) x(302) + real ( kind = 8 ) y(302) + real ( kind = 8 ) z(302) + + n = 1 + v = 0.8545911725128148D-03 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.3599119285025571D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3515640345570105D+00 + v = 0.3449788424305883D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6566329410219612D+00 + v = 0.3604822601419882D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4729054132581005D+00 + v = 0.3576729661743367D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.9618308522614784D-01 + v = 0.2352101413689164D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2219645236294178D+00 + v = 0.3108953122413675D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7011766416089545D+00 + v = 0.3650045807677255D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2644152887060663D+00 + v = 0.2982344963171804D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5718955891878961D+00 + v = 0.3600820932216460D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2510034751770465D+00 + b = 0.8000727494073952D+00 + v = 0.3571540554273387D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1233548532583327D+00 + b = 0.4127724083168531D+00 + v = 0.3392312205006170D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0302 + + !----------------------------------------------------------------------------- + + subroutine ld0350 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0350 computes the 350 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(350) + real ( kind = 8 ) x(350) + real ( kind = 8 ) y(350) + real ( kind = 8 ) z(350) + + n = 1 + v = 0.3006796749453936D-02 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.3050627745650771D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7068965463912316D+00 + v = 0.1621104600288991D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4794682625712025D+00 + v = 0.3005701484901752D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1927533154878019D+00 + v = 0.2990992529653774D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6930357961327123D+00 + v = 0.2982170644107595D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3608302115520091D+00 + v = 0.2721564237310992D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6498486161496169D+00 + v = 0.3033513795811141D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1932945013230339D+00 + v = 0.3007949555218533D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3800494919899303D+00 + v = 0.2881964603055307D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2899558825499574D+00 + b = 0.7934537856582316D+00 + v = 0.2958357626535696D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.9684121455103957D-01 + b = 0.8280801506686862D+00 + v = 0.3036020026407088D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1833434647041659D+00 + b = 0.9074658265305127D+00 + v = 0.2832187403926303D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0350 + + !----------------------------------------------------------------------------- + + subroutine ld0434 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0434 computes the 434 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(434) + real ( kind = 8 ) x(434) + real ( kind = 8 ) y(434) + real ( kind = 8 ) z(434) + + n = 1 + v = 0.5265897968224436D-03 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.2548219972002607D-02 + call gen_oh ( 2, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.2512317418927307D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6909346307509111D+00 + v = 0.2530403801186355D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1774836054609158D+00 + v = 0.2014279020918528D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4914342637784746D+00 + v = 0.2501725168402936D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6456664707424256D+00 + v = 0.2513267174597564D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2861289010307638D+00 + v = 0.2302694782227416D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7568084367178018D-01 + v = 0.1462495621594614D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3927259763368002D+00 + v = 0.2445373437312980D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.8818132877794288D+00 + v = 0.2417442375638981D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.9776428111182649D+00 + v = 0.1910951282179532D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2054823696403044D+00 + b = 0.8689460322872412D+00 + v = 0.2416930044324775D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5905157048925271D+00 + b = 0.7999278543857286D+00 + v = 0.2512236854563495D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5550152361076807D+00 + b = 0.7717462626915901D+00 + v = 0.2496644054553086D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.9371809858553722D+00 + b = 0.3344363145343455D+00 + v = 0.2236607760437849D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0434 + + !----------------------------------------------------------------------------- + + subroutine ld0590 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0590 computes the 590 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(590) + real ( kind = 8 ) x(590) + real ( kind = 8 ) y(590) + real ( kind = 8 ) z(590) + + n = 1 + v = 0.3095121295306187D-03 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.1852379698597489D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7040954938227469D+00 + v = 0.1871790639277744D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6807744066455243D+00 + v = 0.1858812585438317D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6372546939258752D+00 + v = 0.1852028828296213D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5044419707800358D+00 + v = 0.1846715956151242D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4215761784010967D+00 + v = 0.1818471778162769D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3317920736472123D+00 + v = 0.1749564657281154D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2384736701421887D+00 + v = 0.1617210647254411D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1459036449157763D+00 + v = 0.1384737234851692D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6095034115507196D-01 + v = 0.9764331165051050D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6116843442009876D+00 + v = 0.1857161196774078D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3964755348199858D+00 + v = 0.1705153996395864D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1724782009907724D+00 + v = 0.1300321685886048D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5610263808622060D+00 + b = 0.3518280927733519D+00 + v = 0.1842866472905286D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4742392842551980D+00 + b = 0.2634716655937950D+00 + v = 0.1802658934377451D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5984126497885380D+00 + b = 0.1816640840360209D+00 + v = 0.1849830560443660D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3791035407695563D+00 + b = 0.1720795225656878D+00 + v = 0.1713904507106709D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2778673190586244D+00 + b = 0.8213021581932511D-01 + v = 0.1555213603396808D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5033564271075117D+00 + b = 0.8999205842074875D-01 + v = 0.1802239128008525D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0590 + + !----------------------------------------------------------------------------- + + subroutine ld0770 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0770 computes the 770 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(770) + real ( kind = 8 ) x(770) + real ( kind = 8 ) y(770) + real ( kind = 8 ) z(770) + + n = 1 + v = 0.2192942088181184D-03 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.1436433617319080D-02 + call gen_oh ( 2, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.1421940344335877D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5087204410502360D-01 + v = 0.6798123511050502D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1228198790178831D+00 + v = 0.9913184235294912D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2026890814408786D+00 + v = 0.1180207833238949D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2847745156464294D+00 + v = 0.1296599602080921D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3656719078978026D+00 + v = 0.1365871427428316D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4428264886713469D+00 + v = 0.1402988604775325D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5140619627249735D+00 + v = 0.1418645563595609D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6306401219166803D+00 + v = 0.1421376741851662D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6716883332022612D+00 + v = 0.1423996475490962D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6979792685336881D+00 + v = 0.1431554042178567D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1446865674195309D+00 + v = 0.9254401499865368D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3390263475411216D+00 + v = 0.1250239995053509D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5335804651263506D+00 + v = 0.1394365843329230D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6944024393349413D-01 + b = 0.2355187894242326D+00 + v = 0.1127089094671749D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2269004109529460D+00 + b = 0.4102182474045730D+00 + v = 0.1345753760910670D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.8025574607775339D-01 + b = 0.6214302417481605D+00 + v = 0.1424957283316783D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1467999527896572D+00 + b = 0.3245284345717394D+00 + v = 0.1261523341237750D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1571507769824727D+00 + b = 0.5224482189696630D+00 + v = 0.1392547106052696D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2365702993157246D+00 + b = 0.6017546634089558D+00 + v = 0.1418761677877656D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7714815866765732D-01 + b = 0.4346575516141163D+00 + v = 0.1338366684479554D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3062936666210730D+00 + b = 0.4908826589037616D+00 + v = 0.1393700862676131D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3822477379524787D+00 + b = 0.5648768149099500D+00 + v = 0.1415914757466932D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0770 + + !----------------------------------------------------------------------------- + + subroutine ld0974 ( x, y, z, w ) + + !*************************************************************************** + ! + !! LD0974 computes the 974 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(974) + real ( kind = 8 ) x(974) + real ( kind = 8 ) y(974) + real ( kind = 8 ) z(974) + + n = 1 + v = 0.1438294190527431D-03 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.1125772288287004D-02 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4292963545341347D-01 + v = 0.4948029341949241D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1051426854086404D+00 + v = 0.7357990109125470D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1750024867623087D+00 + v = 0.8889132771304384D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2477653379650257D+00 + v = 0.9888347838921435D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3206567123955957D+00 + v = 0.1053299681709471D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3916520749849983D+00 + v = 0.1092778807014578D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4590825874187624D+00 + v = 0.1114389394063227D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5214563888415861D+00 + v = 0.1123724788051555D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6253170244654199D+00 + v = 0.1125239325243814D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6637926744523170D+00 + v = 0.1126153271815905D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6910410398498301D+00 + v = 0.1130286931123841D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7052907007457760D+00 + v = 0.1134986534363955D-02 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1236686762657990D+00 + v = 0.6823367927109931D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2940777114468387D+00 + v = 0.9454158160447096D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4697753849207649D+00 + v = 0.1074429975385679D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6334563241139567D+00 + v = 0.1129300086569132D-02 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5974048614181342D-01 + b = 0.2029128752777523D+00 + v = 0.8436884500901954D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1375760408473636D+00 + b = 0.4602621942484054D+00 + v = 0.1075255720448885D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3391016526336286D+00 + b = 0.5030673999662036D+00 + v = 0.1108577236864462D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1271675191439820D+00 + b = 0.2817606422442134D+00 + v = 0.9566475323783357D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2693120740413512D+00 + b = 0.4331561291720157D+00 + v = 0.1080663250717391D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1419786452601918D+00 + b = 0.6256167358580814D+00 + v = 0.1126797131196295D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6709284600738255D-01 + b = 0.3798395216859157D+00 + v = 0.1022568715358061D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7057738183256172D-01 + b = 0.5517505421423520D+00 + v = 0.1108960267713108D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2783888477882155D+00 + b = 0.6029619156159187D+00 + v = 0.1122790653435766D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1979578938917407D+00 + b = 0.3589606329589096D+00 + v = 0.1032401847117460D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2087307061103274D+00 + b = 0.5348666438135476D+00 + v = 0.1107249382283854D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4055122137872836D+00 + b = 0.5674997546074373D+00 + v = 0.1121780048519972D-02 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld0974 + + !----------------------------------------------------------------------------- + + subroutine ld5810 ( x, y, z, w ) + + !*****************************************************************************80 + ! + !! LD5810 computes the 5810 point Lebedev angular grid. + ! + ! Modified: + ! + ! 09 September 2010 + ! + ! Author: + ! + ! Dmitri Laikov + ! + ! Reference: + ! + ! Vyacheslav Lebedev, Dmitri Laikov, + ! A quadrature formula for the sphere of the 131st + ! algebraic order of accuracy, + ! Russian Academy of Sciences Doklady Mathematics, + ! Volume 59, Number 3, 1999, pages 477-481. + ! + ! Parameters: + ! + ! Output, real ( kind = 8 ) X(N), Y(N), Z(N), W(N), the coordinates + ! and weights of the points. + ! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) b + integer ( kind = 4 ) n + real ( kind = 8 ) v + real ( kind = 8 ) w(5810) + real ( kind = 8 ) x(5810) + real ( kind = 8 ) y(5810) + real ( kind = 8 ) z(5810) + + n = 1 + v = 0.9735347946175486D-05 + call gen_oh ( 1, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.1907581241803167D-03 + call gen_oh ( 2, n, a, b, v, x(n), y(n), z(n), w(n) ) + v = 0.1901059546737578D-03 + call gen_oh ( 3, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1182361662400277D-01 + v = 0.3926424538919212D-04 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3062145009138958D-01 + v = 0.6667905467294382D-04 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5329794036834243D-01 + v = 0.8868891315019135D-04 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7848165532862220D-01 + v = 0.1066306000958872D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1054038157636201D+00 + v = 0.1214506743336128D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1335577797766211D+00 + v = 0.1338054681640871D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1625769955502252D+00 + v = 0.1441677023628504D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1921787193412792D+00 + v = 0.1528880200826557D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2221340534690548D+00 + v = 0.1602330623773609D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2522504912791132D+00 + v = 0.1664102653445244D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2823610860679697D+00 + v = 0.1715845854011323D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3123173966267560D+00 + v = 0.1758901000133069D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3419847036953789D+00 + v = 0.1794382485256736D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3712386456999758D+00 + v = 0.1823238106757407D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3999627649876828D+00 + v = 0.1846293252959976D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4280466458648093D+00 + v = 0.1864284079323098D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4553844360185711D+00 + v = 0.1877882694626914D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4818736094437834D+00 + v = 0.1887716321852025D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5074138709260629D+00 + v = 0.1894381638175673D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5319061304570707D+00 + v = 0.1898454899533629D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5552514978677286D+00 + v = 0.1900497929577815D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5981009025246183D+00 + v = 0.1900671501924092D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6173990192228116D+00 + v = 0.1899837555533510D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6351365239411131D+00 + v = 0.1899014113156229D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6512010228227200D+00 + v = 0.1898581257705106D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6654758363948120D+00 + v = 0.1898804756095753D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6778410414853370D+00 + v = 0.1899793610426402D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6881760887484110D+00 + v = 0.1901464554844117D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6963645267094598D+00 + v = 0.1903533246259542D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7023010617153579D+00 + v = 0.1905556158463228D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.7059004636628753D+00 + v = 0.1907037155663528D-03 + call gen_oh ( 4, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3552470312472575D-01 + v = 0.5992997844249967D-04 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.9151176620841283D-01 + v = 0.9749059382456978D-04 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1566197930068980D+00 + v = 0.1241680804599158D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2265467599271907D+00 + v = 0.1437626154299360D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2988242318581361D+00 + v = 0.1584200054793902D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3717482419703886D+00 + v = 0.1694436550982744D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4440094491758889D+00 + v = 0.1776617014018108D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5145337096756642D+00 + v = 0.1836132434440077D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5824053672860230D+00 + v = 0.1876494727075983D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6468283961043370D+00 + v = 0.1899906535336482D-03 + call gen_oh ( 5, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6095964259104373D-01 + b = 0.1787828275342931D-01 + v = 0.8143252820767350D-04 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.8811962270959388D-01 + b = 0.3953888740792096D-01 + v = 0.9998859890887728D-04 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1165936722428831D+00 + b = 0.6378121797722990D-01 + v = 0.1156199403068359D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1460232857031785D+00 + b = 0.8985890813745037D-01 + v = 0.1287632092635513D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1761197110181755D+00 + b = 0.1172606510576162D+00 + v = 0.1398378643365139D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2066471190463718D+00 + b = 0.1456102876970995D+00 + v = 0.1491876468417391D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2374076026328152D+00 + b = 0.1746153823011775D+00 + v = 0.1570855679175456D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2682305474337051D+00 + b = 0.2040383070295584D+00 + v = 0.1637483948103775D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2989653312142369D+00 + b = 0.2336788634003698D+00 + v = 0.1693500566632843D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3294762752772209D+00 + b = 0.2633632752654219D+00 + v = 0.1740322769393633D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3596390887276086D+00 + b = 0.2929369098051601D+00 + v = 0.1779126637278296D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3893383046398812D+00 + b = 0.3222592785275512D+00 + v = 0.1810908108835412D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4184653789358347D+00 + b = 0.3512004791195743D+00 + v = 0.1836529132600190D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4469172319076166D+00 + b = 0.3796385677684537D+00 + v = 0.1856752841777379D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4745950813276976D+00 + b = 0.4074575378263879D+00 + v = 0.1872270566606832D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5014034601410262D+00 + b = 0.4345456906027828D+00 + v = 0.1883722645591307D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5272493404551239D+00 + b = 0.4607942515205134D+00 + v = 0.1891714324525297D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5520413051846366D+00 + b = 0.4860961284181720D+00 + v = 0.1896827480450146D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5756887237503077D+00 + b = 0.5103447395342790D+00 + v = 0.1899628417059528D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1225039430588352D+00 + b = 0.2136455922655793D-01 + v = 0.1123301829001669D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1539113217321372D+00 + b = 0.4520926166137188D-01 + v = 0.1253698826711277D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1856213098637712D+00 + b = 0.7086468177864818D-01 + v = 0.1366266117678531D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2174998728035131D+00 + b = 0.9785239488772918D-01 + v = 0.1462736856106918D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2494128336938330D+00 + b = 0.1258106396267210D+00 + v = 0.1545076466685412D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2812321562143480D+00 + b = 0.1544529125047001D+00 + v = 0.1615096280814007D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3128372276456111D+00 + b = 0.1835433512202753D+00 + v = 0.1674366639741759D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3441145160177973D+00 + b = 0.2128813258619585D+00 + v = 0.1724225002437900D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3749567714853510D+00 + b = 0.2422913734880829D+00 + v = 0.1765810822987288D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4052621732015610D+00 + b = 0.2716163748391453D+00 + v = 0.1800104126010751D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4349335453522385D+00 + b = 0.3007127671240280D+00 + v = 0.1827960437331284D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4638776641524965D+00 + b = 0.3294470677216479D+00 + v = 0.1850140300716308D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4920046410462687D+00 + b = 0.3576932543699155D+00 + v = 0.1867333507394938D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5192273554861704D+00 + b = 0.3853307059757764D+00 + v = 0.1880178688638289D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5454609081136522D+00 + b = 0.4122425044452694D+00 + v = 0.1889278925654758D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5706220661424140D+00 + b = 0.4383139587781027D+00 + v = 0.1895213832507346D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5946286755181518D+00 + b = 0.4634312536300553D+00 + v = 0.1898548277397420D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.1905370790924295D+00 + b = 0.2371311537781979D-01 + v = 0.1349105935937341D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2242518717748009D+00 + b = 0.4917878059254806D-01 + v = 0.1444060068369326D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2577190808025936D+00 + b = 0.7595498960495142D-01 + v = 0.1526797390930008D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2908724534927187D+00 + b = 0.1036991083191100D+00 + v = 0.1598208771406474D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3236354020056219D+00 + b = 0.1321348584450234D+00 + v = 0.1659354368615331D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3559267359304543D+00 + b = 0.1610316571314789D+00 + v = 0.1711279910946440D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3876637123676956D+00 + b = 0.1901912080395707D+00 + v = 0.1754952725601440D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4187636705218842D+00 + b = 0.2194384950137950D+00 + v = 0.1791247850802529D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4491449019883107D+00 + b = 0.2486155334763858D+00 + v = 0.1820954300877716D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4787270932425445D+00 + b = 0.2775768931812335D+00 + v = 0.1844788524548449D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5074315153055574D+00 + b = 0.3061863786591120D+00 + v = 0.1863409481706220D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5351810507738336D+00 + b = 0.3343144718152556D+00 + v = 0.1877433008795068D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5619001025975381D+00 + b = 0.3618362729028427D+00 + v = 0.1887444543705232D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5875144035268046D+00 + b = 0.3886297583620408D+00 + v = 0.1894009829375006D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6119507308734495D+00 + b = 0.4145742277792031D+00 + v = 0.1897683345035198D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2619733870119463D+00 + b = 0.2540047186389353D-01 + v = 0.1517327037467653D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.2968149743237949D+00 + b = 0.5208107018543989D-01 + v = 0.1587740557483543D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3310451504860488D+00 + b = 0.7971828470885599D-01 + v = 0.1649093382274097D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3646215567376676D+00 + b = 0.1080465999177927D+00 + v = 0.1701915216193265D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3974916785279360D+00 + b = 0.1368413849366629D+00 + v = 0.1746847753144065D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4295967403772029D+00 + b = 0.1659073184763559D+00 + v = 0.1784555512007570D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4608742854473447D+00 + b = 0.1950703730454614D+00 + v = 0.1815687562112174D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4912598858949903D+00 + b = 0.2241721144376724D+00 + v = 0.1840864370663302D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5206882758945558D+00 + b = 0.2530655255406489D+00 + v = 0.1860676785390006D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5490940914019819D+00 + b = 0.2816118409731066D+00 + v = 0.1875690583743703D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5764123302025542D+00 + b = 0.3096780504593238D+00 + v = 0.1886453236347225D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6025786004213506D+00 + b = 0.3371348366394987D+00 + v = 0.1893501123329645D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6275291964794956D+00 + b = 0.3638547827694396D+00 + v = 0.1897366184519868D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3348189479861771D+00 + b = 0.2664841935537443D-01 + v = 0.1643908815152736D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.3699515545855295D+00 + b = 0.5424000066843495D-01 + v = 0.1696300350907768D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4042003071474669D+00 + b = 0.8251992715430854D-01 + v = 0.1741553103844483D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4375320100182624D+00 + b = 0.1112695182483710D+00 + v = 0.1780015282386092D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4699054490335947D+00 + b = 0.1402964116467816D+00 + v = 0.1812116787077125D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5012739879431952D+00 + b = 0.1694275117584291D+00 + v = 0.1838323158085421D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5315874883754966D+00 + b = 0.1985038235312689D+00 + v = 0.1859113119837737D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5607937109622117D+00 + b = 0.2273765660020893D+00 + v = 0.1874969220221698D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5888393223495521D+00 + b = 0.2559041492849764D+00 + v = 0.1886375612681076D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6156705979160163D+00 + b = 0.2839497251976899D+00 + v = 0.1893819575809276D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6412338809078123D+00 + b = 0.3113791060500690D+00 + v = 0.1897794748256767D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4076051259257167D+00 + b = 0.2757792290858463D-01 + v = 0.1738963926584846D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4423788125791520D+00 + b = 0.5584136834984293D-01 + v = 0.1777442359873466D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4760480917328258D+00 + b = 0.8457772087727143D-01 + v = 0.1810010815068719D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5085838725946297D+00 + b = 0.1135975846359248D+00 + v = 0.1836920318248129D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5399513637391218D+00 + b = 0.1427286904765053D+00 + v = 0.1858489473214328D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5701118433636380D+00 + b = 0.1718112740057635D+00 + v = 0.1875079342496592D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5990240530606021D+00 + b = 0.2006944855985351D+00 + v = 0.1887080239102310D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6266452685139695D+00 + b = 0.2292335090598907D+00 + v = 0.1894905752176822D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6529320971415942D+00 + b = 0.2572871512353714D+00 + v = 0.1898991061200695D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.4791583834610126D+00 + b = 0.2826094197735932D-01 + v = 0.1809065016458791D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5130373952796940D+00 + b = 0.5699871359683649D-01 + v = 0.1836297121596799D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5456252429628476D+00 + b = 0.8602712528554394D-01 + v = 0.1858426916241869D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5768956329682385D+00 + b = 0.1151748137221281D+00 + v = 0.1875654101134641D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6068186944699046D+00 + b = 0.1442811654136362D+00 + v = 0.1888240751833503D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6353622248024907D+00 + b = 0.1731930321657680D+00 + v = 0.1896497383866979D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6624927035731797D+00 + b = 0.2017619958756061D+00 + v = 0.1900775530219121D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5484933508028488D+00 + b = 0.2874219755907391D-01 + v = 0.1858525041478814D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.5810207682142106D+00 + b = 0.5778312123713695D-01 + v = 0.1876248690077947D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6120955197181352D+00 + b = 0.8695262371439526D-01 + v = 0.1889404439064607D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6416944284294319D+00 + b = 0.1160893767057166D+00 + v = 0.1898168539265290D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6697926391731260D+00 + b = 0.1450378826743251D+00 + v = 0.1902779940661772D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6147594390585488D+00 + b = 0.2904957622341456D-01 + v = 0.1890125641731815D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6455390026356783D+00 + b = 0.5823809152617197D-01 + v = 0.1899434637795751D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6747258588365477D+00 + b = 0.8740384899884715D-01 + v = 0.1904520856831751D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + a = 0.6772135750395347D+00 + b = 0.2919946135808105D-01 + v = 0.1905534498734563D-03 + call gen_oh ( 6, n, a, b, v, x(n), y(n), z(n), w(n) ) + n = n - 1 + + return + end subroutine ld5810 + + !----------------------------------------------------------------------------- + +end module gauss_quad_formulas_mod diff --git a/MoM/io_mod.f90 b/MoM/io_mod.f90 new file mode 100644 index 00000000..9c007db8 --- /dev/null +++ b/MoM/io_mod.f90 @@ -0,0 +1,908 @@ +module io_mod +!!============================================================================== +! This module contains I/O procedures, and has a procedure +! specifically designed to read Gmsh2 files. To be used together with mesh_mod. +! +! Last edited: March 7th 2021. +!!============================================================================== + + !!==============!! + ! Use statements ! + !================!============================================================ + use working_precision, only: wp + use iso_fortran_env , only: IOSTAT_END + use iso_fortran_env , only: ERROR_UNIT + use ieee_arithmetic , only: ieee_is_finite + use ieee_arithmetic , only: ieee_is_nan + + implicit none + + + !!=================================!! + ! Public types/procedures/constants ! + !===================================!========================================= + public :: open_read_gmsh2 + public :: string_to_int4 + public :: string_to_real_wp + public :: read_nth_int4 + public :: read_n_last_int4 + public :: read_n_last_real_wp + public :: count_int4_on_string + public :: count_real_wp_on_string + public :: capitalise_char + ! Procedures by John Burkardt for writing tables to file + public :: r8mat_write + public :: get_unit + + !!==================================!! + ! Private types/procedures/constants ! + !====================================!======================================== + private :: check_ioerr_opening + private :: check_ioerr_reading + + + !=======!=========================!==========================================! +contains ! /\/\/\/\/\/\/\/\/\/\/\/\!/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\! + !=======!=========================!==========================================! + + + !!=================!! + ! Public procedures ! + !===================!========================================================= + + !!-------------------------------------------!! + ! Specific file format open and read routines ! + !---------------------------------------------!------------------------------- + subroutine open_read_gmsh2(FILENAME, spatial_dim, element_order, nodes, & + elements) + character(len=*) , intent(in) :: FILENAME + integer , intent(in) :: spatial_dim + integer , intent(in) :: element_order + real(wp), dimension(:, :), allocatable, intent(out) :: nodes + integer , dimension(:, :), allocatable, intent(out) :: elements + ! Variables for internal use ---------------------------------------------- + integer , parameter :: BUFFER_LEN = 255 + integer, parameter :: IOMSG_LEN = 255 + character(len=BUFFER_LEN) :: line + character(len=IOMSG_LEN) :: iotxt + integer :: line_nr + integer :: num_nodes + integer :: num_elements + integer :: num_elements_tot + integer :: element_line_start + integer :: element_line_end + integer :: unit_nr + integer :: level + integer :: int4_value + real(wp) :: real_wp_value + integer :: length + integer :: ioerr + integer :: error_state + integer :: i, j, k + !__________________________________________________________________________! + !/\_/\_/\_/\_/\_/\_/\_/\_/\_/\__DOCSTRING__/\_/\_/\_/\_/\_/\_/\_/\_/\_/\_/\! + ! This routine loads a Gmsh2 ASCII file given by a file name, the spatial + ! order of the mesh, and the element order. It reads the file line by line + ! and succesively progresses through levels, which are activated by + ! keywords in the .msh-file. + ! + ! Arguments: + ! FILENAME - The path to the .msh + ! spatial dim - The spatial order of the mesh + ! element order - The order of the elements in the mesh. + ! Result: + ! nodes - A matrix contain the nodes of the mesh and their Cartesian + ! coordinates. + ! elements - A matrix containing the elements of the mesh, defined by + ! the indices of the nodes it comprises. + !__________________________________________________________________________! + + open (newunit=unit_nr, file=FILENAME, status='old', action='read', & + iostat=ioerr, iomsg=iotxt) + call check_ioerr_opening(ioerr, iotxt, IOMSG_LEN, FILENAME, 1, 'reading') + + ! Read file and interpret line by line + level = 0 + num_elements = 0 + line_nr = 0 + do + length = 1 + line_nr = line_nr + 1 + + read (unit_nr, '(a)', iostat=ioerr, iomsg=iotxt) line + if (ioerr /= 0) then + call check_ioerr_reading(ioerr, iotxt, IOMSG_LEN, FILENAME, 3) + exit + end if + ! Read nodes + if (level == 0) then + if (line(1:6) == '$Nodes') then + level = 1 + end if + else if (level == 1) then + call string_to_int4(line, length, int4_value, error_state) + num_nodes = int4_value + allocate(nodes(num_nodes, spatial_dim)) + j = 0 + level = 2 + else if (level == 2) then + if (line(1:9) == '$EndNodes') then + level = 3 + else + j = j + 1 + call read_n_last_real_wp(line, spatial_dim, nodes(j, :), & + num_real_wp_in=(spatial_dim + 1)) + end if + + ! Read elements + else if (level == 3) then + if (line(1:9) == '$Elements') then + level = 4 + end if + else if (level == 4) then + call string_to_int4(line, length, int4_value, error_state) + num_elements_tot = int4_value + level = 5 + else if (level == 5) then + int4_value = read_nth_int4(line, 2) + if (int4_value == 2) then + element_line_start = line_nr + num_elements = 1 + level = 6 + end if + else if (level == 6) then + if (line(1:12) == '$EndElements') then + level = 7 + rewind(unit_nr) + else + int4_value = read_nth_int4(line, 2) + if (int4_value /= 2) then + level = 7 + rewind(unit_nr) + end if + end if + if (level == 6) then + num_elements = num_elements + 1 + end if + else if (level == 7) then + allocate(elements(num_elements, element_order)) + level = 8 + j = 0 + element_line_end = line_nr - 1 + line_nr = 1 + else if (level == 8) then + if (line(1:12) == '$EndElements') then + exit + else if (j == num_elements) then + exit + else if (line_nr == element_line_end) then + exit + else if (line_nr >= element_line_start) then + j = j + 1 + call read_n_last_int4(line, element_order, elements(j, :)) + end if + end if + end do + + close (unit_nr) + + call validate_nodes_and_elements(spatial_dim, element_order, num_nodes, & + num_elements, nodes, elements) + + end subroutine open_read_gmsh2 + + + !!-----------------------------------------!! + ! Routines converting strings to data types ! + !-------------------------------------------!--------------------------------- + subroutine string_to_int4(text, length, int4_value, error_state) + character(len=*), intent(in) :: text + integer , intent(inout) :: length + integer , intent(inout) :: int4_value + integer , intent(inout) :: error_state + ! Variables for internal use ----------------------------------------------- + character(len=1) :: ch + logical :: terminate + integer :: state + integer :: int4_sign + integer :: char_start + integer :: char_end + integer :: i + + state = 1 + terminate = .false. + int4_sign = 1 + + do i = 1, len_trim(text) + ch = text(i:i) + ! Blank + if (ch == ' ') then + if (state > 1) then + terminate = .true. + end if + ! Plus or minus sign + else if (ch == '+' .or. ch == '-') then + if (state == 1) then + state = 2 + char_start = i + else + terminate = .true. + end if + ! Digit + else if (lle ('0', ch) .and. lle (ch, '9')) then + if (state == 1) then + char_start = i + end if + state = 3 + char_end = i + ! Terminate on anything else + else + terminate = .true. + end if + + if (terminate) then + exit + end if + end do + + length = i - 1 + ! Number seems to have terminated. Have we got a legal number? + ! Not if we terminated right after a sign character or without + ! reading a single digit. I.e. not if we terminated in + ! states 1 or 2 + if (state == 1 .or. state == 2) then + error_state = state + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'STRING_TO_INT4 - Serious error!' + write ( *, '(a)' ) ' Illegal or nonnumeric input:' + write ( *, '(a)' ) ' ' // trim (text) + end if + ! Determine value + read(text(char_start:char_end), '(I10)') int4_value + + end subroutine string_to_int4 + + !------------------------------------------------------------------------------ + + subroutine string_to_real_wp(text, length, value_of_real, error_state) + character(len=*), intent(in) :: text + integer , intent(inout) :: length + real(wp) , intent(inout) :: value_of_real + integer , intent(inout) :: error_state + ! Variables for internal use ----------------------------------------------- + character(len=1) :: ch + logical :: terminate + integer :: state + integer :: sign_of_base + integer :: sign_of_exponent + real(wp) :: base_top + real(wp) :: base_bot + integer :: exponent_top + integer :: exponent_bot + real(wp) :: exponential_value + integer :: i + integer :: digit + + state = 1 + terminate = .false. + sign_of_base = 1 + sign_of_exponent = 1 + base_top = 0._wp + base_bot = 1._wp + exponent_top = 0 + exponent_bot = 1 + error_state = 0 + + do i = 1, len_trim(text) + ch = text(i:i) + ! The following code is a modification of code written by + ! John Burkardt in 2000. + !------------------------------------------------------------------------ + ! + ! Blanck character + if (ch == ' ') then + if (state == 2) then + else if (state == 6 .or. state == 7) then + terminate = .true. + else if (state > 1) then + state = 11 + end if + ! + ! Comma + else if (ch == ',' .or. ch == ';') then + if (state /= 1) then ! If read characters other than blanks. + terminate = .true. + state = 12 + !i = i + 1 ! Why increment? + end if + ! + ! Minus sign + else if (ch == '-') then + if (state == 1) then ! If first non-blank character. + state = 2 + sign_of_base = -1 + else if (state == 6) then + state = 7 + sign_of_exponent = -1 + else + terminate = .true. + end if + ! + ! Pluss sign + else if (ch == '+') then + if (state == 1) then ! If first non-blank character. + state = 2 + sign_of_base = 1 + else if (state == 6) then + state = 7 + sign_of_exponent = 1 + else + terminate = .true. + end if + ! + ! Decimal point + else if (ch == '.') then + if (state < 4) then + state = 4 + else if (state >= 6 .and. state <= 8) then + state = 9 + else + terminate = .true. + end if + ! + ! Scientific notation exponent marker. + else if (capitalise_char(ch) == 'E' .or. capitalise_char(ch) == 'D') then + if (state < 6) then + state = 6 + else + terminate = .true. + end if + ! + ! Digit + else if (state < 11 .and. lle('0', ch) .and. lle(ch, '9')) then + if (state <= 2) then ! If first digit + state = 3 + else if (state == 4) then ! If first digit after decimal point + state = 5 + else if (state == 6 .or. state == 7) then ! If first digit after + ! exponent marker + state = 8 + else if (state == 9) then ! If decimal point after exponent marker + state = 10 + end if + + read(ch, '(I10)') digit + + if (state == 3) then + base_top = 10._wp * base_top + real(digit, wp) + else if (state == 5) then + base_top = 10._wp * base_top + real(digit, wp) + base_bot = 10._wp * base_bot + else if (state == 8) then + exponent_top = 10*exponent_top + digit + else if (state == 10) then + exponent_top = 10*exponent_top + digit + exponent_bot = 10*exponent_bot + end if + ! + ! Termninate on anything else + else + terminate = .true. + end if + if (terminate) then + exit + end if + end do + + length = i - 1 + ! + ! Number seems to have terminated. Have we got a legal number? + ! Not if we terminated right after a sign character, scientific + ! marker, or without reading a single digit. I.e. not if we + ! terminated in states 1, 2, 6 or 7! + ! + if ( state == 1 .or. state == 2 .or. state == 6 .or. state == 7 ) then + error_state = state + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'STRING_TO_REAL_WP - Serious error!' + write ( *, '(a)' ) ' Illegal or nonnumeric input:' + write ( *, '(a)' ) ' ' // trim (text) + end if + ! + ! Number OK. Form it. + if ( exponent_top == 0 ) then ! if non-scientific form + exponential_value = 1._wp + else + if ( exponent_bot == 1 ) then + exponential_value = 10._wp**(sign_of_exponent*exponent_top) + else + exponential_value = 10._wp**(real(sign_of_exponent*exponent_top, wp) & + /real(exponent_bot, wp)) + end if + end if + + value_of_real = real(sign_of_base, wp)*exponential_value*base_top/base_bot + + end subroutine string_to_real_wp + + !----------------------------------------------------------------------------- + + function count_int4_on_string(input_text) result(return_value) + character(len=*), intent(in) :: input_text + integer :: return_value + ! Variables for internal use ----------------------------------------------- + integer :: int4_value + character(len=255) :: text + integer :: length + integer :: i + integer :: error_state + + error_state = 0 + text = trim(input_text) + length = 1 + i = 0 + ! Count total number of data int4 on string + do + ! For optimalisation, a different, more efficient routine may be + ! constructed + call string_to_int4(text, length, int4_value, error_state) + if (error_state /= 0) then + exit + end if + i = i + 1 + if (length == len_trim(text)) then + exit + end if + text = text(length + 1:) + end do + return_value = i + end function count_int4_on_string + + !----------------------------------------------------------------------------- + + function count_real_wp_on_string(input_text) result(return_value) + character(len=*) , intent(in) :: input_text + integer :: return_value + ! Variables for internal use ----------------------------------------------- + real(wp) :: real_wp_value + character(len=255) :: text + integer :: length + integer :: i + integer :: error_state + + error_state = 0 + text = trim(input_text) + length = 1 + i = 0 + ! Count total number of data int4 on string + do + ! For optimalisation, a different, more efficient routine may be + ! constructed + call string_to_real_wp(text, length, real_wp_value, error_state) + if (error_state /= 0) then + exit + end if + i = i + 1 + if (length == len_trim(text)) then + exit + end if + text = text(length + 1:) + end do + return_value = i + end function count_real_wp_on_string + + !------------------------------------------------------------------------------ + + function read_nth_int4(input_text, nth) result(return_value) + character(len=*), intent(in) :: input_text + integer , intent(in) :: nth + integer :: return_value + ! Variables for internal use ----------------------------------------------- + integer :: int4_value + character(len=255) :: text + integer :: length + integer :: i + integer :: error_state + + error_state = 0 + text = trim(input_text) + length = 1 + do i = 1, nth + call string_to_int4(text, length, int4_value, error_state) + if (error_state /= 0) then + exit + end if + text = text(length + 1:) + end do + return_value = int4_value + end function read_nth_int4 + + !------------------------------------------------------------------------------ + + subroutine read_n_last_int4(input_text, n, n_last_int4, num_int4_in) + character(len=*) , intent(in) :: input_text + integer , intent(in) :: n + integer, optional , intent(in) :: num_int4_in + integer, dimension(n) , intent(inout) :: n_last_int4 + ! Variables for internal use ----------------------------------------------- + integer, dimension(:), allocatable :: all_int4 + integer :: num_int4 + integer :: int4_value + character(len=255) :: text + integer :: length + integer :: i + integer :: error_state + + error_state = 0 + text = trim(input_text) + if (.not. present(num_int4_in)) then + num_int4 = count_int4_on_string(text) + else + num_int4 = num_int4_in + end if + + if (num_int4 < n) then + print *, 'READ_N_LAST_INT4 - Error:' + print *, ' String has too few int4.' + print *, ' n = ', n, 'num_data_int4 = ', num_int4 + stop 1 + end if + allocate(all_int4(num_int4)) + + ! Read again, but save int4 + text = input_text + length = 1 + do i = 1, num_int4 + call string_to_int4(text, length, int4_value, error_state) + all_int4(i) = int4_value + if (error_state /= 0) then + exit + end if + text = text(length + 1:) + end do + + n_last_int4 = all_int4(num_int4 - n + 1:) + + end subroutine read_n_last_int4 + + !----------------------------------------------------------------------------- + + subroutine read_n_last_real_wp(input_text, n, n_last_real_wp, num_real_wp_in) + character(len=*) , intent(in) :: input_text + integer , intent(in) :: n + integer, optional , intent(in) :: num_real_wp_in + real(wp), dimension(n) , intent(inout) :: n_last_real_wp + ! Variables for internal use ----------------------------------------------- + real(wp), dimension(:), allocatable :: all_real_wp + integer :: num_real_wp + real(wp) :: real_wp_value + character(len=255) :: text + integer :: length + integer :: i + integer :: error_state + + error_state = 0 + text = trim(input_text) + length = 1 + if (present(num_real_wp_in)) then + num_real_wp = num_real_wp_in + else + num_real_wp = count_real_wp_on_string(text) + end if + + if (num_real_wp < n) then + print *, 'READ_N_LAST_REAL_WP - Error:' + print *, ' String has too few real_wp.' + print *, ' n = ', n, 'num_data_real_wp = ', num_real_wp + stop 1 + end if + allocate(all_real_wp(num_real_wp)) + + ! Read again, but save real_wp + text = input_text + length = 1 + do i = 1, num_real_wp + call string_to_real_wp(text, length, real_wp_value, error_state) + all_real_wp(i) = real_wp_value + if (error_state /= 0) then + exit + end if + text = text(length + 1:) + end do + + n_last_real_wp = all_real_wp(num_real_wp - n + 1:) + + end subroutine read_n_last_real_wp + + + !!===================! + ! Private procedures ! + !====================!========================================================= + + !!--------------!! + ! Error handling ! + !----------------!------------------------------------------------------------- + subroutine check_ioerr_opening(ioerr, iotxt, IOMSG_LEN, FILENAME, & + stop_unit, action) + integer , intent(in) :: ioerr, stop_unit + integer , intent(in) :: IOMSG_LEN + character(len=IOMSG_LEN), intent(in) :: iotxt + character(len=*) , intent(in) :: FILENAME, action + + if (ioerr /= 0) then + write (ERROR_UNIT, *) 'Problem while opening for ', & + action, ': ', FILENAME + write (ERROR_UNIT, *) 'Message : ', trim (iotxt) + stop stop_unit + end if + end subroutine check_ioerr_opening + + + subroutine check_ioerr_reading(ioerr, iotxt, IOMSG_LEN, FILENAME, stop_unit) + integer , intent(in) :: ioerr, stop_unit + integer , intent(in) :: IOMSG_LEN + character(len=IOMSG_LEN), intent(in) :: iotxt + character(len=*) , intent(in) :: FILENAME + + if (ioerr /= IOSTAT_END) then + write (ERROR_UNIT, *) 'Problem while reading: ', FILENAME + write (ERROR_UNIT, *) 'Message : ', trim (iotxt) + stop stop_unit + end if + end subroutine check_ioerr_reading + + + subroutine validate_nodes_and_elements(spatial_dim, element_order, num_nodes,& + num_elements, nodes, elements) + integer , intent(in) :: spatial_dim + integer , intent(in) :: element_order + integer , intent(in) :: num_nodes + integer , intent(in) :: num_elements + real(wp), dimension(num_nodes, spatial_dim) , intent(in) :: nodes + integer , dimension(num_elements, spatial_dim), intent(in) :: elements + ! Variables for internal use ----------------------------------------------- + integer :: i + integer :: j + integer :: k + +!!$ print *, '' +!!$ write (*, fmt="(a)", advance="no") & +!!$ ' Validating nodes and elements... ' + + do i = 1, num_nodes + do j = 1, spatial_dim + if (ieee_is_nan(nodes(i, j))) then + print *, '' + print *, 'Error: Node coordinate is NAN..' + print *, ' i: ', i, 'j: ', j + stop 1 + else if (.not. ieee_is_finite(nodes(i, j))) then + print *, '' + print *, 'Error: Node coordinate is infinite..' + print *, ' i: ', i, 'j: ', j + stop 1 + end if + end do + do k = 1, num_nodes + if (k /= i .and. all(nodes(k, :) == nodes(i, :))) then + print *, '' + print *, 'Error: Two identical nodes..' + print *, ' i: ', i, 'k: ', k + stop 1 + end if + end do + end do + + do i = 1, num_elements + do j = 1, element_order + if (elements(i, j) < 1) then + print *, '' + print *, 'Error: Node-index is less than 1..' + print *, ' i: ', i, 'j: ', j + stop 1 + else if (elements(i, j) > size(nodes, dim=1)) then + print *, '' + print *, 'Error: Node-index is larger than number of nodes..' + print *, ' i: ', i, 'j: ', j + stop 1 + end if + do k = 1, element_order + if (j /= k) then + if (elements(i, j) == elements(i, k)) then + print *, '' + print *, 'Error: Element has two equal vertices.' + print *, ' i: ', i, 'j: ', j + stop 1 + end if + end if + end do + end do + do k = 1, num_elements + if (k /= i .and. all(elements(k, :) == elements(i, :))) then + print *, '' + print *, 'Error: Two identical elements..' + print *, ' i: ', i, 'k: ', k + print *, elements(i, :) + print *, elements(k, :) + stop 1 + end if + end do + end do + + end subroutine validate_nodes_and_elements + + + !!----------------!! + ! Other procedures ! + !------------------!---------------------------------------------------------- + function capitalise_char(ch) result(return_value) + character, intent(in) :: ch + character :: return_value + integer :: ascii_code + ascii_code = iachar(ch) + if (ascii_code >= 97 .and. ascii_code <= 122) then + return_value = achar(ascii_code - 32) + else + return_value = ch + end if + end function capitalise_char + + + !!------------------------!! + ! Writing matrices to file ! + !--------------------------!-------------------------------------------------- + subroutine r8mat_write ( output_filename, m, n, table ) + !*************************************************************************80 + ! + !! R8MAT_WRITE writes an R8MAT file. + ! + ! Discussion: + ! + ! An R8MAT is an array of R8 values. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 31 May 2009 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Input, character ( len = * ) OUTPUT_FILENAME, the output file name. + ! + ! Input, integer ( kind = 4 ) M, the spatial dimension. + ! + ! Input, integer ( kind = 4 ) N, the number of points. + ! + ! Input, real ( kind = 8 ) TABLE(M,N), the data. + ! + implicit none + + integer ( kind = 4 ) m + integer ( kind = 4 ) n + + integer ( kind = 4 ) j + character ( len = * ) output_filename + integer ( kind = 4 ) output_status + integer ( kind = 4 ) output_unit + character ( len = 30 ) string + real ( kind = 8 ) table(m,n) + ! + ! Open the file. + ! + call get_unit ( output_unit ) + + open ( unit = output_unit, file = output_filename, & + status = 'replace', iostat = output_status ) + + if ( output_status /= 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'R8MAT_WRITE - Fatal error!' + write ( *, '(a,i8)' ) ' Could not open the output file "' // & + trim ( output_filename ) // '" on unit ', output_unit + output_unit = -1 + stop 1 + end if + ! + ! Create a format string. + ! + ! For less precision in the output file, try: + ! + ! & + ! '(', m, 'g', 14, '.', 6, ')' + ! + if ( 0 < m .and. 0 < n ) then + + write ( string, '(a1,i8,a1,i8,a1,i8,a1)' ) & + '(', n, 'g', 24, '.', 16, ')' + ! + ! Write the data. + ! + do j = 1, m + write ( output_unit, string ) table(j, 1:n) + end do + + end if + ! + ! Close the file. + ! + close ( unit = output_unit ) + + return + end subroutine r8mat_write + + !!---------------------------------------------------------------------------- + + subroutine get_unit ( iunit ) + !*************************************************************************80 + ! + !! GET_UNIT returns a free FORTRAN unit number. + ! + ! Discussion: + ! + ! A "free" FORTRAN unit number is a value between 1 and 99 which + ! is not currently associated with an I/O device. A free FORTRAN unit + ! number is needed in order to open a file with the OPEN command. + ! + ! If IUNIT = 0, then no free FORTRAN unit could be found, although + ! all 99 units were checked (except for units 5, 6 and 9, which + ! are commonly reserved for console I/O). + ! + ! Otherwise, IUNIT is a value between 1 and 99, representing a + ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 + ! are special, and will never return those values. + ! + ! Licensing: + ! + ! This code is distributed under the GNU LGPL license. + ! + ! Modified: + ! + ! 26 October 2008 + ! + ! Author: + ! + ! John Burkardt + ! + ! Parameters: + ! + ! Output, integer ( kind = 4 ) IUNIT, the free unit number. + ! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) ios + integer ( kind = 4 ) iunit + logical ( kind = 4 ) lopen + + iunit = 0 + + do i = 1, 99 + + if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then + + inquire ( unit = i, opened = lopen, iostat = ios ) + + if ( ios == 0 ) then + if ( .not. lopen ) then + iunit = i + return + end if + end if + + end if + + end do + + return + end subroutine get_unit + + !!---------------------------------------------------------------------------- + +end module io_mod diff --git a/MoM/is_close_mod.f90 b/MoM/is_close_mod.f90 new file mode 100644 index 00000000..27fdface --- /dev/null +++ b/MoM/is_close_mod.f90 @@ -0,0 +1,106 @@ +module is_close_mod +!!============================================================================== +! This module defines the is_close funcion useful for comparing real numbers. +! +! +! Last edited: November 25th 2020. +!!============================================================================== + + !!==============!! + ! Use statements ! + !================!============================================================ + use working_precision, only: wp + use ieee_arithmetic , only: ieee_is_nan + use ieee_arithmetic , only: ieee_is_finite + implicit none + + + !!=================================!! + ! Public types/procedures/constants ! + !===================================!========================================= + public :: is_close + + + !!=====================!! + ! Procedure definitions ! + !=======================!===================================================== + + !=======!=========================!==========================================! +contains ! /\/\/\/\/\/\/\/\/\/\/\/\!/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\! + !=======!=========================!==========================================! + + + elemental function is_close(actual, desired, rtol, atol, equal_nan)& + result(return_value) + ! The following code is snipped from: + ! https://scivision.github.io/fortran2018-examples/sourcefile/ + ! assert.f90.html + !!-------------------------------------------------------------------------- + ! inputs + ! ------ + ! actual: value "measured" + ! desired: value "wanted" + ! rtol: relative tolerance + ! atol: absolute tolerance + ! equal_nan: consider NaN to be equal? + ! + ! rtol overrides atol when both are specified + ! + ! https://www.python.org/dev/peps/pep-0485/#proposed-implementation + ! https://github.com/PythonCHB/close_pep/blob/master/is_close.py + + real(wp), intent(in) :: actual + real(wp), intent(in) :: desired + real(wp), intent(in), optional :: rtol + real(wp), intent(in), optional :: atol + logical , intent(in), optional :: equal_nan + logical :: return_value + ! Variables for internal use ----------------------------------------------- + real(wp) :: r + real(wp) :: a + logical :: n + real(wp) :: zero_margin + real(wp) :: adjustment + + ! this is appropriate INSTEAD OF merge(), since non present values aren't + ! defined. + r = 1e-5_wp + a = 1.e4_wp*epsilon(0._wp) ! 1.e3 + n = .false. + if (present(rtol)) r = rtol + if (present(atol)) a = atol + if (present(equal_nan)) n = equal_nan + + zero_margin = 0.1_wp + adjustment = 0._wp + + !--- Check if desired and actual is close to zero. Added by E. S. Oyre +!!$ if ((abs(desired) < zero_margin) .and. (abs(actual) < zero_margin)) then +!!$ adjustment = zero_margin +!!$ end if + !--- sanity check + if ((r < 0._wp).or.(a < 0._wp)) error stop + !--- simplest case + return_value = (actual == desired) + if (return_value) return + !--- equal nan + return_value = n.and.(ieee_is_nan(actual).and.ieee_is_nan(desired)) + if (return_value) return + !--- Inf /= -Inf, unequal NaN + if (.not.ieee_is_finite(actual) .or. .not.ieee_is_finite(desired)) return + !--- floating point closeness check +!!$ return_value = abs(actual-desired) <= max(r * max(abs(actual + adjustment),& +!!$ abs(desired + adjustment)), a) + return_value = abs(actual-desired) <= max(r * max(abs(actual),& + abs(desired)), a) + !!-------------------------------------------------------------------------- + + end function is_close + + + +!!------------------------------------------------------------------------------ +end module is_close_mod + + + diff --git a/MoM/math_funcs_mod.f90 b/MoM/math_funcs_mod.f90 new file mode 100644 index 00000000..83d60362 --- /dev/null +++ b/MoM/math_funcs_mod.f90 @@ -0,0 +1,159 @@ +module math_funcs_mod +!!============================================================================== +! This module defines various mathematical functions +! +! +! Last edited: November 9th 2020. +!!============================================================================== + + !!==============!! + ! Use statements ! + !================!============================================================ + use working_precision, only: wp + use constants_mod , only: I_IMAG + use constants_mod , only: ZERO + use is_close_mod , only: is_close + + implicit none + + + !!=================================!! + ! Public types/procedures/constants ! + !===================================!========================================= + public :: cross_prod_3D + public :: cross_prod_3D_cmplx + public :: standard_basis + public :: scale_with_1 + public :: first_component + public :: plane_wave + + !!==================================!! + ! Private types/procedures/constants ! + !====================================!======================================== + private + + !!------------------------!! + ! Derived type definitions ! + !--------------------------!-------------------------------------------------- + + + !!---------!! + ! Main type ! + !-----------!----------------------------------------------------------------- + + !=======!=========================!==========================================! +contains ! /\/\/\/\/\/\/\/\/\/\/\/\!/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\! + !=======!=========================!==========================================! + + + !!=================!! + ! Public procedures ! + !===================!========================================================= + + function cross_prod_3D(a, b) result(return_value) + ! Computes the cross product a x b, for a, b in R^3 + real(wp), dimension(3) :: a + real(wp), dimension(3) :: b + real(wp), dimension(3) :: return_value + return_value(1) = a(2)*b(3) - a(3)*b(2) + return_value(2) = a(3)*b(1) - a(1)*b(3) + return_value(3) = a(1)*b(2) - a(2)*b(1) + end function cross_prod_3D + + !!---------------------------------------------------------------------------- + + function cross_prod_3D_cmplx(a, b) result(return_value) + ! Computes the cross product a x b, for a, b in R^3 + complex(wp), dimension(3) :: a + complex(wp), dimension(3) :: b + complex(wp), dimension(3) :: return_value + return_value(1) = a(2)*b(3) - a(3)*b(2) + return_value(2) = a(3)*b(1) - a(1)*b(3) + return_value(3) = a(1)*b(2) - a(2)*b(1) + end function cross_prod_3D_cmplx + + !----------------------------------------------------------------------------- + + function standard_basis(vector) result(return_value) + real(wp), dimension(:), intent(in) :: vector + complex(wp), dimension(:), allocatable :: return_value + integer :: i + allocate(return_value(size(vector))) + do i = 1, size(vector) + return_value(:) = cmplx(1._wp, 0._wp) + end do + end function standard_basis + + !!---------------------------------------------------------------------------- + + function scale_with_1(vector) result(return_value) + real(wp), dimension(:), intent(in) :: vector + complex(wp), dimension(:), allocatable :: return_value + integer :: i + allocate(return_value(size(vector))) + do i = 1, size(vector) + return_value(i) = cmplx(vector(i), 0._wp) + end do + end function scale_with_1 + + !!---------------------------------------------------------------------------- + + function first_component(vector) result(return_value) + real(wp), dimension(:), intent(in) :: vector + complex(wp), dimension(:), allocatable :: return_value + integer :: i + allocate(return_value(size(vector))) + return_value(1) = cmplx(vector(1), 0._wp) + do i = 1, size(vector) + if (i /= 1) then + return_value(i) = cmplx(vector(i), 0._wp) + end if + end do + end function first_component + + !!---------------------------------------------------------------------------- + + function plane_wave(& + r , & + wavenumber , & + amplitude , & + direction , & + angular_frequency, & + time) & + result(return_value) + ! Direction must be normalised to unity + real(wp), dimension(:) , intent(in) :: r ! position-vector + complex(wp) , intent(in) :: wavenumber + complex(wp), dimension(:), intent(in) :: amplitude + real(wp) , dimension(:), intent(in) :: direction + real(wp) , optional , intent(in) :: angular_frequency + real(wp) , optional , intent(in) :: time + complex(wp), dimension(:), allocatable :: return_value + ! Variables for internal use ----------------------------------------------- + complex(wp) :: exponential + complex(wp) :: kr + real(wp) :: wt + integer :: spatial_dim + integer :: i + +!!$ print *, 'r:', r + spatial_dim = size(r) + allocate(return_value(spatial_dim)) + + kr = wavenumber*dot_product(r, direction) + if (is_close(wavenumber%im, ZERO)) then + exponential = cmplx(cos(kr%re), sin(kr%re)) + else + exponential = exp(I_IMAG*kr) + end if + if (present(angular_frequency) .and. present(time)) then + wt = angular_frequency*time + exponential = exponential*cmplx(cos(wt), -sin(wt)) + end if + do i = 1, spatial_dim + return_value(i) = amplitude(i)*exponential + end do + end function plane_wave + + !--------------!-------------------------------------------------------------- +end module math_funcs_mod diff --git a/MoM/mesh_mod.f90 b/MoM/mesh_mod.f90 new file mode 100644 index 00000000..227666b0 --- /dev/null +++ b/MoM/mesh_mod.f90 @@ -0,0 +1,1094 @@ +module mesh_mod +!!============================================================================== +! This module represents a mesh in the hierarchical structure: +! face --> edge --> vertex --> point +! +! A mesh_type is initialised by reading a .mesh-formated file. +! +! Abbreviations: +! CS - Closed Surface +! OS - Open Surface +!` +! Last edited: March 7th 2021. +!!============================================================================== + + !!==============!! + ! Use statements ! + !================!============================================================ + use working_precision, only: wp + use math_funcs_mod , only: cross_prod_3D + use io_mod , only: open_read_gmsh2 + use io_mod , only: r8mat_write + use iso_fortran_env , only: real64 + use is_close_mod , only: is_close + use constants_mod , only: PI + use constants_mod , only: ZERO + + implicit none + + !!===================!! + ! External procedures ! + !=====================!======================================================= + external :: dnrm2 ! BLAS level 1: Euclidean norm (double) + + + !!=================================!! + ! Public types/procedures/constants ! + !===================================!========================================= + public :: mesh_type ! Main type + public :: face_type + public :: edge_type + public :: vertex_type + public :: node_type + + !!==================================!! + ! Private types/procedures/constants ! + !====================================!======================================== + private :: eval_Euler_characteristic_CS + private :: check_input_triangulated_surface + private :: eval_topology_on_triangulated_surface + + ! From here on everything is by defualt decleared private + private + + !!------------------------!! + ! Derived type definitions ! + !--------------------------!-------------------------------------------------- + type face_type + ! Type to store indices related to the edges forming a face on the mesh. + integer, dimension(:), allocatable :: edges + end type face_type + + type edge_type + ! Type to store the indicies related to the vertices forming an edge. + integer, dimension(2) :: vertices + ! Length of node_idx depends on edge order: + ! linear: len = 0 + ! quadratic: len = 1 + ! cubic: len = 2 + integer, dimension(:), allocatable :: node_idx + contains + procedure, pass(this), public :: initialise_edge + end type edge_type + + type vertex_type + ! Type to store the index of the node at which the vertex is located. + integer :: node_idx + end type vertex_type + + type node_type + ! Type to store the 3D coordinates of a node. + real(wp), dimension(3) :: coords + end type node_type + + !!---------!! + ! Main type ! + !-----------!----------------------------------------------------------------- + type mesh_type + type (face_type) , dimension(:), allocatable :: faces + type (edge_type) , dimension(:), allocatable :: edges + type (vertex_type), dimension(:), allocatable :: vertices + type (node_type) , dimension(:), allocatable :: nodes + integer :: edge_order + integer :: spatial_dim + integer :: face_order + integer :: num_faces + integer :: num_edges + integer :: num_vertices + integer :: num_nodes + integer :: num_handles + integer :: num_apertures + integer :: num_boundary_edges + logical :: closed_surface + contains + ! Initialisers + procedure, pass(this), public :: initialise + procedure, pass(this), public :: initialise_tetrahedron + ! Writing procedures + procedure, pass(this), public :: write_mesh + ! Deallocation of attributes + procedure, pass(this), public :: deallocate_attributes + ! Get-procedures + procedure, pass(this), public :: get_closed_surface + procedure, pass(this), public :: get_edge_order + procedure, pass(this), public :: get_spatial_dim + procedure, pass(this), public :: get_face_order + procedure, pass(this), public :: get_num_handles + procedure, pass(this), public :: get_num_faces + procedure, pass(this), public :: get_num_edges + procedure, pass(this), public :: get_num_vertices + procedure, pass(this), public :: get_num_nodes + procedure, pass(this), public :: get_topology + procedure, pass(this), public :: get_edges_on_face + procedure, pass(this), public :: get_vertices_of_edge + procedure, pass(this), public :: get_vertices_of_face + procedure, pass(this), public :: get_vertex_coords + procedure, pass(this), public :: get_edge_coords + procedure, pass(this), public :: get_face_coords + ! Calculations + procedure, pass(this), public :: face_normal + procedure, pass(this), public :: face_unit_normal + procedure, pass(this), public :: face_area + procedure, pass(this), public :: face_centroid + procedure, pass(this), public :: edge_length + procedure, pass(this), public :: surface_area + procedure, pass(this), public :: volume + ! Other routines + procedure, pass(this), public :: print + procedure, pass(this), public :: scale_nodes + ! For determining whether a point is inside or outside + ! of meshe_nodes + procedure, pass(this), public :: solid_angle_spanned_by_face + procedure, pass(this), public :: solid_angle_spanned_by_mesh + procedure, pass(this), public :: is_obs_pnt_inside_mesh + ! Private procedures for internal use + procedure, pass(this), private :: create_member_types_linear + + + end type mesh_type + + + !!==============================!! + ! Overloaded operator interfaces ! + !================================!============================================ + ! Overloaded operator interfaces + interface operator (==) + module procedure is_edges_equal + end interface operator (==) + + + !=======!=========================!==========================================! +contains ! /\/\/\/\/\/\/\/\/\/\/\/\!/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\! + !=======!=========================!==========================================! + + + !!=================!! + ! Public procedures ! + !===================!========================================================= + !!------------!! + ! Constructors ! + !--------------!-------------------------------------------------------------- + + + !!=============================!! + ! mesh_type internal procedures ! + !===============================!============================================= + !!------------!! + ! Initialisers ! + !--------------!-------------------------------------------------------------- + subroutine initialise_edge(this, vertices, node_idx) + class (edge_type) , intent(inout) :: this + integer, dimension(2) , intent(in) :: vertices + integer, dimension(:), optional, intent(in) :: node_idx + this%vertices = vertices + if (present(node_idx)) then + allocate(this%node_idx(size(node_idx))) + this%node_idx = node_idx + else + allocate(this%node_idx(0)) + end if + end subroutine initialise_edge + + + subroutine initialise(this, & + MSH_FILE, & + FILE_FORMAT, & + closed_surface, & + edge_order, & + spatial_dim, & + face_order, & + num_handles_in, & + num_apertures_in, & + num_boundary_edges_in) + class (mesh_type), intent(inout) :: this + character(len=*) , intent(in) :: MSH_FILE + character(len=*) , intent(in) :: FILE_FORMAT + logical , intent(in) :: closed_surface + integer , intent(in) :: edge_order + integer , intent(in) :: spatial_dim + integer , intent(in) :: face_order + integer, optional, intent(in) :: num_handles_in + integer, optional, intent(in) :: num_apertures_in + integer, optional, intent(in) :: num_boundary_edges_in + ! Variables for internal use ----------------------------------------------- + real(wp),dimension(:, :), allocatable :: nodes + integer, dimension(:, :), allocatable :: elements + integer :: num_elements + integer :: num_faces + integer :: num_edges + integer :: num_vertices + integer :: num_nodes + integer :: num_handles + integer :: num_apertures + integer :: num_boundary_edges + + !file_type = read_file_type(MSH_FILE) + select case (FILE_FORMAT) + case ('gmsh2') + call open_read_gmsh2(MSH_FILE, spatial_dim, face_order, nodes, & + elements) + end select + + num_elements = size(elements,dim=1) + num_nodes = size(nodes, dim=1) + num_faces = num_elements ! Always the case for surface meshes + + if (face_order > 3) then + print *, 'Error: mesh_mod.f90: mesh_type_initialise:' + print *, ' Functionality for reading quadriliteral faces', & + ' is not implemented..' + stop 1 + else if (face_order < 3) then + print *, 'Error: mesh_mod.f90: mesh_type_initialise:' + print *, ' Invalid input: face_order' + stop 1 + else + call check_input_triangulated_surface(& + closed_surface, & + edge_order, & + num_handles_in=num_handles_in, & + num_apertures_in=num_apertures_in, & + num_boundary_edges_in=num_boundary_edges_in) + + call eval_topology_on_triangulated_surface(& + num_edges, & + num_vertices, & + num_handles, & + num_apertures, & + num_boundary_edges, & + num_faces, & + num_nodes, & + closed_surface, & + edge_order, & + num_handles_in=num_handles_in, & + num_apertures_in=num_apertures_in, & + num_boundary_edges_in=num_boundary_edges_in) + end if + + this%closed_surface = closed_surface + this%edge_order = edge_order + this%spatial_dim = spatial_dim + this%face_order = face_order + this%num_faces = num_faces + this%num_edges = num_edges + this%num_vertices = num_vertices + this%num_nodes = num_nodes + this%num_handles = num_handles + this%num_apertures = num_apertures + this%num_boundary_edges = num_boundary_edges + allocate(this%faces(num_faces)) + allocate(this%edges(num_edges)) + allocate(this%vertices(num_vertices)) + allocate(this%nodes(num_nodes)) + + select case (edge_order) + case (0) + call this%create_member_types_linear(nodes, elements) +!!$ case (1) + ! Not yet implemented +!!$ call this%create_member_types_quadratic(nodes, elements) +!!$ case (2) + ! Not yet implemented +!!$ call this%create_member_types_cubic(nodes, elements) + end select + + ! Test if face orientation is correct + if (closed_surface) then + if (this%volume() < 0) then + print *, 'Volume is negative:', this%volume() + stop 1 + ! Not yet implemented +!!$ call this%flip_face_orientation() + end if + end if + + + end subroutine initialise + + !!---------------------------------------------------------------------------- + + subroutine initialise_tetrahedron(this) + class (mesh_type), intent(inout) :: this + this%num_nodes = 4 + this%num_vertices = 4 + this%num_edges = 6 + this%num_faces = 4 + allocate (this%nodes(this%num_nodes)) + allocate (this%vertices(this%num_vertices)) + allocate (this%edges(this%num_edges)) + allocate (this%faces(this%num_faces)) + this%nodes(1) = node_type([ 1.0_wp, -1.0_wp, 1.0_wp ]) + this%nodes(2) = node_type([ -1.0_wp, 1.0_wp, 1.0_wp ]) + this%nodes(3) = node_type([ 1.0_wp, 1.0_wp, -1.0_wp ]) + this%nodes(4) = node_type([ -1.0_wp, -1.0_wp, -1.0_wp ]) + this%vertices(1) = vertex_type(1) + this%vertices(2) = vertex_type(2) + this%vertices(3) = vertex_type(3) + this%vertices(4) = vertex_type(4) + call this%edges(1)%initialise_edge([ 1, 3 ]) + call this%edges(2)%initialise_edge([ 3, 2 ]) + call this%edges(3)%initialise_edge([ 2, 1 ]) + call this%edges(4)%initialise_edge([ 2, 4 ]) + call this%edges(5)%initialise_edge([ 4, 1 ]) + call this%edges(6)%initialise_edge([ 4, 3 ]) + this%faces(1) = face_type([ 1, 2, 3 ]) + this%faces(2) = face_type([ 3, 4, 5 ]) + this%faces(3) = face_type([ 2, 6, 4 ]) + this%faces(4) = face_type([ 5, 6, 1 ]) + this%num_handles = eval_Euler_characteristic_CS( & + num_faces=this%num_faces, & + num_edges=this%num_edges, & + num_vertices=this%num_vertices) + this%closed_surface = .true. + this%edge_order = 0 + this%spatial_dim = 3 + this%face_order = 3 + end subroutine initialise_tetrahedron + + !!---------------------------------------------------------------------------- + + subroutine deallocate_attributes(this) + class (mesh_type), intent(inout) :: this + ! Variables for internal use ----------------------------------------------- + integer :: i + + do i = 1, this%num_faces + deallocate(this%faces(i)%edges) + end do + do i = 1, this%num_edges + deallocate(this%edges(i)%node_idx) + end do + deallocate(this%faces) + deallocate(this%edges) + deallocate(this%vertices) + deallocate(this%nodes) + end subroutine deallocate_attributes + + !!--------------!! + ! Write routines ! + !----------------!------------------------------------------------------------ + + subroutine write_mesh(this, filename) + class (mesh_type), intent(in) :: this + character(len=*) , intent(in) :: filename + ! Variables for internal use ----------------------------------------------- + real(wp), dimension(this%num_faces,this%spatial_dim*this%face_order):: table + real(wp), dimension(this%face_order, this%spatial_dim) :: face_coords + integer :: i + integer :: j + integer :: k + + do i = 1, this%num_faces + face_coords = this%get_face_coords(i) + do j = 1, this%face_order + do k = 1, this%spatial_dim + table(i, (j - 1)*this%spatial_dim + k) = face_coords(j, k) + end do + end do + end do + if (wp == real64) then + call r8mat_write(filename, this%num_faces, & + this%spatial_dim*this%face_order, table) + else + print *, 'No write routine for current precision.' + end if + end subroutine write_mesh + + !!-------------!! + ! Get-functions ! + !---------------!------------------------------------------------------------- + function get_closed_surface(this) result(return_value) + class (mesh_type), intent(in) :: this + logical :: return_value + return_value = this%closed_surface + end function get_closed_surface + + !!---------------------------------------------------------------------------- + + function get_spatial_dim(this) result(return_value) + class (mesh_type), intent(in) :: this + integer :: return_value + return_value = this%spatial_dim + end function get_spatial_dim + + !!---------------------------------------------------------------------------- + + function get_face_order(this) result(return_value) + class (mesh_type), intent(in) :: this + integer :: return_value + return_value = this%face_order + end function get_face_order + + !!---------------------------------------------------------------------------- + + function get_edge_order(this) result(return_value) + class (mesh_type), intent(in) :: this + integer :: return_value + return_value = this%edge_order + end function get_edge_order + + !!---------------------------------------------------------------------------- + + function get_num_handles(this) result(return_value) + class (mesh_type), intent(in) :: this + integer :: return_value + return_value = this%num_handles + end function get_num_handles + + !!---------------------------------------------------------------------------- + + function get_num_faces(this) result(return_value) + class (mesh_type), intent(in) :: this + integer :: return_value + return_value = this%num_faces + end function get_num_faces + + !!---------------------------------------------------------------------------- + + function get_num_edges(this) result(return_value) + class (mesh_type), intent(in) :: this + integer :: return_value + return_value = this%num_edges + end function get_num_edges + + !!---------------------------------------------------------------------------- + + function get_num_vertices(this) result(return_value) + class (mesh_type), intent(in) :: this + integer :: return_value + return_value = this%num_vertices + end function get_num_vertices + + !!---------------------------------------------------------------------------- + + function get_num_nodes(this) result(return_value) + class (mesh_type), intent(in) :: this + integer :: return_value + return_value = this%num_nodes + end function get_num_nodes + + !!---------------------------------------------------------------------------- + + subroutine get_topology(& + this , & + num_handles , & + num_apertures , & + num_boundary_edges, & + num_faces , & + num_edges , & + num_vertices) + class (mesh_type), intent(in) :: this + integer , intent(inout) :: num_handles + integer , intent(inout) :: num_apertures + integer , intent(inout) :: num_boundary_edges + integer , intent(inout) :: num_faces + integer , intent(inout) :: num_edges + integer , intent(inout) :: num_vertices + num_handles = this%num_handles + num_apertures = this%num_apertures + num_boundary_edges = this%num_boundary_edges + num_faces = this%num_faces + num_edges = this%num_edges + num_vertices = this%num_vertices + end subroutine get_topology + + !!---------------------------------------------------------------------------- + + function get_edges_on_face(this, face_idx) result(return_value) + class (mesh_type) , intent(in) :: this + integer , intent(in) :: face_idx + integer, dimension(3) :: return_value + return_value = this%faces(face_idx)%edges + end function get_edges_on_face + + !!---------------------------------------------------------------------------- + + function get_vertices_of_edge(this, edge_idx) result(return_value) + class (mesh_type), intent(in) :: this + integer , intent(in) :: edge_idx + integer, dimension(2) :: return_value + return_value = this%edges(edge_idx)%vertices + end function get_vertices_of_edge + + !!---------------------------------------------------------------------------- + + function get_vertex_coords(this, vertex_idx) result(return_value) + class (mesh_type) , intent(in) :: this + integer , intent(in) :: vertex_idx + real(wp), dimension(this%spatial_dim) :: return_value + return_value = this%nodes(this%vertices(vertex_idx)%node_idx)%coords + end function get_vertex_coords + + !!---------------------------------------------------------------------------- + + function get_edge_coords(this, edge_idx) result(return_value) + class (mesh_type) , intent(in) :: this + integer , intent(in) :: edge_idx + real(wp), dimension(2, this%spatial_dim) :: return_value + ! Variables for internal use ----------------------------------------------- + integer , dimension(2) :: vertices + vertices = this%edges(edge_idx)%vertices + return_value(1, :) = this%get_vertex_coords(vertices(1)) + return_value(2, :) = this%get_vertex_coords(vertices(2)) + end function get_edge_coords + + !!---------------------------------------------------------------------------- + + function get_vertices_of_face(this, face_idx) result(return_value) + class (mesh_type) , intent(in) :: this + integer , intent(in) :: face_idx + integer , dimension(this%face_order) :: return_value + ! Variables for internal use ----------------------------------------------- + integer , dimension(this%face_order) :: edges_on_face + integer , dimension(2) :: vertices_of_edge1 + integer , dimension(2) :: vertices_of_edge2 + + edges_on_face = this%faces(face_idx)%edges + vertices_of_edge1 = this%edges(edges_on_face(1))%vertices + vertices_of_edge2 = this%edges(edges_on_face(2))%vertices + ! Find the three unique vertices of the face and arrange them in the + ! array 'return_value' such that the orientation of the face is correct + if (((vertices_of_edge1(1) == vertices_of_edge2(1)) .and. & + (vertices_of_edge1(2) == vertices_of_edge2(2))) .or. & + ((vertices_of_edge1(2) == vertices_of_edge2(1)) .and. & + (vertices_of_edge1(1) == vertices_of_edge2(2)))) then + ! If two edges represents the same vertices, exit with error. + print *, 'Face has two identical edges.' + print *, 'Edges on face: ', edges_on_face + print *, 'Exiting..' + stop 1 + else if (vertices_of_edge1(1) == vertices_of_edge2(1)) then + return_value(1) = vertices_of_edge1(2) + return_value(2) = vertices_of_edge1(1) + return_value(3) = vertices_of_edge2(2) + else if (vertices_of_edge1(1) == vertices_of_edge2(2)) then + return_value(1) = vertices_of_edge1(2) + return_value(2) = vertices_of_edge1(1) + return_value(3) = vertices_of_edge2(1) + else if (vertices_of_edge1(2) == vertices_of_edge2(1)) then + return_value(1) = vertices_of_edge1(1) + return_value(2) = vertices_of_edge1(2) + return_value(3) = vertices_of_edge2(2) + else if (vertices_of_edge1(2) == vertices_of_edge2(2)) then + return_value(1) = vertices_of_edge1(1) + return_value(2) = vertices_of_edge1(2) + return_value(3) = vertices_of_edge2(1) + else + ! If the two edges does not have a common vertex, exit with error. + print *, 'Could not find matching vertices on face edges.' + print *, 'Edges on face: ', edges_on_face + print *, 'Vertices of edge1: ', vertices_of_edge1 + print *, 'Vertices of edge2: ', vertices_of_edge2 + print *, 'Exiting..' + stop 1 + end if + end function get_vertices_of_face + + !!---------------------------------------------------------------------------- + + function get_face_coords(this, face_idx) result(return_value) + class (mesh_type) , intent(in) :: this + integer , intent(in) :: face_idx + real(wp), dimension(this%face_order, this%spatial_dim) :: return_value + ! Variables for internal use ----------------------------------------------- + integer , dimension(this%face_order) :: vertices_of_face + integer :: i + vertices_of_face = this%get_vertices_of_face(face_idx) + do i = 1, this%face_order + return_value(i, :) = this%get_vertex_coords(vertices_of_face(i)) + end do + end function get_face_coords + + + !!------------!! + ! Calculations ! + !--------------!-------------------------------------------------------------- + function face_normal(this, face_idx) result(return_value) + class (mesh_type) , intent(in) :: this + integer , intent(in) :: face_idx + integer :: i + real(wp), dimension(3) :: return_value + real(wp), dimension(3, 3) :: face_coords + real(wp), dimension(2, 3) :: face_vectors + face_coords = this%get_face_coords(face_idx) + do i = 1, 3 + face_vectors(1, i) = face_coords(2, i) - face_coords(1, i) + face_vectors(2, i) = face_coords(3, i) - face_coords(1, i) + end do + return_value = cross_prod_3D(face_vectors(1, :), face_vectors(2, :)) + end function face_normal + + + function face_unit_normal(this, face_idx) result(return_value) + class (mesh_type) , intent(in) :: this + integer , intent(in) :: face_idx + real(wp), dimension(3) :: return_value + real(wp) , external :: dnrm2 + real(wp) :: scale_factor + return_value = this%face_normal(face_idx) + scale_factor = 1/norm2(return_value) + return_value = scale_factor*return_value + end function face_unit_normal + + + function face_area(this, face_idx) result(return_value) + ! From BLAS level 1: + ! dnrm2: Euclidean norm (double) + class (mesh_type), intent(in) :: this + integer , intent(in) :: face_idx + real(wp) :: return_value + real(wp) , external :: dnrm2 + return_value = 0.5_wp*norm2(this%face_normal(face_idx)) + end function face_area + + + function face_centroid(this, face_idx) result(return_value) + class (mesh_type) , intent(in) :: this + integer , intent(in) :: face_idx + integer :: i + real(wp), dimension(3) :: return_value + real(wp), dimension(3, 3) :: face_coords + face_coords = this%get_face_coords(face_idx) + ! The centroid has coordinates equal to the mean x, y, z coordinates + ! of the face's node coordinates + do i = 1, 3 + return_value(i) = sum(face_coords(:, i))/3._wp + end do + end function face_centroid + + + function surface_area(this) result(return_value) + class (mesh_type), intent(in) :: this + real(wp) :: return_value + integer :: i + return_value = 0._wp + do i = 1, this%num_faces + return_value = return_value + this%face_area(i) + end do + end function surface_area + + + function edge_length(this, edge_idx) result(return_value) + class (mesh_type), intent(in) :: this + integer , intent(in) :: edge_idx + real(wp) :: return_value + ! Variables for internal use ----------------------------------------------- + real(wp) , external :: dnrm2 + real(wp), dimension(2, this%spatial_dim) :: edge_coords + real(wp), dimension(this%spatial_dim) :: displacement_vector + edge_coords = this%get_edge_coords(edge_idx) + displacement_vector = edge_coords(2, :) - edge_coords(1, :) + return_value = dnrm2(this%spatial_dim, displacement_vector, 1) + end function edge_length + + + function volume(this) result(return_value) + ! This function is not optimised because it calls on face_normal() two times + ! and get_face_coords three times + class (mesh_type), intent(in) :: this + real(wp) :: return_value + real(wp) :: area + integer :: i + real(wp), dimension(3) :: unit_normal, centroid + return_value = 0._wp + if (this%closed_surface) then + do i = 1, this%num_faces + unit_normal = this%face_unit_normal(i) + area = this%face_area(i) + centroid = this%face_centroid(i) + return_value = return_value + unit_normal(1)*area*centroid(1) + end do + else + print *, 'Error: mesh_mod.f90: volume:' + print *, ' Cannot calculate volume of open surface meshes.' + stop 1 + end if + end function volume + + + !!-----------------!! + ! Printing routines ! + !-------------------!--------------------------------------------------------- + subroutine print(this) + class (mesh_type), intent(in) :: this + integer :: i + + print *, 'Vertices:' + do i = 1, this%num_vertices + print *, this%vertices(i)%node_idx + end do + print *, 'Edges:' + do i = 1, this%num_edges + print *, this%edges(i)%vertices + end do + print *, 'Faces:' + do i = 1, this%num_faces + print *, this%faces(i)%edges + end do + end subroutine print + + + !!---------------------------------------------------------------------------- + + subroutine scale_nodes(this, scale_factor) + class (mesh_type), intent(inout) :: this + real(wp) , intent(in) :: scale_factor + ! Variables for internal use ----------------------------------------------- + integer :: i + integer :: j + do i = 1, this%num_nodes + do j = 1, this%spatial_dim + this%nodes(i)%coords(j) = this%nodes(i)%coords(j)*scale_factor + end do + end do + end subroutine scale_nodes + + !!---------------------------------------------------------------------------- + + function solid_angle_spanned_by_face(this, face_idx, obs_pnt) result(res) + class (mesh_type), intent(in) :: this + integer , intent(in) :: face_idx + real(wp), dimension(this%spatial_dim) :: obs_pnt + real(wp) :: res + ! Variables for internal use ----------------------------------------------- + real(wp), dimension(this%face_order, this%spatial_dim) :: face_coords + real(wp), dimension(this%spatial_dim) :: a + real(wp), dimension(this%spatial_dim) :: b + real(wp), dimension(this%spatial_dim) :: c + + ! Currently only implemented for 3D surface triangulations + if (this%spatial_dim /= 3 .or. this%face_order /= 3) then + print *, 'Error: mesh_mod.f90: solid_angle_spanned_by_triangle' + print *, ' Solid angle calculation only implemented for 3D', & + 'surface triangulations' + end if + + face_coords = this%get_face_coords(face_idx) + a = face_coords(1, :) - obs_pnt + b = face_coords(2, :) - obs_pnt + c = face_coords(3, :) - obs_pnt + a = a/norm2(a) + b = b/norm2(b) + c = c/norm2(c) + ! Observation point on face + ! Solid angle calculated by area of the spherical triangle abc on the unit + ! sphere + res = abs(dot_product(a, cross_prod_3D(b, c))) & + /(1._wp + dot_product(a, b) + dot_product(b, c) + dot_product(a, c)) + ! Set sign of solid angle depending on the orientation of the face + res = 2*atan(res) + res = sign(res, dot_product(this%face_normal(face_idx), a)) + end function solid_angle_spanned_by_face + + !!---------------------------------------------------------------------------- + + function solid_angle_spanned_by_mesh(this, obs_pnt) result(res) + class (mesh_type), intent(in) :: this + real(wp), dimension(this%spatial_dim) :: obs_pnt + real(wp) :: res + ! Variables for internal use ----------------------------------------------- + integer :: n + + res = 0._wp + do n = 1, this%num_faces + res = res + this%solid_angle_spanned_by_face(n, obs_pnt) + end do + end function solid_angle_spanned_by_mesh + + !!---------------------------------------------------------------------------- + + function is_obs_pnt_inside_mesh(this, obs_pnt) result(res) + class (mesh_type), intent(in) :: this + real(wp), dimension(this%spatial_dim) :: obs_pnt + logical :: res + ! Variables for internal use ----------------------------------------------- + real(wp) :: solid_angle + + solid_angle = this%solid_angle_spanned_by_mesh(obs_pnt) + if (is_close(solid_angle, 4._wp*PI, rtol=1.E-2_wp)) then + res = .true. + else if (is_close(solid_angle, ZERO)) then + res = .false. + else + print *, 'Warning: mesh_mod: is_obs_pnt_inside_mesh:' + print *, ' Observation point neither inside or outside mesh.', & + ' Check mesh representation.' + print *, ' Solid angle value:', solid_angle + print *, ' Observation point:', obs_pnt + print *, ' Distance from Ori:', norm2(obs_pnt) + res = .true. + end if + end function is_obs_pnt_inside_mesh + + !!---------------------------!! + ! Private internal procedures ! + !-----------------------------!---------------------------------------------- + subroutine create_member_types_linear(this, nodes, elements) + class (mesh_type) , intent(inout) :: this + real(wp), dimension(:, :), intent(in) :: nodes + integer , dimension(:, :), intent(in) :: elements + ! Variables for internal use ---------------------------------------------- + type (edge_type) :: edge + integer :: i + integer :: j + integer :: k + integer :: idx + integer :: edge_counter + integer, dimension(this%face_order) :: edge_idxs + logical :: edge_exists + + ! Create vertices and nodes + do i = 1, this%num_nodes + this%nodes(i) = node_type(nodes(i, :)) + this%vertices(i) = vertex_type(i) + end do + + allocate(edge%node_idx(0)) + ! Create faces and edges + edge_counter = 0 + do i = 1, this%num_faces + do j = 1, this%face_order + if (j == this%face_order) then + idx = 1 + else + idx = j + 1 + end if + edge%vertices = [ elements(i, j), elements(i, idx) ] + edge_exists = .false. + do k = 1, edge_counter + if (edge == this%edges(k)) then + edge_exists = .true. + exit + end if + end do + if (edge_exists) then + edge_idxs(j) = k + else + edge_counter = edge_counter + 1 + allocate(this%edges(edge_counter)%node_idx(0)) + this%edges(edge_counter)%vertices = [ elements(i, j), & + elements(i, idx) ] + edge_idxs(j) = edge_counter + end if + end do + allocate(this%faces(i)%edges(this%face_order)) + this%faces(i)%edges = edge_idxs + end do + + end subroutine create_member_types_linear + + !!---------------------------------------------------------------------------- +!!$ +!!$ subroutine create_member_types_quadratic(this, nodes, elements) +!!$ class (mesh_type), intent(inout) :: this +!!$ real(wp), dimension(:, :), intent(in) :: nodes +!!$ integer , dimension(:, :), intent(in) :: elements +!!$ ! Not implemented +!!$ end subroutine create_member_types_quadratic +!!$ +!!$ !!---------------------------------------------------------------------------- +!!$ +!!$ subroutine create_member_types_cubic(this, nodes, elements) +!!$ class (mesh_type), intent(inout) :: this +!!$ real(wp), dimension(:, :), intent(in) :: nodes +!!$ integer , dimension(:, :), intent(in) :: elements +!!$ ! Not implemented +!!$ end subroutine create_member_types_cubic +!!$ +!!$ !!---------------------------------------------------------------------------- +!!$ +!!$ subroutine flip_face_orientation(this) +!!$ class (mesh_type), intent(inout) :: this +!!$ ! Not implemented +!!$ end subroutine flip_face_orientation +!!$ + + !!==================!! + ! Private procedures ! + !====================!======================================================== + function eval_Euler_characteristic_CS(num_faces, num_edges, num_vertices, & + num_handles) result (return_value) + integer, optional, intent(in) :: num_faces + integer, optional, intent(in) :: num_edges + integer, optional, intent(in) :: num_vertices + integer, optional, intent(in) :: num_handles + integer :: return_value + + if (present(num_faces) .and. present(num_edges) .and. & + present(num_vertices)) then + return_value = (num_edges - num_faces - num_vertices + 2)/2 + else if (present(num_handles) .and. present(num_edges) .and. & + present(num_vertices)) then + return_value = 2*(1 - num_handles) + num_edges - num_vertices + else if (present(num_handles) .and. present(num_faces) .and. & + present(num_vertices)) then + return_value = -2*(1 - num_handles) + num_faces + num_vertices + else if (present(num_handles) .and. present(num_faces) .and. & + present(num_edges)) then + return_value = 2*(1 - num_handles) - num_faces + num_edges + else + print *, 'Error: eval_Euler_characteristic_CS: invalid options' + stop 1 + end if + end function eval_Euler_characteristic_CS + + + subroutine check_input_triangulated_surface(& + closed_surface, & + edge_order, & + num_handles_in, & + num_apertures_in, & + num_boundary_edges_in) + logical , intent(in) :: closed_surface + integer , intent(in) :: edge_order + integer, optional, intent(in) :: num_handles_in + integer, optional, intent(in) :: num_apertures_in + integer, optional, intent(in) :: num_boundary_edges_in + + if (closed_surface) then + if (edge_order > 0) then + if (.not. present(num_handles_in)) then + print *, 'Error: mesh_mod.f90: initialise: ' + print *, ' Missing optional parameter: num_handles. ' + end if + end if + else + if (edge_order > 0) then + if (.not. present(num_handles_in) .or. & + .not. present(num_apertures_in) .or. & + .not. present(num_boundary_edges_in)) then + print *, 'Error: mesh_mod.f90: initialise: ' + print *, ' Missing one or more of the following optional ', & + 'parameters: ' + print *, ' num_handles, num_apertures, num_boundary_edges' + end if + else + if (.not. present(num_boundary_edges_in)) then + print *, 'Error: mesh_mod.f90: initialise: ' + print *, ' Missing optional parameter: num_bounadry_edges. ' + end if + end if + end if + end subroutine check_input_triangulated_surface + + !------------------------------------------------------------------------------ + + subroutine eval_topology_on_triangulated_surface(& + num_edges, & + num_vertices, & + num_handles, & + num_apertures, & + num_boundary_edges, & + num_faces, & + num_nodes, & + closed_surface, & + edge_order, & + num_handles_in, & + num_apertures_in, & + num_boundary_edges_in) + + integer, intent(inout) :: num_edges + integer, intent(inout) :: num_vertices + integer, intent(inout) :: num_handles + integer, intent(inout) :: num_apertures + integer, intent(inout) :: num_boundary_edges + integer, intent(in) :: num_faces + integer, intent(in) :: num_nodes + logical, intent(in) :: closed_surface + integer, intent(in) :: edge_order + integer, optional, intent(in) :: num_handles_in + integer, optional, intent(in) :: num_apertures_in + integer, optional, intent(in) :: num_boundary_edges_in + + select case (closed_surface) + case (.true.) + if (edge_order == 0) then + num_vertices = num_nodes + else + num_vertices = eval_Euler_characteristic_CS(& + num_faces=num_faces, & + num_edges=num_edges, & + num_handles=num_handles_in) + end if + num_edges = 3*num_faces/2 + if (.not. present(num_handles_in)) then + num_handles = eval_Euler_characteristic_CS(& + num_faces=num_faces, & + num_edges=num_edges, & + num_vertices=num_vertices) + else + num_handles = num_edges - num_Faces - num_vertices + 2 + if (num_handles /= 2*num_handles_in) then + print *, 'Warning: mesh_mod.f90: eval_topology_on_triangulated_', & + 'surface:' + print *, ' Evaluated topology parameters do not follow ' + print *, ' Euler characteristic. num_handles differ by:', & + (num_handles_in - 2*num_handles)/2 ! Might cause rounding err. + end if + num_handles = num_handles_in + end if + num_apertures = 0 + num_boundary_edges = 0 + case (.false.) + if (edge_order == 0) then + num_vertices = num_nodes + else + num_vertices = (num_faces - 2*num_apertures_in - 4*(num_handles_in-1)& + + num_boundary_edges_in)/2 + end if + num_edges = (3*num_faces + num_boundary_edges_in)/2 + if (present(num_apertures_in) .and. & + .not. present(num_handles_in)) then + num_apertures = num_apertures_in + num_handles = (num_edges - 3*num_vertices - 3*num_apertures_in & + + 6 + num_boundary_edges_in)/6 + else if (present(num_handles_in) .and. & + .not. present(num_apertures_in)) then + num_handles = num_handles_in + num_apertures = (num_faces - 2*num_vertices - 4*(num_handles_in - 1) & + + num_boundary_edges_in)/2 + else if (present(num_handles_in) .and. & + present(num_apertures_in)) then + num_handles = (num_faces - 2*num_vertices - 2*num_apertures + & + num_boundary_edges_in + 4)/4 + num_apertures = num_apertures_in + if (num_handles /= num_handles_in) then + print *, 'Warning: mesh_mod.f90: eval_topology_on_triangulated_', & + 'surface:' + print *, ' Evaluated topology parameters do not follow ' + print *, ' Euler characteristic. num_handles differ by:', & + num_handles_in - num_handles + num_handles = num_handles_in + end if + else + print *, 'Warning: mesh_mod.f90: eval_topology_on_triangulated_', & + 'surface:' + print *, ' mesh_type attributes not set:' + print *, ' num_handles, num_apertures' + end if + num_boundary_edges = num_boundary_edges_in + + end select + end subroutine eval_topology_on_triangulated_surface + + + + !!====================!! + ! Overloaded operators ! + !======================!====================================================== + function is_edges_equal(edge_a, edge_b) result(return_value) + type(edge_type), intent(in) :: edge_a + type(edge_type), intent(in) :: edge_b + logical :: return_value + if ((edge_a%vertices(1) == edge_b%vertices(1) .and. & + edge_a%vertices(2) == edge_b%vertices(2)) .or. (& + edge_a%vertices(1) == edge_b%vertices(2) .and. & + edge_a%vertices(2) == edge_b%vertices(1))) then + return_value = .true. + else + return_value = .false. + end if + end function is_edges_equal + + !============================================================================= +end Module mesh_mod diff --git a/MoM/test_utilities.f90 b/MoM/test_utilities.f90 new file mode 100644 index 00000000..414901f4 --- /dev/null +++ b/MoM/test_utilities.f90 @@ -0,0 +1,277 @@ +module test_utilities +!!============================================================================== +! This module defines som useful procedures for use by the testing programs. +! +! +! Last edited: October 21th 2020. +!!============================================================================== + + !!==============!! + ! Use statements ! + !================!============================================================ + use working_precision, only: wp + use mesh_mod , only: mesh_type + use RWG_basis_mod , only: RWG_basis_type + implicit none + + + !!=================================!! + ! Public types/procedures/constants ! + !===================================!========================================= + public :: print_status_start + public :: print_status_done + public :: check_mesh_calculations + public :: check_RWG_basis_initialisation + + + !!=====================!! + ! Procedure definitions ! + !=======================!===================================================== + contains + + subroutine print_status_start(num_tests, test_nr, mod, proc) + integer, intent(in) :: num_tests + integer, intent(in) :: test_nr + character(len=*), intent(in) :: mod + character(len=*), intent(in) :: proc + write (*, fmt="(a,a)", advance="no") 'Testing: ', mod + write (*, fmt="(i3,a,i0,a)", advance="no") test_nr, '/', num_tests, ' >>> ' + write (*, fmt="(a,a)", advance="no") proc, ' ...' + end subroutine print_status_start + + !!---------------------------------------------------------------------------- + + subroutine print_status_done(test_nr) + integer, intent(inout) :: test_nr + write (*,*) 'done' + test_nr = test_nr + 1 + end subroutine print_status_done + + !!---------------------------------------------------------------------------- + + subroutine print_error_message(module_name, test_name, msg, degree) + character(len=*) , intent(in) :: module_name + character(len=*) , intent(in) :: test_name + character(len=*) , intent(in) :: msg + integer, optional, intent(in) :: degree + print *, '' + print *, 'Error: ', module_name, ': ', test_name, ':' + print *, ' ', msg + if (present(degree)) then + stop degree + else + stop 2 + end if + end subroutine print_error_message + + !!---------------------------------------------------------------------------- + + subroutine check_mesh_calculations(& + mesh , & + correct_num_faces , & + correct_num_edges , & + correct_num_vertices , & + correct_num_handles , & + correct_num_apertures , & + correct_num_boundary_edges, & + correct_face_area , & + correct_surface_area , & + correct_volume) + type (mesh_type) , intent(in) :: mesh + integer , intent(in) :: correct_num_faces + integer , intent(in) :: correct_num_edges + integer , intent(in) :: correct_num_vertices + integer , intent(in) :: correct_num_handles + integer , intent(in) :: correct_num_apertures + integer , intent(in) :: correct_num_boundary_edges + real(wp) , intent(in) :: correct_face_area + real(wp) , intent(in) :: correct_surface_area + real(wp), optional, intent(in) :: correct_volume + ! Variables for internal use ----------------------------------------------- + real(wp) :: area + real(wp) :: surface_area + real(wp) :: volume + integer :: i + + if (mesh%num_faces /= correct_num_faces) then + print *, '' + print *, 'Error: test_initialise_tetrahedron in mesh_test.f90', & + ' failed..' + print *, ' Estimated number of faces: ', mesh%num_faces, & + 'Correct result: ', correct_num_faces + stop 1 + end if + if (mesh%num_edges /= correct_num_edges) then + print *, '' + print *, 'Error: test_initialise_tetrahedron in mesh_test.f90', & + ' failed..' + print *, ' Estimated number of edges: ', mesh%num_edges, & + 'Correct result: ', correct_num_edges + stop 1 + end if + if (mesh%num_vertices /= correct_num_vertices) then + print *, '' + print *, 'Error: test_initialise_tetrahedron in mesh_test.f90', & + ' failed..' + print *, ' Estimated number of vertices: ', mesh%num_vertices, & + 'Correct result: ', correct_num_vertices + stop 1 + end if + if (mesh%num_handles /= correct_num_handles) then + print *, '' + print *, 'Error: test_initialise_tetrahedron in mesh_test.f90', & + ' failed..' + print *, ' Estimated number of handles: ', mesh%num_handles, & + 'Correct result: ', correct_num_handles + stop 1 + end if + if (mesh%num_apertures /= correct_num_apertures) then + print *, '' + print *, 'Error: test_initialise_tetrahedron in mesh_test.f90', & + ' failed..' + print *, ' Estimated number of apertures: ', mesh%num_apertures, & + 'Correct result: ', correct_num_apertures + stop 1 + end if + if (mesh%num_boundary_edges /= correct_num_boundary_edges) then + print *, '' + print *, 'Error: test_initialise_tetrahedron in mesh_test.f90', & + ' failed..' + print *, ' Estimated number of boundary_edges: ', & + mesh%num_boundary_edges, & + 'Correct result: ', correct_num_boundary_edges + stop 1 + end if + + do i = 1, mesh%num_faces + area = mesh%face_area(i) + if (area /= correct_face_area) then + print *, '' + print *, 'Error: test_initialise_tetrahedron in mesh_test.f90', & + ' failed..' + print *, ' Estimated face area: ', area, 'Correct result: ', & + correct_face_area + stop 1 + end if + end do + + surface_area = mesh%surface_area() + if (surface_area /= correct_surface_area) then + print *, '' + print *, 'Error: test_surface_area in mesh_test.f90 failed..' + print *, ' Estimated surface area: ', surface_area, 'Correct result: ', & + correct_surface_area + stop 1 + end if + if (present(correct_volume)) then + volume = mesh%volume() + if (volume /= correct_volume) then + print *, '' + print *, 'Error: test_volume in mesh_test.f90 failed..' + print *, ' Estimated volume: ', volume, 'Correct result: ', & + correct_volume + stop 1 + end if + end if + + end subroutine check_mesh_calculations + + !!---------------------------------------------------------------------------- + + subroutine check_RWG_basis_initialisation(& + RWG_basis , & + correct_basis_edges, & + correct_adjacencies, & + correct_basis_edge_length) + type (RWG_basis_type) , intent(in) :: RWG_basis + integer , dimension(:) , intent(in) :: correct_basis_edges + integer , dimension(:, :), intent(in) :: correct_adjacencies + real(wp), dimension(:) , intent(in) :: correct_basis_edge_length + ! Variables for internal use ----------------------------------------------- + integer :: correct_num_bases + integer :: i + integer :: j + + correct_num_bases = size(correct_basis_edges) + if (correct_num_bases /= RWG_basis%num_bases) then + print *, 'Error: test_initialise in RWG_basis_test.f90 failed..' + print *, 'Num bases:', RWG_basis%num_bases, 'Correct', correct_num_bases + stop 2 + end if + do i = 1, correct_num_bases + if (RWG_basis%basis_edges(i) /= correct_basis_edges(i)) then + print *, 'Error: test_initialise in RWG_basis_test.f90 failed..' + print *, 'i: ', i, 'Edge_idx:', RWG_basis%basis_edges(i), & + 'Correct value:', correct_basis_edges(i) + stop 2 + end if + + if (RWG_basis%basis_edge_length(i) /= correct_basis_edge_length(i)) then + print *, 'Error: test_initialise in RWG_basis_test.f90 failed..' + print *, 'i: ', i, 'edge length:', & + RWG_basis%basis_edge_length(i), & + 'Correct value:', correct_basis_edge_length(i) + stop 2 + end if + + do j = 1, 2 + if (RWG_basis%adjacent_faces(i, j) /= correct_adjacencies(i, j)) then + print *, 'Error: test_initialise in RWG_basis_test.f90 failed..' + print *, 'i: ', i, 'j:', j, 'face_idx:', & + RWG_basis%adjacent_faces(i, j), & + 'Correct value:', correct_adjacencies(i, j) + stop 2 + end if + end do + end do + end subroutine check_RWG_basis_initialisation + +!!------------------------------------------------------------------------------ + + function linspace( & + lower_limit , & + upper_limit , & + num_elements) & + result(res) + real(wp), intent(in) :: lower_limit + real(wp), intent(in) :: upper_limit + integer , intent(in) :: num_elements + ! Result variable to be returned ------------------------------------------- + real(wp), dimension(num_elements) :: res + ! Variables for internal use ----------------------------------------------- + real(wp) :: uniform_spacing + integer :: i + + uniform_spacing = (upper_limit - lower_limit)/real(num_elements - 1) + do i = 1, num_elements + res(i) = lower_limit + (i - 1)*uniform_spacing + end do + end function linspace + +!!------------------------------------------------------------------------------ + + subroutine meshgrid(& + XX , & + YY , & + x_coords, & + y_coords) + real(wp), dimension(:, :),intent(inout) :: XX(:, :) + real(wp), dimension(:, :), intent(inout) :: YY(:, :) + real(wp), dimension(:) , intent(in) :: x_coords + real(wp), dimension(:) , intent(in) :: y_coords + ! Variables for internal use ----------------------------------------------- + integer :: num_x_coords + integer :: num_y_coords + integer :: i + + num_x_coords = size(x_coords) + num_y_coords = size(y_coords) +!!$ allocate(XX(num_y_coords, num_x_coords)) +!!$ allocate(YY(num_y_coords, num_y_coords)) + XX(:, :) = reshape(spread(x_coords, 1, num_y_coords), [num_y_coords, num_x_coords]) + YY(:, :) = reshape(spread(y_coords, 2, num_x_coords), [num_y_coords, num_x_coords]) + end subroutine meshgrid + +!!------------------------------------------------------------------------------ +end module test_utilities + diff --git a/MoM/working_precision.f90 b/MoM/working_precision.f90 new file mode 100644 index 00000000..32b7a292 --- /dev/null +++ b/MoM/working_precision.f90 @@ -0,0 +1,22 @@ +module working_precision +!!============================================================================== +! This module defines working precision used in the project. +! +! +! Last edited: October 21th 2020. +!!============================================================================== + + !!==============!! + ! Use statements ! + !================!============================================================ + + use iso_fortran_env, only: real64, wp=>real64 + implicit none + + !!=================================!! + ! Public types/procedures/constants ! + !===================================!========================================= + + +end module working_precision +