From bb84746cbe37393eda1c1b569226c4f761310224 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:29:32 +0900 Subject: [PATCH 01/43] modified cmakelist modules --- src/modules/CMakeLists.txt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index 0df7a44a9..df8802c2d 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -75,6 +75,9 @@ INCLUDE(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) #BaseType INCLUDE(${CMAKE_CURRENT_LIST_DIR}/BaseType/CMakeLists.txt) +#MultiIndices +INCLUDE(${CMAKE_CURRENT_LIST_DIR}/MultiIndices/CMakeLists.txt) + #OpenMP INCLUDE(${CMAKE_CURRENT_LIST_DIR}/OpenMP/CMakeLists.txt) From 12430c3bc096249138384f82a3471ea8edceae78 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:29:44 +0900 Subject: [PATCH 02/43] modified base method --- src/modules/BaseMethod/src/BaseMethod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/BaseMethod/src/BaseMethod.F90 b/src/modules/BaseMethod/src/BaseMethod.F90 index a50ad58b1..e5bb32f0d 100644 --- a/src/modules/BaseMethod/src/BaseMethod.F90 +++ b/src/modules/BaseMethod/src/BaseMethod.F90 @@ -74,6 +74,7 @@ MODULE BaseMethod USE Utility USE PolynomialUtility USE BaseType +USE MultiIndices_Method USE Random_Method USE BoundingBox_Method USE IntVector_Method From 683bd8b8c863ee53972bc13f46e71f97b79379f6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:30:10 +0900 Subject: [PATCH 03/43] :mod globaldata --- src/modules/GlobalData/src/GlobalData.F90 | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/src/modules/GlobalData/src/GlobalData.F90 b/src/modules/GlobalData/src/GlobalData.F90 index 93001465a..868c8947e 100755 --- a/src/modules/GlobalData/src/GlobalData.F90 +++ b/src/modules/GlobalData/src/GlobalData.F90 @@ -250,11 +250,11 @@ MODULE GlobalData INTEGER(DIP), PARAMETER :: BYI4B = BIT_SIZE(MaxInt) / 8_DIP ! default in bytes REAL(DFP), PARAMETER :: Pi = 3.14159265359_DFP REAL(DFP), PARAMETER, DIMENSION(3, 3) :: Eye3 = RESHAPE( & - (/1.0_DFP, 0.0_DFP, 0.0_DFP, & - 0.0_DFP, 1.0_DFP, 0.0_DFP, & - 0.0_DFP, 0.0_DFP, 1.0_DFP/), (/3, 3/)) + (/1.0_DFP, 0.0_DFP, 0.0_DFP, & + 0.0_DFP, 1.0_DFP, 0.0_DFP, & + 0.0_DFP, 0.0_DFP, 1.0_DFP/), (/3, 3/)) REAL(DFP), PARAMETER, DIMENSION(2, 2) :: Eye2 = RESHAPE( & - (/1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP/), (/2, 2/)) + (/1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP/), (/2, 2/)) ! Parameters for iteration data INTEGER(I4B), PARAMETER :: RelativeConvergence = 1 INTEGER(I4B), PARAMETER :: AbsoluteConvergence = 2 @@ -273,6 +273,10 @@ MODULE GlobalData INTEGER(I4B), PARAMETER :: GaussLegendre = 2 INTEGER(I4B), PARAMETER :: GaussLobatto = 3 INTEGER(I4B), PARAMETER :: Chebyshev = 4 +INTEGER(I4B), PARAMETER :: Gauss = 5 +INTEGER(I4B), PARAMETER :: GaussRadau = 6 +INTEGER(I4B), PARAMETER :: GaussRadauLeft = 7 +INTEGER(I4B), PARAMETER :: GaussRadauRight = 8 ! Type of Lagrange Interpolation Poitns INTEGER(I4B), PARAMETER :: EquidistanceLIP = Equidistance INTEGER(I4B), PARAMETER :: GaussLobattoLIP = GaussLobatto @@ -282,6 +286,10 @@ MODULE GlobalData INTEGER(I4B), PARAMETER :: GaussLegendreQP = GaussLegendre INTEGER(I4B), PARAMETER :: GaussLobattoQP = GaussLobatto INTEGER(I4B), PARAMETER :: ChebyshevQP = Chebyshev +INTEGER(I4B), PARAMETER :: GaussQP = Gauss +INTEGER(I4B), PARAMETER :: GaussRadauQP = GaussRadau +INTEGER(I4B), PARAMETER :: GaussRadauLeftQP = GaussRadauLeft +INTEGER(I4B), PARAMETER :: GaussRadauRightQP = GaussRadauRight ! Types of Elements INTEGER(I4B), PARAMETER :: Line = 1 INTEGER(I4B), PARAMETER :: Line2 = 1 @@ -493,7 +501,7 @@ MODULE GlobalData INTEGER(I4B), PARAMETER, PUBLIC :: Nodal = 1 INTEGER(I4B), PARAMETER, PUBLIC :: Quadrature = 2 -INTEGER( I4B ), PARAMETER, PUBLIC :: MAX_CHUNK_SIZE=1024 +INTEGER(I4B), PARAMETER, PUBLIC :: MAX_CHUNK_SIZE = 1024 !---------------------------------------------------------------------------- ! From d7b5f45515a4d53b380e2d3d9872eecdddc565f8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:30:21 +0900 Subject: [PATCH 04/43] :mod intvector --- src/modules/IntVector/src/ConstructorMethods.inc | 1 - 1 file changed, 1 deletion(-) diff --git a/src/modules/IntVector/src/ConstructorMethods.inc b/src/modules/IntVector/src/ConstructorMethods.inc index 815302090..06b63510f 100644 --- a/src/modules/IntVector/src/ConstructorMethods.inc +++ b/src/modules/IntVector/src/ConstructorMethods.inc @@ -418,7 +418,6 @@ INTERFACE END FUNCTION intVec_Constructor_3 END INTERFACE - INTERFACE IntVector_Pointer MODULE PROCEDURE intVec_Constructor_3 END INTERFACE IntVector_Pointer From 77c0b3b550b8ed47217448c3952ec6ad8fd8bb4f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:30:44 +0900 Subject: [PATCH 05/43] :add multiindices --- src/modules/MultiIndices/CMakeLists.txt | 22 ++ .../MultiIndices/src/MultiIndices_Method.F90 | 192 ++++++++++++++++++ src/submodules/MultiIndices/CMakeLists.txt | 22 ++ .../src/MultiIndices_Method@Methods.F90 | 96 +++++++++ 4 files changed, 332 insertions(+) create mode 100644 src/modules/MultiIndices/CMakeLists.txt create mode 100644 src/modules/MultiIndices/src/MultiIndices_Method.F90 create mode 100644 src/submodules/MultiIndices/CMakeLists.txt create mode 100644 src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 diff --git a/src/modules/MultiIndices/CMakeLists.txt b/src/modules/MultiIndices/CMakeLists.txt new file mode 100644 index 000000000..75e364bf1 --- /dev/null +++ b/src/modules/MultiIndices/CMakeLists.txt @@ -0,0 +1,22 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/MultiIndices_Method.F90 +) diff --git a/src/modules/MultiIndices/src/MultiIndices_Method.F90 b/src/modules/MultiIndices/src/MultiIndices_Method.F90 new file mode 100644 index 000000000..0346fd726 --- /dev/null +++ b/src/modules/MultiIndices/src/MultiIndices_Method.F90 @@ -0,0 +1,192 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE MultiIndices_Method +USE GlobalData +USE BaseType +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Initiate the multi indices + +INTERFACE + MODULE PURE SUBROUTINE obj_Initiate1(obj, n, d) + TYPE(MultiIndices_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), INTENT(IN) :: d + END SUBROUTINE obj_Initiate1 +END INTERFACE + +INTERFACE Initiate + MODULE PROCEDURE obj_Initiate1 +END INTERFACE Initiate + +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! MultiIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Function to construct the multi-index + +INTERFACE + MODULE PURE FUNCTION obj_MultiIndices(n, d) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), INTENT(IN) :: d + TYPE(MultiIndices_) :: ans + END FUNCTION obj_MultiIndices +END INTERFACE + +INTERFACE MultiIndices + MODULE PROCEDURE obj_MultiIndices +END INTERFACE MultiIndices + +PUBLIC :: MultiIndices + +!---------------------------------------------------------------------------- +! Deallocate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Deallocate the object + +INTERFACE + MODULE PURE SUBROUTINE obj_Deallocate(obj) + TYPE(MultiIndices_), INTENT(INOUT) :: obj + END SUBROUTINE obj_Deallocate +END INTERFACE + +INTERFACE Deallocate + MODULE PROCEDURE obj_Deallocate +END INTERFACE Deallocate + +PUBLIC :: Deallocate + +!---------------------------------------------------------------------------- +! Display@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Display the content + +INTERFACE + MODULE SUBROUTINE obj_Display(obj, msg, unitno) + TYPE(MultiIndices_), INTENT(IN) :: obj + CHARACTER(LEN=*), INTENT(IN) :: msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno + END SUBROUTINE obj_Display +END INTERFACE + +INTERFACE Display + MODULE PROCEDURE obj_Display +END INTERFACE Display + +PUBLIC :: Display + +!---------------------------------------------------------------------------- +! Size@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get the number of touples + +INTERFACE + MODULE PURE FUNCTION obj_Size1(obj) RESULT(ans) + TYPE(MultiIndices_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION obj_Size1 +END INTERFACE + +INTERFACE Size + MODULE PROCEDURE obj_Size1 +END INTERFACE Size + +PUBLIC :: Size + +!---------------------------------------------------------------------------- +! Size@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get the number of touples + +INTERFACE + MODULE PURE FUNCTION obj_Size2(obj, upto) RESULT(ans) + TYPE(MultiIndices_), INTENT(IN) :: obj + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B) :: ans + END FUNCTION obj_Size2 +END INTERFACE + +INTERFACE Size + MODULE PROCEDURE obj_Size2 +END INTERFACE Size + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices + +INTERFACE + MODULE PURE FUNCTION obj_GetMultiIndices1(obj) RESULT(ans) + TYPE(MultiIndices_), INTENT(IN) :: obj + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_GetMultiIndices1 +END INTERFACE + +INTERFACE GetMultiIndices + MODULE PROCEDURE obj_GetMultiIndices1 +END INTERFACE GetMultiIndices + +PUBLIC :: GetMultiIndices + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices + +INTERFACE + MODULE PURE FUNCTION obj_GetMultiIndices2(obj, upto) RESULT(ans) + TYPE(MultiIndices_), INTENT(IN) :: obj + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_GetMultiIndices2 +END INTERFACE + +INTERFACE GetMultiIndices + MODULE PROCEDURE obj_GetMultiIndices2 +END INTERFACE GetMultiIndices + +END MODULE MultiIndices_Method diff --git a/src/submodules/MultiIndices/CMakeLists.txt b/src/submodules/MultiIndices/CMakeLists.txt new file mode 100644 index 000000000..76b424d30 --- /dev/null +++ b/src/submodules/MultiIndices/CMakeLists.txt @@ -0,0 +1,22 @@ +# This program is a part of EASIFEM library +# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# + +SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +TARGET_SOURCES( + ${PROJECT_NAME} PRIVATE + ${src_path}/MultiIndices_Method@Methods.F90 +) diff --git a/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 b/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 new file mode 100644 index 000000000..fff8eab4d --- /dev/null +++ b/src/submodules/MultiIndices/src/MultiIndices_Method@Methods.F90 @@ -0,0 +1,96 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(MultiIndices_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate1 +obj%n = n +obj%d = d +END PROCEDURE obj_Initiate1 + +!---------------------------------------------------------------------------- +! MultiIndices +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_MultiIndices +ans%n = n +ans%d = d +END PROCEDURE obj_MultiIndices + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Deallocate +obj%n = 0 +obj%d = 0 +END PROCEDURE obj_Deallocate + +!---------------------------------------------------------------------------- +! Display +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Display +CALL Display(msg, unitno=unitno) +CALL Display(obj%n, "n = ", unitno=unitno) +CALL Display(obj%d, "d = ", unitno=unitno) +END PROCEDURE obj_Display + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Size1 +ans = INT(Binom(obj%n + obj%d, obj%d, 1.0_DFP), KIND=I4B) +END PROCEDURE obj_Size1 + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Size2 +INTEGER(I4B) :: ii +ans = 0_I4B +DO ii = 0, obj%n + ans = ans + Size(n=ii, d=obj%d) +END DO +END PROCEDURE obj_Size2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetMultiIndices1 +ans = GetMultiIndices(n=obj%n, d=obj%d) +END PROCEDURE obj_GetMultiIndices1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetMultiIndices2 +ans = GetMultiIndices(n=obj%n, d=obj%d, upto=.true.) +END PROCEDURE obj_GetMultiIndices2 + +END SUBMODULE Methods From b0b4f23373d5b4dffef958244c1ca5146762788e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:31:06 +0900 Subject: [PATCH 06/43] :mod polynomial --- src/modules/Polynomial/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index 1b614a51d..40fbacf2f 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -30,5 +30,6 @@ TARGET_SOURCES( ${src_path}/HexahedronInterpolationUtility.F90 ${src_path}/PrismInterpolationUtility.F90 ${src_path}/PyramidInterpolationUtility.F90 + ${src_path}/RecursiveNodesUtility.F90 ${src_path}/PolynomialUtility.F90 ) \ No newline at end of file From 75a2a4476a3c35ca7c873b0b9df5c12f9aa72370 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:31:18 +0900 Subject: [PATCH 07/43] :added legendre polynomial --- .../src/LegendrePolynomialUtility.F90 | 505 ++++++++++++++++++ 1 file changed, 505 insertions(+) create mode 100644 src/modules/Polynomial/src/LegendrePolynomialUtility.F90 diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 new file mode 100644 index 000000000..4ffc15d2d --- /dev/null +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -0,0 +1,505 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Utility related to Legendre Polynomials is defined. +! +!{!pages/LegendrePolynomialUtility.md!} + +MODULE LegendrePolynomialUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! GetLegendreRecurrenceCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Return the recurrence coefficient for nth order polynomial +! +!# Introduction +! +! These recurrence coefficients are for monic Legendre polynomials. + +INTERFACE + MODULE PURE SUBROUTINE GetLegendreRecurrenceCoeff(n, alpha, beta, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial, it should be greater than 1 + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) + REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) + END SUBROUTINE GetLegendreRecurrenceCoeff +END INTERFACE + +PUBLIC :: GetLegendreRecurrenceCoeff + +!---------------------------------------------------------------------------- +! LegendreLeadingCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Leading coefficient of Legendre polynomial + +INTERFACE + MODULE PURE FUNCTION LegendreLeadingCoeff(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha in Legendre poly + REAL(DFP), INTENT(IN) :: beta + !! beta in Legendre poly + REAL(DFP) :: ans + !! answer + END FUNCTION LegendreLeadingCoeff +END INTERFACE + +PUBLIC :: LegendreLeadingCoeff + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Square norm of Legendre polynomial +! +!# Introduction +! +! This function returns the following +! +!$$ +!\Vert P_{n}^{\alpha,\beta}\Vert_{d\lambda}^{2}=\int_{-1}^{+1}P_{n}^ +!{\alpha,\beta}P_{n}^{\alpha,\beta}(1-x)^{\alpha}(1+x)^{\beta}dx +!$$ + +INTERFACE + MODULE PURE FUNCTION LegendreNormSQR(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans + END FUNCTION LegendreNormSQR +END INTERFACE + +!---------------------------------------------------------------------------- +! LegendreLegendreMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE LegendreLegendreMatrix(n, alpha, beta, D, E, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: alpha + !! alpha of jacobu poly + REAL(DFP), INTENT(IN) :: beta + !! beta of Legendre poly + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE LegendreLegendreMatrix +END INTERFACE + +PUBLIC :: LegendreLegendreMatrix + +!---------------------------------------------------------------------------- +! LegendreGaussQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss quadrature points for Legendre Polynomial +! +!# Introduction +! +! This routine computes the n Gauss-Quadrature points. Which, +! are n zeros of a Legendre polynomial defined with respect to the +! weight $(1-x)^{\alpha} (1+x)^{\beta}$. +! +! All Gauss-Quadrature points are inside $(-1, 1)$ + +INTERFACE + MODULE SUBROUTINE LegendreGaussQuadrature(n, alpha, beta, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! It represents the order of Legendre polynomial + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: pt(:) + !! the size is 1 to n + REAL(DFP), INTENT(OUT) :: wt(:) + !! the size is 1 to n + END SUBROUTINE LegendreGaussQuadrature +END INTERFACE + +PUBLIC :: LegendreGaussQuadrature + +!---------------------------------------------------------------------------- +! LegendreLegendreRadauMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE LegendreLegendreRadauMatrix(a, n, alpha, beta, D, & + & E, alphaCoeff, betaCoeff) + REAL(DFP), INTENT(IN) :: a + !! one of the end of the domain + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: alpha + !! alpha of jacobu poly + REAL(DFP), INTENT(IN) :: beta + !! beta of Legendre poly + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+1 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE LegendreLegendreRadauMatrix +END INTERFACE + +PUBLIC :: LegendreLegendreRadauMatrix + +!---------------------------------------------------------------------------- +! LegendreGaussRadauQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss-Radau quadrature points for Legendre Polynomial +! +!# Introduction +! +! This routine returns the $n+1$ Quadrature points and weights. +! +! The Gauss-Radau quadrature points consists one of the end points denoted +! by $a$. So $a$ can be $\pm 1$. The remaining $n$ points are internal to +! to $(-1, +1)$, and they are n-zeros of Legendre polynomial of order n with +! respect to the following weight. +! +!- $(1-x)^{\alpha} (1+x)^{\beta} (x+1)$ if $a=-1$. +!- $(1-x)^{\alpha} (1+x)^{\beta} (1-x)$ if $a=+1$. +! +! Here n is the order of Legendre polynomial. +! +! If $a=1$ then n+1 quadrature point will be +1 +! If $a=-1$ then 1st quadrature point will be -1 + +INTERFACE + MODULE SUBROUTINE LegendreGaussRadauQuadrature(a, n, alpha, beta, pt, wt) + REAL(DFP), INTENT(IN) :: a + !! the value of one of the end points + !! it should be either -1 or +1 + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Legendre polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Legendre polynomial + REAL(DFP), INTENT(OUT) :: pt(:) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), INTENT(OUT) :: wt(:) + !! n+1 weights from 1 to n+1 + END SUBROUTINE LegendreGaussRadauQuadrature +END INTERFACE + +PUBLIC :: LegendreGaussRadauQuadrature + +!---------------------------------------------------------------------------- +! LegendreLegendreLobattoMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE LegendreLegendreLobattoMatrix(n, alpha, beta, D, & + & E, alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: alpha + !! alpha of jacobu poly + REAL(DFP), INTENT(IN) :: beta + !! beta of Legendre poly + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+2 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE LegendreLegendreLobattoMatrix +END INTERFACE + +PUBLIC :: LegendreLegendreLobattoMatrix + +!---------------------------------------------------------------------------- +! LegendreGaussLobattoQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss-Lobatto quadrature points for Legendre Polynomial +! +!# Introduction +! +! This routine returns the $n+2$ Quadrature points and weights. +! +! The Gauss-Lobatto quadrature points consists both $\pm 1$ as +! quadrature points. +! +!- The first quadrature point is $-1$ +!- The second quadrature point is $+1$ +! +! The remaining $n$ points are internal to +! to $(-1, +1)$, and they are n-zeros of Legendre polynomial of order n with +! respect to the following weight. +! +!$$(1-x)^{\alpha} (1+x)^{\beta} (x+1)(1-x)$$ +! +! Here n is the order of Legendre polynomial. + +INTERFACE + MODULE SUBROUTINE LegendreGaussLobattoQuadrature(n, alpha, beta, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomials + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: pt(:) + !! n+2 quad points indexed from 1 to n+2 + REAL(DFP), INTENT(OUT) :: wt(:) + !! n+2 weights, index from 1 to n+2 + END SUBROUTINE LegendreGaussLobattoQuadrature +END INTERFACE + +PUBLIC :: LegendreGaussLobattoQuadrature + +!---------------------------------------------------------------------------- +! LegendreZeros +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Returns zeros of Legendre polynomials + +INTERFACE + MODULE FUNCTION LegendreZeros(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans(n) + END FUNCTION LegendreZeros +END INTERFACE + +PUBLIC :: LegendreZeros + +!---------------------------------------------------------------------------- +! LegendreQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: This routine can return Legendre-Gauss, Legendre-Radau, Legendre-Lobatto +! +!# Introduction +! +! This routine returns the Quadrature point of Legendre polynomial +! +!@note +! Here n is the number of quadrature points. Please note it is not +! the order of Legendre polynomial. The order is decided internally +! depending upon the quadType +!@endnote +! +!@note +! pt and wt should be allocated outside, and length should be n. +!@endnote +! + +INTERFACE + MODULE SUBROUTINE LegendreQuadrature(n, alpha, beta, pt, wt, quadType) + INTEGER(I4B), INTENT(IN) :: n + !! number of quadrature points, the order will be computed as follows + !! for quadType = Gauss, n is same as order of Legendre polynomial + !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 + !! for quadType = GaussLobatto, n = order+2 + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Legendre polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Legendre polynomial + REAL(DFP), INTENT(OUT) :: pt(n) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), INTENT(OUT) :: wt(n) + !! n+1 weights from 1 to n+1 + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss + !! GaussRadauLeft + !! GaussRadauRight + !! GaussLobatto + END SUBROUTINE LegendreQuadrature +END INTERFACE + +PUBLIC :: LegendreQuadrature + +!---------------------------------------------------------------------------- +! LegendreEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Legendre polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Legendre polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Legendre polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LegendreEvalAll1(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(n + 1) + !! Evaluate Legendre polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LegendreEvalAll1 +END INTERFACE + +INTERFACE LegendreEvalAll + MODULE PROCEDURE LegendreEvalAll1 +END INTERFACE LegendreEvalAll + +PUBLIC :: LegendreEvalAll + +!---------------------------------------------------------------------------- +! LegendreEvalUpto +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Legendre polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Legendre polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Legendre polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LegendreEvalAll2(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Legendre polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LegendreEvalAll2 +END INTERFACE + +INTERFACE LegendreEvalAll + MODULE PROCEDURE LegendreEvalAll2 +END INTERFACE LegendreEvalAll + +!---------------------------------------------------------------------------- +! LegendreEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Legendre polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Legendre polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Legendre polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LegendreEval1(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreEval1 +END INTERFACE + +INTERFACE LegendreEval + MODULE PROCEDURE LegendreEval1 +END INTERFACE LegendreEval + +PUBLIC :: LegendreEval + +!---------------------------------------------------------------------------- +! LegendreEvalUpto +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Legendre polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Legendre polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Legendre polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LegendreEval2(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreEval2 +END INTERFACE + +INTERFACE LegendreEval + MODULE PROCEDURE LegendreEval2 +END INTERFACE LegendreEval + +END MODULE LegendrePolynomialUtility From 2055e5f97789d7dd62a3aa04b0a5cb7fb1c07ee1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:31:31 +0900 Subject: [PATCH 08/43] :added recursive nodes --- .../Polynomial/src/RecursiveNodesUtility.F90 | 186 ++++++++++++++++++ 1 file changed, 186 insertions(+) create mode 100644 src/modules/Polynomial/src/RecursiveNodesUtility.F90 diff --git a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 new file mode 100644 index 000000000..fa9da6f75 --- /dev/null +++ b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 @@ -0,0 +1,186 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE RecursiveNodesUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! RecursiveNode1D +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Convert nodal coordinates to barycentric coordinates + +INTERFACE + MODULE PURE FUNCTION RecursiveNode1D(order, ipType, domain) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order >= 0 + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 2 corresponding to b0 and b1 + !! size(ans,2) total number of points + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: domain + !! unit (0,1) + !! biunit (-1, 1) + !! equilateral + END FUNCTION RecursiveNode1D +END INTERFACE + +PUBLIC :: RecursiveNode1D + +!---------------------------------------------------------------------------- +! RecursiveNode2D +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Convert nodal coordinates to barycentric coordinates + +INTERFACE + MODULE PURE FUNCTION RecursiveNode2D(order, ipType, domain) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order >= 0 + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 3 corresponding to b0, b1, b2 + !! size(ans,2) total number of points + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: domain + !! unit + !! Biunit + !! Equilateral + END FUNCTION RecursiveNode2D +END INTERFACE + +PUBLIC :: RecursiveNode2D + +!---------------------------------------------------------------------------- +! RecursiveNode3D +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Convert nodal coordinates to barycentric coordinates + +INTERFACE + MODULE PURE FUNCTION RecursiveNode3D(order, ipType, & + & domain) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order >= 0 + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance + !! LobattoGaussJacobi + !! LobattoGaussChebyshev + !! LobattoGaussGegenbauer + !! GaussJacobi + !! GaussChebyshev + !! GaussGegenbauer + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! barycentric coordinates, in xiJ format + !! size(ans,1) = 4 corresponding to b0, b1, b2, b3 + !! size(ans,2) total number of points + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: domain + !! unit + !! Biunit + !! Equilateral + END FUNCTION RecursiveNode3D +END INTERFACE + +PUBLIC :: RecursiveNode3D + +!---------------------------------------------------------------------------- +! ToUnit +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION ToUnit(x, domain) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:, :) + CHARACTER(LEN=*), INTENT(IN) :: domain + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION ToUnit +END INTERFACE + +!---------------------------------------------------------------------------- +! ToUnit +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION FromUnit(x, domain) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:, :) + CHARACTER(LEN=*), INTENT(IN) :: domain + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION FromUnit +END INTERFACE + +!---------------------------------------------------------------------------- +! ToUnit +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE Unit2Equilateral(d, x) + INTEGER(I4B), INTENT(IN) :: d + REAL(DFP), INTENT(INOUT) :: x(:, :) + END SUBROUTINE Unit2Equilateral +END INTERFACE + +!---------------------------------------------------------------------------- +! ToUnit +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE Equilateral2Unit(d, x) + INTEGER(I4B), INTENT(IN) :: d + REAL(DFP), INTENT(INOUT) :: x(:, :) + END SUBROUTINE Equilateral2Unit +END INTERFACE + +!---------------------------------------------------------------------------- +! Coord_Map +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Coord_Map(x, from, to) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:, :) + CHARACTER(LEN=*), INTENT(IN) :: from + CHARACTER(LEN=*), INTENT(IN) :: to + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION Coord_Map +END INTERFACE + +END MODULE RecursiveNodesUtility From ea0081e3eeeb04b83a5c777e8430dc3a86777731 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:31:42 +0900 Subject: [PATCH 09/43] :mod jacobi polynomials --- .../src/JacobiPolynomialUtility.F90 | 373 +++++++++++++----- 1 file changed, 285 insertions(+), 88 deletions(-) diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index c923670f3..03f14b9d9 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -39,15 +39,15 @@ MODULE JacobiPolynomialUtility ! These recurrence coefficients are for monic jacobi polynomials. INTERFACE -MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff( n, alpha, beta, alphaCoeff, & - & betaCoeff ) - INTEGER( I4B ), INTENT( IN ) :: n + MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff(n, alpha, beta, alphaCoeff, & + & betaCoeff) + INTEGER(I4B), INTENT(IN) :: n !! order of jacobi polynomial, it should be greater than 1 - REAL( DFP ), INTENT( IN ) :: alpha - REAL( DFP ), INTENT( IN ) :: beta - REAL( DFP ), INTENT( OUT ) :: alphaCoeff(0:n-1) - REAL( DFP ), INTENT( OUT ) :: betaCoeff(0:n-1) -END SUBROUTINE GetJacobiRecurrenceCoeff + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) + REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) + END SUBROUTINE GetJacobiRecurrenceCoeff END INTERFACE PUBLIC :: GetJacobiRecurrenceCoeff @@ -61,16 +61,16 @@ END SUBROUTINE GetJacobiRecurrenceCoeff ! summary: Leading coefficient of Jacobi polynomial INTERFACE -MODULE PURE FUNCTION JacobiLeadingCoeff( n, alpha, beta ) RESULT( ans ) - INTEGER( I4B ), INTENT( IN ) :: n + MODULE PURE FUNCTION JacobiLeadingCoeff(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n !! order of Jacobi polynomial - REAL( DFP ), INTENT( IN ) :: alpha + REAL(DFP), INTENT(IN) :: alpha !! alpha in Jacobi poly - REAL( DFP ), INTENT( IN ) :: beta + REAL(DFP), INTENT(IN) :: beta !! beta in Jacobi poly - REAL( DFP ) :: ans + REAL(DFP) :: ans !! answer -END FUNCTION JacobiLeadingCoeff + END FUNCTION JacobiLeadingCoeff END INTERFACE PUBLIC :: JacobiLeadingCoeff @@ -93,12 +93,12 @@ END FUNCTION JacobiLeadingCoeff !$$ INTERFACE -MODULE PURE FUNCTION JacobiNormSQR( n, alpha, beta ) RESULT( ans ) - INTEGER( I4B ), INTENT( IN ) :: n - REAL( DFP ), INTENT( IN ) :: alpha - REAL( DFP ), INTENT( IN ) :: beta - REAL( DFP ) :: ans -END FUNCTION JacobiNormSQR + MODULE PURE FUNCTION JacobiNormSQR(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans + END FUNCTION JacobiNormSQR END INTERFACE !---------------------------------------------------------------------------- @@ -106,21 +106,21 @@ END FUNCTION JacobiNormSQR !---------------------------------------------------------------------------- INTERFACE -MODULE PURE SUBROUTINE JacobiJacobiMatrix( n, alpha, beta, D, E, & - & alphaCoeff, betaCoeff ) - INTEGER( I4B ), INTENT( IN ) :: n + MODULE PURE SUBROUTINE JacobiJacobiMatrix(n, alpha, beta, D, E, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n !! n should be greater than or equal to 1 - REAL( DFP ), INTENT( IN ) :: alpha + REAL(DFP), INTENT(IN) :: alpha !! alpha of jacobu poly - REAL( DFP ), INTENT( IN ) :: beta + REAL(DFP), INTENT(IN) :: beta !! beta of jacobi poly - REAL( DFP ), INTENT( OUT ) :: D( : ) + REAL(DFP), INTENT(OUT) :: D(:) !! the size should be 1:n - REAL( DFP ), INTENT( OUT ) :: E( : ) + REAL(DFP), INTENT(OUT) :: E(:) !! the size should be 1:n-1 - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: alphaCoeff( 0: ) - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: betaCoeff( 0: ) -END SUBROUTINE JacobiJacobiMatrix + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE JacobiJacobiMatrix END INTERFACE PUBLIC :: JacobiJacobiMatrix @@ -131,7 +131,7 @@ END SUBROUTINE JacobiJacobiMatrix !> author: Vikas Sharma, Ph. D. ! date: 3 Aug 2022 -! summary: Returns the Gauss quadrature points for Jacobi Polynomial +! summary: Returns the Gauss quadrature points for Jacobi Polynomial ! !# Introduction ! @@ -142,15 +142,16 @@ END SUBROUTINE JacobiJacobiMatrix ! All Gauss-Quadrature points are inside $(-1, 1)$ INTERFACE -MODULE SUBROUTINE JacobiGaussQuadrature( n, alpha, beta, pt, wt ) - INTEGER( I4B ), INTENT( IN ) :: n - REAL( DFP ), INTENT( IN ) :: alpha - REAL( DFP ), INTENT( IN ) :: beta - REAL( DFP ), INTENT( OUT ) :: pt(:) + MODULE SUBROUTINE JacobiGaussQuadrature(n, alpha, beta, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! It represents the order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: pt(:) !! the size is 1 to n - REAL( DFP ), INTENT( OUT ) :: wt(:) + REAL(DFP), INTENT(OUT) :: wt(:) !! the size is 1 to n -END SUBROUTINE JacobiGaussQuadrature + END SUBROUTINE JacobiGaussQuadrature END INTERFACE PUBLIC :: JacobiGaussQuadrature @@ -160,23 +161,23 @@ END SUBROUTINE JacobiGaussQuadrature !---------------------------------------------------------------------------- INTERFACE -MODULE PURE SUBROUTINE JacobiJacobiRadauMatrix( a, n, alpha, beta, D, & - & E, alphaCoeff, betaCoeff ) - REAL( DFP ), INTENT( IN ) :: a + MODULE PURE SUBROUTINE JacobiJacobiRadauMatrix(a, n, alpha, beta, D, & + & E, alphaCoeff, betaCoeff) + REAL(DFP), INTENT(IN) :: a !! one of the end of the domain - INTEGER( I4B ), INTENT( IN ) :: n + INTEGER(I4B), INTENT(IN) :: n !! n should be greater than or equal to 1 - REAL( DFP ), INTENT( IN ) :: alpha + REAL(DFP), INTENT(IN) :: alpha !! alpha of jacobu poly - REAL( DFP ), INTENT( IN ) :: beta + REAL(DFP), INTENT(IN) :: beta !! beta of jacobi poly - REAL( DFP ), INTENT( OUT ) :: D( : ) + REAL(DFP), INTENT(OUT) :: D(:) !! the size should be 1:n+1 - REAL( DFP ), INTENT( OUT ) :: E( : ) + REAL(DFP), INTENT(OUT) :: E(:) !! the size should be 1:n - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: alphaCoeff( 0: ) - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: betaCoeff( 0: ) -END SUBROUTINE JacobiJacobiRadauMatrix + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE JacobiJacobiRadauMatrix END INTERFACE PUBLIC :: JacobiJacobiRadauMatrix @@ -187,7 +188,7 @@ END SUBROUTINE JacobiJacobiRadauMatrix !> author: Vikas Sharma, Ph. D. ! date: 3 Aug 2022 -! summary: Returns the Gauss-Radau quadrature points for Jacobi Polynomial +! summary: Returns the Gauss-Radau quadrature points for Jacobi Polynomial ! !# Introduction ! @@ -207,21 +208,21 @@ END SUBROUTINE JacobiJacobiRadauMatrix ! If $a=-1$ then 1st quadrature point will be -1 INTERFACE -MODULE SUBROUTINE JacobiGaussRadauQuadrature( a, n, alpha, beta, pt, wt ) - REAL( DFP ), INTENT( IN ) :: a - !! the value of one of the end points - !! it should be either -1 or +1 - INTEGER( I4B ), INTENT( IN ) :: n - !! order of jacobi polynomial - REAL( DFP ), INTENT( IN ) :: alpha - !! alpha of Jacobi polynomial - REAL( DFP ), INTENT( IN ) :: beta - !! beta of Jacobi polynomial - REAL( DFP ), INTENT( OUT ) :: pt(:) + MODULE SUBROUTINE JacobiGaussRadauQuadrature(a, n, alpha, beta, pt, wt) + REAL(DFP), INTENT(IN) :: a + !! the value of one of the end points + !! it should be either -1 or +1 + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial + REAL(DFP), INTENT(OUT) :: pt(:) !! n+1 quadrature points from 1 to n+1 - REAL( DFP ), INTENT( OUT ) :: wt(:) + REAL(DFP), INTENT(OUT) :: wt(:) !! n+1 weights from 1 to n+1 -END SUBROUTINE JacobiGaussRadauQuadrature + END SUBROUTINE JacobiGaussRadauQuadrature END INTERFACE PUBLIC :: JacobiGaussRadauQuadrature @@ -231,21 +232,21 @@ END SUBROUTINE JacobiGaussRadauQuadrature !---------------------------------------------------------------------------- INTERFACE -MODULE PURE SUBROUTINE JacobiJacobiLobattoMatrix( n, alpha, beta, D, & - & E, alphaCoeff, betaCoeff ) - INTEGER( I4B ), INTENT( IN ) :: n + MODULE PURE SUBROUTINE JacobiJacobiLobattoMatrix(n, alpha, beta, D, & + & E, alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n !! n should be greater than or equal to 1 - REAL( DFP ), INTENT( IN ) :: alpha + REAL(DFP), INTENT(IN) :: alpha !! alpha of jacobu poly - REAL( DFP ), INTENT( IN ) :: beta + REAL(DFP), INTENT(IN) :: beta !! beta of jacobi poly - REAL( DFP ), INTENT( OUT ) :: D( : ) + REAL(DFP), INTENT(OUT) :: D(:) !! the size should be 1:n+2 - REAL( DFP ), INTENT( OUT ) :: E( : ) + REAL(DFP), INTENT(OUT) :: E(:) !! the size should be 1:n+1 - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: alphaCoeff( 0: ) - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: betaCoeff( 0: ) -END SUBROUTINE JacobiJacobiLobattoMatrix + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE JacobiJacobiLobattoMatrix END INTERFACE PUBLIC :: JacobiJacobiLobattoMatrix @@ -256,7 +257,7 @@ END SUBROUTINE JacobiJacobiLobattoMatrix !> author: Vikas Sharma, Ph. D. ! date: 3 Aug 2022 -! summary: Returns the Gauss-Lobatto quadrature points for Jacobi Polynomial +! summary: Returns the Gauss-Lobatto quadrature points for Jacobi Polynomial ! !# Introduction ! @@ -277,15 +278,16 @@ END SUBROUTINE JacobiJacobiLobattoMatrix ! Here n is the order of Jacobi polynomial. INTERFACE -MODULE SUBROUTINE JacobiGaussLobattoQuadrature( n, alpha, beta, pt, wt ) - INTEGER( I4B ), INTENT( IN ) :: n - REAL( DFP ), INTENT( IN ) :: alpha - REAL( DFP ), INTENT( IN ) :: beta - REAL( DFP ), INTENT( OUT ) :: pt(:) + MODULE SUBROUTINE JacobiGaussLobattoQuadrature(n, alpha, beta, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomials + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: pt(:) !! n+2 quad points indexed from 1 to n+2 - REAL( DFP ), INTENT( OUT ) :: wt(:) + REAL(DFP), INTENT(OUT) :: wt(:) !! n+2 weights, index from 1 to n+2 -END SUBROUTINE JacobiGaussLobattoQuadrature + END SUBROUTINE JacobiGaussLobattoQuadrature END INTERFACE PUBLIC :: JacobiGaussLobattoQuadrature @@ -294,15 +296,210 @@ END SUBROUTINE JacobiGaussLobattoQuadrature ! JacobiZeros !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Returns zeros of Jacobi polynomials + INTERFACE -MODULE FUNCTION JacobiZeros( n, alpha, beta ) RESULT( ans ) - INTEGER( I4B ), INTENT( IN ) :: n - REAL( DFP ), INTENT( IN ) :: alpha - REAL( DFP ), INTENT( IN ) :: beta - REAL( DFP ) :: ans( n ) -END FUNCTION JacobiZeros + MODULE FUNCTION JacobiZeros(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans(n) + END FUNCTION JacobiZeros END INTERFACE PUBLIC :: JacobiZeros -END MODULE JacobiPolynomialUtility \ No newline at end of file +!---------------------------------------------------------------------------- +! JacobiQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: This routine can return Jacobi-Gauss, Jacobi-Radau, Jacobi-Lobatto +! +!# Introduction +! +! This routine returns the Quadrature point of Jacobi polynomial +! +!@note +! Here n is the number of quadrature points. Please note it is not +! the order of jacobi polynomial. The order is decided internally +! depending upon the quadType +!@endnote +! +!@note +! pt and wt should be allocated outside, and length should be n. +!@endnote +! + +INTERFACE + MODULE SUBROUTINE JacobiQuadrature(n, alpha, beta, pt, wt, quadType) + INTEGER(I4B), INTENT(IN) :: n + !! number of quadrature points, the order will be computed as follows + !! for quadType = Gauss, n is same as order of Jacobi polynomial + !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 + !! for quadType = GaussLobatto, n = order+2 + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial + REAL(DFP), INTENT(OUT) :: pt(n) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), INTENT(OUT) :: wt(n) + !! n+1 weights from 1 to n+1 + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss + !! GaussRadauLeft + !! GaussRadauRight + !! GaussLobatto + END SUBROUTINE JacobiQuadrature +END INTERFACE + +PUBLIC :: JacobiQuadrature + +!---------------------------------------------------------------------------- +! JacobiEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Jacobi polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Jacobi polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Jacobi polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION JacobiEvalAll1(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(n + 1) + !! Evaluate Jacobi polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION JacobiEvalAll1 +END INTERFACE + +INTERFACE JacobiEvalAll + MODULE PROCEDURE JacobiEvalAll1 +END INTERFACE JacobiEvalAll + +PUBLIC :: JacobiEvalAll + +!---------------------------------------------------------------------------- +! JacobiEvalUpto +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Jacobi polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Jacobi polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Jacobi polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION JacobiEvalAll2(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Jacobi polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION JacobiEvalAll2 +END INTERFACE + +INTERFACE JacobiEvalAll + MODULE PROCEDURE JacobiEvalAll2 +END INTERFACE JacobiEvalAll + +!---------------------------------------------------------------------------- +! JacobiEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Jacobi polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Jacobi polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Jacobi polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION JacobiEval1(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiEval1 +END INTERFACE + +INTERFACE JacobiEval + MODULE PROCEDURE JacobiEval1 +END INTERFACE JacobiEval + +PUBLIC :: JacobiEval + +!---------------------------------------------------------------------------- +! JacobiEvalUpto +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Jacobi polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Jacobi polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Jacobi polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION JacobiEval2(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiEval2 +END INTERFACE + +INTERFACE JacobiEval + MODULE PROCEDURE JacobiEval2 +END INTERFACE JacobiEval + +END MODULE JacobiPolynomialUtility From ff9865dbf34414a190376a4f59de87b4c3bd156b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:31:51 +0900 Subject: [PATCH 10/43] :modified line interpolation --- .../src/LineInterpolationUtility.F90 | 43 ++++++++++++++++++- 1 file changed, 41 insertions(+), 2 deletions(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index 8781d39c0..d2ae795e6 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -227,7 +227,7 @@ END FUNCTION EquidistancePoint_Line2 ! summary: Returns the interpolation point INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Line(order, ipType, xij) & + MODULE PURE FUNCTION InterpolationPoint_Line1(order, ipType, xij) & & RESULT(ans) !! INTEGER(I4B), INTENT(IN) :: order @@ -235,11 +235,50 @@ MODULE PURE FUNCTION InterpolationPoint_Line(order, ipType, xij) & REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) REAL(DFP), ALLOCATABLE :: ans(:, :) !! - END FUNCTION InterpolationPoint_Line + END FUNCTION InterpolationPoint_Line1 END INTERFACE +INTERFACE InterpolationPoint_Line + MODULE PROCEDURE InterpolationPoint_Line1 +END INTERFACE InterpolationPoint_Line + PUBLIC :: InterpolationPoint_Line +!---------------------------------------------------------------------------- +! InterpolationPoint_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Aug 2022 +! summary: Returns the interpolation point + +INTERFACE + MODULE PURE FUNCTION InterpolationPoint_Line2(order, ipType, xij) & + & RESULT(ans) + !! + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation nodes type: + !! Equidistance + !! LobattoGaussLegendre + !! LobattoGaussChebyshev + !! LobattoGaussJacobi + !! LobattoGaussGegenbauer + !! GaussLegendre + !! GaussChebyshev + !! GaussJacobi + !! GaussGegenbauer + REAL(DFP), INTENT(IN) :: xij(2) + !! end points + REAL(DFP), ALLOCATABLE :: ans(:) + !! + END FUNCTION InterpolationPoint_Line2 +END INTERFACE + +INTERFACE InterpolationPoint_Line + MODULE PROCEDURE InterpolationPoint_Line2 +END INTERFACE InterpolationPoint_Line + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From 40def95209c82e917aee4e9ed106b563f31c975b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:32:08 +0900 Subject: [PATCH 11/43] :mod polynomial utility --- src/modules/Polynomial/src/PolynomialUtility.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/Polynomial/src/PolynomialUtility.F90 b/src/modules/Polynomial/src/PolynomialUtility.F90 index 91cf6437c..1779d2d06 100644 --- a/src/modules/Polynomial/src/PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/PolynomialUtility.F90 @@ -28,4 +28,5 @@ MODULE PolynomialUtility USE HexahedronInterpolationUtility USE PrismInterpolationUtility USE PyramidInterpolationUtility +USE RecursiveNodesUtility END MODULE PolynomialUtility From 33e67d92c43f592dd659ec747252da7857d166b9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:32:18 +0900 Subject: [PATCH 12/43] :mod utility --- src/modules/Utility/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/Utility/CMakeLists.txt b/src/modules/Utility/CMakeLists.txt index 016329fa8..bf3b28bf9 100644 --- a/src/modules/Utility/CMakeLists.txt +++ b/src/modules/Utility/CMakeLists.txt @@ -40,5 +40,6 @@ TARGET_SOURCES( ${src_path}/SwapUtility.F90 ${src_path}/ConvertUtility.F90 ${src_path}/IntegerUtility.F90 + ${src_path}/PushPopUtility.F90 ${src_path}/Utility.F90 ) \ No newline at end of file From 12bc9df23468fff3f6ed911161340ed40e7e53ed Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:32:29 +0900 Subject: [PATCH 13/43] :added push pop utility --- src/modules/Utility/src/PushPopUtility.F90 | 272 +++++++++++++++++++++ 1 file changed, 272 insertions(+) create mode 100644 src/modules/Utility/src/PushPopUtility.F90 diff --git a/src/modules/Utility/src/PushPopUtility.F90 b/src/modules/Utility/src/PushPopUtility.F90 new file mode 100644 index 000000000..3738796ec --- /dev/null +++ b/src/modules/Utility/src/PushPopUtility.F90 @@ -0,0 +1,272 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE PushPopUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: Push +PUBLIC :: Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_int8(vec, pos, value) RESULT(ans) + INTEGER(Int8), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int8), INTENT(IN) :: value + INTEGER(Int8) :: ans(SIZE(vec) + 1) + END FUNCTION push_int8 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_int8 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_int16(vec, pos, value) RESULT(ans) + INTEGER(Int16), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int16), INTENT(IN) :: value + INTEGER(Int16) :: ans(SIZE(vec) + 1) + END FUNCTION push_int16 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_int16 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_int32(vec, pos, value) RESULT(ans) + INTEGER(Int32), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int32), INTENT(IN) :: value + INTEGER(Int32) :: ans(SIZE(vec) + 1) + END FUNCTION push_int32 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_int32 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_int64(vec, pos, value) RESULT(ans) + INTEGER(Int64), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int64), INTENT(IN) :: value + INTEGER(Int64) :: ans(SIZE(vec) + 1) + END FUNCTION push_int64 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_int64 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_real32(vec, pos, value) RESULT(ans) + REAL(Real32), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + REAL(Real32), INTENT(IN) :: value + REAL(Real32) :: ans(SIZE(vec) + 1) + END FUNCTION push_real32 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_real32 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Push a value + +INTERFACE + MODULE PURE FUNCTION push_real64(vec, pos, value) RESULT(ans) + REAL(Real64), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + REAL(Real64), INTENT(IN) :: value + REAL(Real64) :: ans(SIZE(vec) + 1) + END FUNCTION push_real64 +END INTERFACE + +INTERFACE Push + MODULE PROCEDURE push_real64 +END INTERFACE Push + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_int8(vec, pos) RESULT(ans) + INTEGER(Int8), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int8) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_int8 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_int8 +END INTERFACE Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_int16(vec, pos) RESULT(ans) + INTEGER(Int16), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int16) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_int16 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_int16 +END INTERFACE Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_int32(vec, pos) RESULT(ans) + INTEGER(Int32), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int32) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_int32 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_int32 +END INTERFACE Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_int64(vec, pos) RESULT(ans) + INTEGER(Int64), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + INTEGER(Int64) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_int64 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_int64 +END INTERFACE Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_real32(vec, pos) RESULT(ans) + REAL(Real32), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + REAL(Real32) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_real32 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_real32 +END INTERFACE Pop + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 5 Sept 2022 +! summary: Pop a value + +INTERFACE + MODULE PURE FUNCTION Pop_real64(vec, pos) RESULT(ans) + REAL(Real64), INTENT(IN) :: vec(:) + INTEGER(I4B), INTENT(IN) :: pos + REAL(Real64) :: ans(MAX(SIZE(vec) - 1, 0)) + END FUNCTION Pop_real64 +END INTERFACE + +INTERFACE Pop + MODULE PROCEDURE Pop_real64 +END INTERFACE Pop + +END MODULE PushPopUtility From 205e6aa1ea5f43ca6d401741a0fe13ac8a7dc91a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:32:50 +0900 Subject: [PATCH 14/43] :mod binom utility --- src/modules/Utility/src/BinomUtility.F90 | 102 +++++++++++------------ 1 file changed, 51 insertions(+), 51 deletions(-) diff --git a/src/modules/Utility/src/BinomUtility.F90 b/src/modules/Utility/src/BinomUtility.F90 index 446913bae..255ec146b 100644 --- a/src/modules/Utility/src/BinomUtility.F90 +++ b/src/modules/Utility/src/BinomUtility.F90 @@ -26,8 +26,8 @@ MODULE BinomUtility !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 -! summary: Compute the Binomial coefficient +! date: 2 Aug 2022 +! summary: Compute the Binomial coefficient ! !# Introduction ! @@ -43,13 +43,13 @@ MODULE BinomUtility !``` INTERFACE -MODULE RECURSIVE FUNCTION Real32_Binom_Int8( n, k, kind ) RESULT( ans ) - INTEGER( Int8 ), INTENT( IN ) :: n + MODULE PURE FUNCTION Real32_Binom_Int8(n, k, kind) RESULT(ans) + INTEGER(Int8), INTENT(IN) :: n !! n is integer, should be a positive number and greater or equal to k - INTEGER( Int8 ), INTENT( IN ) :: k - REAL( Real32 ) :: kind - REAL( Real32 ) :: ans -END FUNCTION Real32_Binom_Int8 + INTEGER(Int8), INTENT(IN) :: k + REAL(Real32), INTENT(IN) :: kind + REAL(Real32) :: ans + END FUNCTION Real32_Binom_Int8 END INTERFACE !---------------------------------------------------------------------------- @@ -57,12 +57,12 @@ END FUNCTION Real32_Binom_Int8 !---------------------------------------------------------------------------- INTERFACE -MODULE RECURSIVE FUNCTION Real32_Binom_Int16( n, k, kind ) RESULT( ans ) - INTEGER( Int16 ), INTENT( IN ) :: n - INTEGER( Int16 ), INTENT( IN ) :: k - REAL( Real32 ) :: kind - REAL( Real32 ) :: ans -END FUNCTION Real32_Binom_Int16 + MODULE PURE FUNCTION Real32_Binom_Int16(n, k, kind) RESULT(ans) + INTEGER(Int16), INTENT(IN) :: n + INTEGER(Int16), INTENT(IN) :: k + REAL(Real32), INTENT(IN) :: kind + REAL(Real32) :: ans + END FUNCTION Real32_Binom_Int16 END INTERFACE !---------------------------------------------------------------------------- @@ -70,19 +70,19 @@ END FUNCTION Real32_Binom_Int16 !---------------------------------------------------------------------------- INTERFACE -MODULE RECURSIVE FUNCTION Real32_Binom_Int32( n, k, kind ) RESULT( ans ) - INTEGER( Int32 ), INTENT( IN ) :: n - INTEGER( Int32 ), INTENT( IN ) :: k - REAL( Real32 ) :: kind - REAL( Real32 ) :: ans -END FUNCTION Real32_Binom_Int32 + MODULE PURE FUNCTION Real32_Binom_Int32(n, k, kind) RESULT(ans) + INTEGER(Int32), INTENT(IN) :: n + INTEGER(Int32), INTENT(IN) :: k + REAL(Real32), INTENT(IN) :: kind + REAL(Real32) :: ans + END FUNCTION Real32_Binom_Int32 !! -MODULE RECURSIVE FUNCTION Real32_Binom_Int64( n, k, kind ) RESULT( ans ) - INTEGER( Int64 ), INTENT( IN ) :: n - INTEGER( Int64 ), INTENT( IN ) :: k - REAL( Real32 ) :: kind - REAL( Real32 ) :: ans -END FUNCTION Real32_Binom_Int64 + MODULE PURE FUNCTION Real32_Binom_Int64(n, k, kind) RESULT(ans) + INTEGER(Int64), INTENT(IN) :: n + INTEGER(Int64), INTENT(IN) :: k + REAL(Real32), INTENT(IN) :: kind + REAL(Real32) :: ans + END FUNCTION Real32_Binom_Int64 END INTERFACE INTERFACE Binom @@ -95,33 +95,33 @@ END FUNCTION Real32_Binom_Int64 !---------------------------------------------------------------------------- INTERFACE -MODULE RECURSIVE FUNCTION Real64_Binom_Int8( n, k, kind ) RESULT( ans ) - INTEGER( Int8 ), INTENT( IN ) :: n - INTEGER( Int8 ), INTENT( IN ) :: k - REAL( Real64 ) :: kind - REAL( Real64 ) :: ans -END FUNCTION Real64_Binom_Int8 + MODULE PURE FUNCTION Real64_Binom_Int8(n, k, kind) RESULT(ans) + INTEGER(Int8), INTENT(IN) :: n + INTEGER(Int8), INTENT(IN) :: k + REAL(Real64), INTENT(IN) :: kind + REAL(Real64) :: ans + END FUNCTION Real64_Binom_Int8 !! -MODULE RECURSIVE FUNCTION Real64_Binom_Int16( n, k, kind ) RESULT( ans ) - INTEGER( Int16 ), INTENT( IN ) :: n - INTEGER( Int16 ), INTENT( IN ) :: k - REAL( Real64 ) :: kind - REAL( Real64 ) :: ans -END FUNCTION Real64_Binom_Int16 + MODULE PURE FUNCTION Real64_Binom_Int16(n, k, kind) RESULT(ans) + INTEGER(Int16), INTENT(IN) :: n + INTEGER(Int16), INTENT(IN) :: k + REAL(Real64), INTENT(IN) :: kind + REAL(Real64) :: ans + END FUNCTION Real64_Binom_Int16 !! -MODULE RECURSIVE FUNCTION Real64_Binom_Int32( n, k, kind ) RESULT( ans ) - INTEGER( Int32 ), INTENT( IN ) :: n - INTEGER( Int32 ), INTENT( IN ) :: k - REAL( Real64 ) :: kind - REAL( Real64 ) :: ans -END FUNCTION Real64_Binom_Int32 + MODULE PURE FUNCTION Real64_Binom_Int32(n, k, kind) RESULT(ans) + INTEGER(Int32), INTENT(IN) :: n + INTEGER(Int32), INTENT(IN) :: k + REAL(Real64), INTENT(IN) :: kind + REAL(Real64) :: ans + END FUNCTION Real64_Binom_Int32 !! -MODULE RECURSIVE FUNCTION Real64_Binom_Int64( n, k, kind ) RESULT( ans ) - INTEGER( Int64 ), INTENT( IN ) :: n - INTEGER( Int64 ), INTENT( IN ) :: k - REAL( Real64 ) :: kind - REAL( Real64 ) :: ans -END FUNCTION Real64_Binom_Int64 + MODULE PURE FUNCTION Real64_Binom_Int64(n, k, kind) RESULT(ans) + INTEGER(Int64), INTENT(IN) :: n + INTEGER(Int64), INTENT(IN) :: k + REAL(Real64), INTENT(IN) :: kind + REAL(Real64) :: ans + END FUNCTION Real64_Binom_Int64 END INTERFACE INTERFACE Binom @@ -129,4 +129,4 @@ END FUNCTION Real64_Binom_Int64 & Real64_Binom_Int32, Real64_Binom_Int64 END INTERFACE Binom -END MODULE BinomUtility \ No newline at end of file +END MODULE BinomUtility From 4e707a98fba17084a7c4539011419ea6bc41af5d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:33:00 +0900 Subject: [PATCH 15/43] :mod integer utility --- src/modules/Utility/src/IntegerUtility.F90 | 90 ++++++++++++++++++++-- 1 file changed, 85 insertions(+), 5 deletions(-) diff --git a/src/modules/Utility/src/IntegerUtility.F90 b/src/modules/Utility/src/IntegerUtility.F90 index edb0ab73a..28a550038 100644 --- a/src/modules/Utility/src/IntegerUtility.F90 +++ b/src/modules/Utility/src/IntegerUtility.F90 @@ -24,6 +24,86 @@ MODULE IntegerUtility PUBLIC :: OPERATOR(.isin.) PUBLIC :: RemoveDuplicates PUBLIC :: Repeat +PUBLIC :: SIZE +PUBLIC :: GetMultiIndices + +!---------------------------------------------------------------------------- +! Size@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get the number of touples + +INTERFACE + MODULE PURE FUNCTION obj_Size1(n, d) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + INTEGER(I4B) :: ans + END FUNCTION obj_Size1 +END INTERFACE + +INTERFACE Size + MODULE PROCEDURE obj_Size1 +END INTERFACE Size + +!---------------------------------------------------------------------------- +! Size@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get the number of touples + +INTERFACE + MODULE PURE FUNCTION obj_Size2(n, d, upto) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B) :: ans + END FUNCTION obj_Size2 +END INTERFACE + +INTERFACE Size + MODULE PROCEDURE obj_Size2 +END INTERFACE Size + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices + +INTERFACE + MODULE PURE FUNCTION obj_GetMultiIndices1(n, d) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_GetMultiIndices1 +END INTERFACE + +INTERFACE GetMultiIndices + MODULE PROCEDURE obj_GetMultiIndices1 +END INTERFACE GetMultiIndices + +!---------------------------------------------------------------------------- +! GetIndices@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 Sept 2022 +! summary: Get Indices upto order n + +INTERFACE + MODULE PURE FUNCTION obj_GetMultiIndices2(n, d, upto) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n, d + LOGICAL(LGT), INTENT(IN) :: upto + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION obj_GetMultiIndices2 +END INTERFACE + +INTERFACE GetMultiIndices + MODULE PROCEDURE obj_GetMultiIndices2 +END INTERFACE GetMultiIndices !---------------------------------------------------------------------------- ! Operator(.in.)@IntegerMethods @@ -85,25 +165,25 @@ END FUNCTION in_1d MODULE PURE FUNCTION isin_1a(a, b) RESULT(Ans) INTEGER(Int8), INTENT(IN) :: a(:) INTEGER(Int8), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans( SIZE( a ) ) + LOGICAL(LGT) :: ans(SIZE(a)) END FUNCTION isin_1a MODULE PURE FUNCTION isin_1b(a, b) RESULT(Ans) INTEGER(Int16), INTENT(IN) :: a(:) INTEGER(Int16), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans( SIZE( a ) ) + LOGICAL(LGT) :: ans(SIZE(a)) END FUNCTION isin_1b MODULE PURE FUNCTION isin_1c(a, b) RESULT(Ans) INTEGER(Int32), INTENT(IN) :: a(:) INTEGER(Int32), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans( SIZE( a ) ) + LOGICAL(LGT) :: ans(SIZE(a)) END FUNCTION isin_1c MODULE PURE FUNCTION isin_1d(a, b) RESULT(Ans) INTEGER(Int64), INTENT(IN) :: a(:) INTEGER(Int64), INTENT(IN) :: b(:) - LOGICAL(LGT) :: ans( SIZE( a ) ) + LOGICAL(LGT) :: ans(SIZE(a)) END FUNCTION isin_1d END INTERFACE @@ -216,4 +296,4 @@ END FUNCTION Repeat_1d ! !---------------------------------------------------------------------------- -END MODULE IntegerUtility \ No newline at end of file +END MODULE IntegerUtility From 8c9c33939d3f0d427864af73f981a9cc5f4f897d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:33:09 +0900 Subject: [PATCH 16/43] :mod utility --- src/modules/Utility/src/Utility.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/Utility/src/Utility.F90 b/src/modules/Utility/src/Utility.F90 index f2f04d172..6c9a81ec4 100755 --- a/src/modules/Utility/src/Utility.F90 +++ b/src/modules/Utility/src/Utility.F90 @@ -37,6 +37,7 @@ MODULE Utility USE SwapUtility USE ConvertUtility USE IntegerUtility +USE PushPopUtility USE PolynomialUtility !---------------------------------------------------------------------------- From b5a92fa8112116ac3e8691caf73a16a251dc7ab7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:33:19 +0900 Subject: [PATCH 17/43] :mod cmakelist submodules --- src/submodules/CMakeLists.txt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index 6653e4f17..0a6974eab 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -27,6 +27,9 @@ INCLUDE(${CMAKE_CURRENT_LIST_DIR}/Utility/CMakeLists.txt) #Polynomial INCLUDE(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) +#MultiIndices +INCLUDE(${CMAKE_CURRENT_LIST_DIR}/MultiIndices/CMakeLists.txt) + #OpenMP INCLUDE(${CMAKE_CURRENT_LIST_DIR}/OpenMP/CMakeLists.txt) From 6067bb6a4e17adcd91bb00b33d965529529aaba9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:33:25 +0900 Subject: [PATCH 18/43] :mod intvector --- .../src/IntVector_Method@IOMethods.F90 | 30 +++++++++---------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/submodules/IntVector/src/IntVector_Method@IOMethods.F90 b/src/submodules/IntVector/src/IntVector_Method@IOMethods.F90 index 8e97bf02f..437a7ae85 100644 --- a/src/submodules/IntVector/src/IntVector_Method@IOMethods.F90 +++ b/src/submodules/IntVector/src/IntVector_Method@IOMethods.F90 @@ -17,7 +17,7 @@ !> author: Vikas Sharma, Ph. D. ! date: 28 Feb 2021 -! summary: This submodule contains Input/Output methods for [[IntVector_]] +! summary: This contains Input/Output methods for [[IntVector_]] SUBMODULE(IntVector_Method) IOMethods USE BaseMethod @@ -29,15 +29,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_Display1 - INTEGER(I4B) :: j - CALL Display(msg="# "//TRIM(msg), unitNo=unitNo) - CALL Display(msg="# size : ", val=SIZE(obj), unitNo=unitNo) - DO j = 1, SIZE(obj) - CALL Display(obj(j), & - & msg="# "//TRIM(msg)//"( " & - & //TOSTRING(j)//" ) ", & - & unitNo=UnitNo, orient=orient) - END DO +INTEGER(I4B) :: j +CALL Display(msg="# "//TRIM(msg), unitNo=unitNo) +CALL Display(msg="# size : ", val=SIZE(obj), unitNo=unitNo) +DO j = 1, SIZE(obj) + CALL Display(obj(j), & + & msg="# "//TRIM(msg)//"( " & + & //TOSTRING(j)//" ) ", & + & unitNo=UnitNo, orient=orient) +END DO END PROCEDURE intVec_Display1 !---------------------------------------------------------------------------- @@ -45,11 +45,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE intVec_Display2 - IF (isAllocated(obj)) THEN - CALL Display(msg="# "//TRIM(msg), unitNo=unitNo) - CALL Display(msg="# size : ", val=SIZE(obj), unitNo=unitNo) - CALL Display(Val=obj%Val, msg='', unitNo=unitNo, orient=orient) - END IF +IF (isAllocated(obj)) THEN + CALL Display(msg="# "//TRIM(msg), unitNo=unitNo) + CALL Display(msg="# size : ", val=SIZE(obj), unitNo=unitNo) + CALL Display(Val=obj%Val, msg='', unitNo=unitNo, orient=orient) +END IF END PROCEDURE intVec_Display2 END SUBMODULE IOMethods From 0680c6466a035b592b8fc5161428be2e486e5572 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:33:35 +0900 Subject: [PATCH 19/43] :mod polynomial --- src/submodules/Polynomial/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index e56fd619c..29325c639 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -30,4 +30,5 @@ TARGET_SOURCES( ${src_path}/JacobiPolynomialUtility@Methods.F90 ${src_path}/Chebyshev1PolynomialUtility@Methods.F90 ${src_path}/OrthogonalPolynomialUtility@Methods.F90 + ${src_path}/RecursiveNodesUtility@Methods.F90 ) From fae6868a78036009f14ab32735f529eb331636bd Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:33:48 +0900 Subject: [PATCH 20/43] :added recursive nodes --- .../src/RecursiveNodesUtility@Methods.F90 | 330 ++++++++++++++++++ 1 file changed, 330 insertions(+) create mode 100644 src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 diff --git a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 new file mode 100644 index 000000000..80ca94964 --- /dev/null +++ b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 @@ -0,0 +1,330 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(RecursiveNodesUtility) Methods +USE BaseMethod +CONTAINS + +!---------------------------------------------------------------------------- +! RecursiveNode1D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RecursiveNode1D +INTEGER(I4B) :: n, jj +INTEGER(I4B), PARAMETER :: d = 1_I4B +INTEGER(I4B) :: aindx(d + 1) +REAL(DFP) :: avar +REAL(DFP), PARAMETER :: xij(2) = [0.0_DFP, 1.0_DFP] +INTEGER(I4B), ALLOCATABLE :: indices(:, :) +REAL(DFP), ALLOCATABLE :: x(:) +!! +n = order +x = InterpolationPoint_Line(order=order, ipType=ipType, xij=xij) +!! +IF (order .GT. 1) THEN + avar = x(2) + x(2:order) = x(3:) + x(order + 1) = avar +END IF +!! +indices = GetMultiIndices(n=n, d=d) +CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) +!! +DO jj = 1, SIZE(ans, 2) + aindx = indices(:, jj) + 1 + avar = x(aindx(1)) + x(aindx(2)) + ans(1, jj) = x(aindx(1)) / avar + ans(2, jj) = x(aindx(2)) / avar +END DO +!! +IF (PRESENT(domain)) THEN + ans = Coord_Map(x=ans, from="BaryCentric", to=domain) +END IF +!! +IF (ALLOCATED(indices)) DEALLOCATE (indices) +IF (ALLOCATED(x)) DEALLOCATE (x) +!! +END PROCEDURE RecursiveNode1D + +!---------------------------------------------------------------------------- +! RecursiveNode2D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RecursiveNode2D +INTEGER(I4B) :: n, jj, ii +INTEGER(I4B), PARAMETER :: d = 2_I4B +INTEGER(I4B) :: aindx(d + 1), indx(d) +REAL(DFP) :: xi, xt, b(d + 1), bs(d), Xn(order + 1) +REAL(DFP) :: BX(2, order + 1, order + 1) +INTEGER(I4B), ALLOCATABLE :: indices(:, :) +!! +n = order +CALL BarycentericNodeFamily1D(order=order, ipType=ipType, ans=BX, Xn=Xn) +! +indices = GetMultiIndices(n=n, d=d) +CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) +!! +DO jj = 1, SIZE(ans, 2) + !! + aindx = indices(:, jj) + xt = 0.0_DFP + !! + DO ii = 1, d + 1 + !! + indx = Pop(aindx, ii) + bs = BX(:, indx(1) + 1, indx(2) + 1) + b = Push(vec=bs, value=0.0_DFP, pos=ii) + xi = Xn(SUM(indx) + 1) + xt = xt + xi + ans(1:d + 1, jj) = ans(1:d + 1, jj) + xi * b + !! + END DO + !! + ans(:, jj) = ans(:, jj) / xt + !! +END DO +!! +IF (PRESENT(domain)) THEN + ans = Coord_Map(x=ans, from="BaryCentric", to=domain) +END IF +!! +!! +IF (ALLOCATED(indices)) DEALLOCATE (indices) +!! +END PROCEDURE RecursiveNode2D + +!---------------------------------------------------------------------------- +! RecursiveNode3D +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RecursiveNode3D +INTEGER(I4B) :: n, jj, ii +INTEGER(I4B), PARAMETER :: d = 3_I4B +INTEGER(I4B) :: aindx(d + 1), indx(d) +REAL(DFP) :: xi, xt, b(d + 1), bs(d), Xn(order + 1) +REAL(DFP) :: BX(3, order + 1, order + 1, order + 1) +INTEGER(I4B), ALLOCATABLE :: indices(:, :) +!! +n = order +CALL BarycentericNodeFamily2D(order=order, ipType=ipType, ans=BX, Xn=Xn) +! +indices = GetMultiIndices(n=n, d=d) +CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) +ans = 0.0_DFP +!! +DO jj = 1, SIZE(ans, 2) + !! + aindx = indices(:, jj) + xt = 0.0_DFP + !! + DO ii = 1, d + 1 + !! + indx = Pop(aindx, ii) + bs = BX(:, indx(1) + 1, indx(2) + 1, indx(3) + 1) + b = Push(vec=bs, value=0.0_DFP, pos=ii) + xi = Xn(SUM(indx) + 1) + xt = xt + xi + ans(:, jj) = ans(:, jj) + xi * b + !! + END DO + !! + ans(:, jj) = ans(:, jj) / xt + !! +END DO +!! +IF (PRESENT(domain)) THEN + ans = Coord_Map(x=ans, from="BaryCentric", to=domain) +END IF +!! +IF (ALLOCATED(indices)) DEALLOCATE (indices) +!! +END PROCEDURE RecursiveNode3D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE BarycentericNodeFamily1D(order, ipType, ans, Xn) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: ipType + REAL(DFP), INTENT(OUT) :: ans(2, order + 1, order + 1) + REAL(DFP), INTENT(OUT) :: Xn(order + 1) + !! + INTEGER(I4B) :: ii, jj, n + INTEGER(I4B), PARAMETER :: d = 1_I4B + REAL(DFP), ALLOCATABLE :: BXn(:, :) + INTEGER(I4B), ALLOCATABLE :: indices(:, :) + !! + DO ii = 0, order + n = ii + indices = GetMultiIndices(n=n, d=d) + BXn = RecursiveNode1D(order=n, ipType=ipType) + !! + DO jj = 1, n + 1 + ans(1:d + 1, indices(1, jj) + 1, indices(2, jj) + 1) = BXn(1:d + 1, jj) + END DO + !! + END DO + !! + Xn = BXn(1, :) + !! + IF (ALLOCATED(BXn)) DEALLOCATE (BXn) + IF (ALLOCATED(indices)) DEALLOCATE (indices) + !! +END SUBROUTINE BarycentericNodeFamily1D + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE BarycentericNodeFamily2D(order, ipType, ans, Xn) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: ipType + REAL(DFP), INTENT(OUT) :: ans(3, order + 1, order + 1, order + 1) + REAL(DFP), INTENT(OUT) :: Xn(order + 1) + !! + INTEGER(I4B) :: ii, jj, n + INTEGER(I4B), PARAMETER :: d = 2_I4B + REAL(DFP), ALLOCATABLE :: BXn(:, :) + INTEGER(I4B), ALLOCATABLE :: indices(:, :) + REAL(DFP) :: avar + REAL(DFP), PARAMETER :: xij(2) = [0.0_DFP, 1.0_DFP] + !! + DO ii = 0, order + n = ii + indices = GetMultiIndices(n=n, d=d) + BXn = RecursiveNode2D(order=n, ipType=ipType) + !! + DO jj = 1, SIZE(BXn, 2) + ans(1:3, & + & indices(1, jj) + 1, & + & indices(2, jj) + 1, & + & indices(3, jj) + 1) = BXn(1:3, jj) + END DO + !! + END DO + !! + Xn = InterpolationPoint_Line(order=order, ipType=ipType, xij=xij) + !! + IF (order .GT. 1) THEN + avar = Xn(2) + Xn(2:order) = Xn(3:) + Xn(order + 1) = avar + END IF + !! + IF (ALLOCATED(BXn)) DEALLOCATE (BXn) + IF (ALLOCATED(indices)) DEALLOCATE (indices) + !! +END SUBROUTINE BarycentericNodeFamily2D + +!---------------------------------------------------------------------------- +! Unit2Equilateral +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Unit2Equilateral +INTEGER(I4B) :: ii +!! +IF (d .GT. 1_I4B) THEN + ! Move the top vertex over the centroid + DO ii = 1, d - 1 + x(ii, :) = x(ii, :) + x(d, :) / d + END DO + ! Make the projection onto the lesser dimensions equilateral + CALL Unit2Equilateral(d - 1, x(1:d - 1, :)) + ! scale the vertical dimension + x(d, :) = x(d, :) * SQRT((d + 1.0_DFP) / (2.0_DFP * d)) +END IF +END PROCEDURE Unit2Equilateral + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Equilateral2Unit +INTEGER(I4B) :: ii +!! +IF (d .GT. 1_I4B) THEN + x(d, :) = x(d, :) / SQRT((d + 1.0_DFP) / (2.0_DFP * d)) + CALL Equilateral2Unit(d=d - 1, x=x(1:d - 1, :)) + DO ii = 1, d - 1 + x(ii, :) = x(ii, :) - x(d, :) / d + END DO +END IF +END PROCEDURE Equilateral2Unit + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ToUnit +TYPE(String) :: astr +INTEGER(I4B) :: d +astr = UpperCase(TRIM(domain)) +SELECT CASE (astr%chars()) +CASE ("UNIT") + ans = x +CASE ("BIUNIT") + ans = 0.5_DFP * (x + 1.0_DFP) +CASE ("BARYCENTRIC") + d = SIZE(x, 1) + ans = x(1:d - 1, :) +CASE ("EQUILATERAL") + d = SIZE(x, 1) + ans = x + ans = ans / 2.0_DFP + CALL Equilateral2Unit(d=d, x=ans) + ans = ans + 1.0_DFP / (d + 1.0_DFP) +END SELECT +END PROCEDURE ToUnit + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnit +TYPE(String) :: astr +INTEGER(I4B) :: d +astr = UpperCase(TRIM(domain)) +SELECT CASE (astr%chars()) +CASE ("UNIT") + ans = x +CASE ("BIUNIT") + ans = 2.0_DFP * x - 1 +CASE ("BARYCENTRIC") + ans = x.ROWCONCAT. (1.0_DFP - SUM(x, dim=1)) +CASE ("EQUILATERAL") + d = SIZE(x, 1) + ans = x + ans = ans - 1.0_DFP / (d + 1.0_DFP) + CALL Unit2Equilateral(d=d, x=ans) + ans = ans * 2.0_DFP +END SELECT +END PROCEDURE FromUnit + +!---------------------------------------------------------------------------- +! Coord_Map +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Coord_Map +ans = FromUnit(x=(ToUnit(x=x, domain=from)), domain=to) +END PROCEDURE Coord_Map + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods From acb8314454470025e04c9f5c4003a5e2fd760863 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:34:08 +0900 Subject: [PATCH 21/43] :modified jacobi polynomial --- .../src/JacobiPolynomialUtility@Methods.F90 | 535 +++++++++++++----- 1 file changed, 394 insertions(+), 141 deletions(-) diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index abf222d2d..f24470fb2 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -1,7 +1,7 @@ ! This program is a part of EASIFEM library ! Copyright (C) 2020-2021 Vikas Sharma, Ph.D ! -! This program is free software: you can redistribute it and/or modify +! This program is free software: you can redistribute it and/or modIFy ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation, either version 3 of the License, or ! (at your option) any later version. @@ -12,7 +12,7 @@ ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License -! along with this program. If not, see +! along with this program. IF not, see ! SUBMODULE(JacobiPolynomialUtility) Methods @@ -25,48 +25,48 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetJacobiRecurrenceCoeff - REAL( DFP ), PARAMETER :: two = 2.0_DFP, four=4.0_DFP - REAL( DFP ) :: ab1, ab, ab2, abm1, bma,ab3, b2ma2, ab4 - INTEGER( I4B ) :: ii +REAL(DFP), PARAMETER :: two = 2.0_DFP, four = 4.0_DFP +REAL(DFP) :: ab1, ab, ab2, abm1, bma, ab3, b2ma2, ab4 +INTEGER(I4B) :: ii !! - IF( n .LE. 0 ) RETURN +IF (n .LE. 0) RETURN !! - ab = alpha + beta - ab1 = ab + 1.0_DFP - abm1 = ab - 1.0_DFP - bma = beta - alpha - ab2 = ab1 + 1.0_DFP - ab3 = ab2 + 1.0_DFP - ab4 = ab3 + 1.0_DFP - b2ma2 = beta*beta - alpha*alpha +ab = alpha + beta +ab1 = ab + 1.0_DFP +abm1 = ab - 1.0_DFP +bma = beta - alpha +ab2 = ab1 + 1.0_DFP +ab3 = ab2 + 1.0_DFP +ab4 = ab3 + 1.0_DFP +b2ma2 = beta * beta - alpha * alpha !! !! beta 0 !! - betaCoeff(0) = two ** ( ab1 ) * GAMMA( alpha + 1.0_DFP ) & - & * GAMMA( beta+1.0_DFP ) & - & / GAMMA( ab1+1.0_DFP ) +betaCoeff(0) = two**(ab1) * GAMMA(alpha + 1.0_DFP) & + & * GAMMA(beta + 1.0_DFP) & + & / GAMMA(ab1 + 1.0_DFP) !! !! alpha 0 !! - alphaCoeff( 0 ) = bma / ab2 +alphaCoeff(0) = bma / ab2 !! - !! Return if n = 1 + !! RETURN IF n = 1 !! - IF( n .EQ. 1 ) RETURN +IF (n .EQ. 1) RETURN !! - betaCoeff(1) = four * (1.0_DFP+alpha) * (1.0_DFP+beta) / (ab2*ab2*ab3) - alphaCoeff(1) = b2ma2 / (ab2*ab4) +betaCoeff(1) = four * (1.0_DFP + alpha) * (1.0_DFP + beta) / (ab2 * ab2 * ab3) +alphaCoeff(1) = b2ma2 / (ab2 * ab4) !! !! Now it safe to compute other coefficients !! - DO ii = 2, n-1 +DO ii = 2, n - 1 !! - betaCoeff( ii ) = four * ii * (ii+alpha) * (ii+beta) * (ii+ab) & - & / (ab+2.0*ii)**2 / (ab1+2.0*ii) / (abm1 + 2.0*ii) + betaCoeff(ii) = four * ii * (ii + alpha) * (ii + beta) * (ii + ab) & + & / (ab + 2.0 * ii)**2 / (ab1 + 2.0 * ii) / (abm1 + 2.0 * ii) !! - alphaCoeff( ii ) = b2ma2 / ( ab+2.0*ii ) / ( ab2 + 2.0*ii ) + alphaCoeff(ii) = b2ma2 / (ab + 2.0 * ii) / (ab2 + 2.0 * ii) !! - END DO +END DO !! END PROCEDURE GetJacobiRecurrenceCoeff @@ -75,8 +75,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiLeadingCoeff - ans = GAMMA( 2.0_DFP*n + alpha + beta + 1.0_DFP) / GAMMA( n + 1.0_DFP ) / & - & GAMMA( n + alpha + beta + 1.0_DFP ) / 2.0_DFP ** n +ans = GAMMA(2.0_DFP * n + alpha + beta + 1.0_DFP) / GAMMA(n + 1.0_DFP) / & + & GAMMA(n + alpha + beta + 1.0_DFP) / 2.0_DFP**n END PROCEDURE JacobiLeadingCoeff !---------------------------------------------------------------------------- @@ -84,14 +84,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiNormSqr - REAL( DFP ) :: a1, a2, a3, b1, b2, b3 - a1 = 2.0 ** ( alpha + beta + 1.0_DFP ) - a2 = GAMMA( n + alpha + 1.0_DFP ) - a3 = GAMMA( n + beta + 1.0_DFP ) - b1 = 2.0_DFP * n + alpha + beta + 1.0_DFP - b2 = Factorial( n ) - b3 = GAMMA( n + alpha + beta + 1.0_DFP ) - ans = a1 * a2 * a3 / b1 / b2 / b3 +REAL(DFP) :: a1, a2, a3, b1, b2, b3 +a1 = 2.0**(alpha + beta + 1.0_DFP) +a2 = GAMMA(n + alpha + 1.0_DFP) +a3 = GAMMA(n + beta + 1.0_DFP) +b1 = 2.0_DFP * n + alpha + beta + 1.0_DFP +b2 = Factorial(n) +b3 = GAMMA(n + alpha + beta + 1.0_DFP) +ans = a1 * a2 * a3 / b1 / b2 / b3 END PROCEDURE JacobiNormSqr !---------------------------------------------------------------------------- @@ -99,16 +99,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiJacobiMatrix - REAL( DFP ), DIMENSION( 0:n-1 ) :: alphaCoeff0, betaCoeff0 +REAL(DFP), DIMENSION(0:n - 1) :: alphaCoeff0, betaCoeff0 !! - IF( n .LT. 1 ) RETURN +IF (n .LT. 1) RETURN !! - CALL GetJacobiRecurrenceCoeff( n=n, alpha=alpha, beta=beta, & - & alphaCoeff=alphaCoeff0, betaCoeff=betaCoeff0 ) - IF( PRESENT( alphaCoeff ) ) alphaCoeff( 0:n-1 ) = alphaCoeff0 - IF( PRESENT( betaCoeff ) ) betaCoeff( 0:n-1 ) = betaCoeff0 - CALL JacobiMatrix( alphaCoeff=alphaCoeff0, & - & betaCoeff=betaCoeff0, D=D, E=E ) +CALL GetJacobiRecurrenceCoeff(n=n, alpha=alpha, beta=beta, & + & alphaCoeff=alphaCoeff0, betaCoeff=betaCoeff0) +IF (PRESENT(alphaCoeff)) alphaCoeff(0:n - 1) = alphaCoeff0 +IF (PRESENT(betaCoeff)) betaCoeff(0:n - 1) = betaCoeff0 +CALL JacobiMatrix(alphaCoeff=alphaCoeff0, & + & betaCoeff=betaCoeff0, D=D, E=E) !! END PROCEDURE JacobiJacobiMatrix @@ -117,58 +117,57 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiGaussQuadrature - REAL( DFP ) :: beta0, Z(n, n), betaCoeff( 0:n-1 ) - INTEGER( I4B ) :: ii +REAL(DFP) :: beta0, Z(n, n), betaCoeff(0:n - 1) +INTEGER(I4B) :: ii !! - CALL JacobiJacobiMatrix( n=n, alpha=alpha, beta=beta, D=pt, & - & E=wt, betaCoeff=betaCoeff ) +CALL JacobiJacobiMatrix(n=n, alpha=alpha, beta=beta, D=pt, & + & E=wt, betaCoeff=betaCoeff) !! #ifdef USE_LAPACK95 - CALL STEV( D=pt, E=wt, Z=Z ) - DO ii = 1, n - wt( ii ) = betaCoeff( 0 ) * Z( 1, ii )**2 - END DO +CALL STEV(D=pt, E=wt, Z=Z) +DO ii = 1, n + wt(ii) = betaCoeff(0) * Z(1, ii)**2 +END DO !! #else - CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file = __FILE__, & - & routine= "JacobiGaussQuadrature", & - & line= __LINE__, & - & unitno = stdout ) +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="JacobiGaussQuadrature", & + & line=__LINE__, & + & unitno=stdout) #endif !! END PROCEDURE JacobiGaussQuadrature - !---------------------------------------------------------------------------- ! JacobiJacobiRadauMatrix !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiJacobiRadauMatrix - REAL( DFP ) :: avar, r1, r2, r3, ab,ab2 +REAL(DFP) :: avar, r1, r2, r3, ab, ab2 !! - IF( n .LT. 1 ) RETURN +IF (n .LT. 1) RETURN !! - CALL JacobiJacobiMatrix( n=n, alpha=alpha, beta=beta, & - & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff ) +CALL JacobiJacobiMatrix(n=n, alpha=alpha, beta=beta, & + & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) !! - r1 = (1.0-a)*n*(n+alpha) - (1.0+a)*n*(n+beta) - r2 = 2.0*n+alpha+beta - r3 = r2 + 1.0 - avar = a + r1/r2/r3 - D(n+1) = avar +r1 = (1.0 - a) * n * (n + alpha) - (1.0 + a) * n * (n + beta) +r2 = 2.0 * n + alpha + beta +r3 = r2 + 1.0 +avar = a + r1 / r2 / r3 +D(n + 1) = avar !! - ab = alpha + beta - ab2 = ab + 2.0_DFP - IF( n .EQ. 1 ) THEN - avar = 4.0_DFP * (1.0_DFP+alpha) * (1.0_DFP+beta) / (ab2*ab2*(ab2+1.0)) - ELSE - avar = 4.0_DFP * n * (n+alpha) * (n+beta) * (n+ab) & - & / (ab+2.0*n)**2 / (ab+1.0+2.0*n) / (ab-1.0 + 2.0*n) - END IF +ab = alpha + beta +ab2 = ab + 2.0_DFP +IF (n .EQ. 1) THEN + avar = 4.0_DFP * (1.0_DFP+alpha) * (1.0_DFP+beta) / (ab2*ab2*(ab2+1.0)) +ELSE + avar = 4.0_DFP * n * (n + alpha) * (n + beta) * (n + ab) & + & / (ab + 2.0 * n)**2 / (ab + 1.0 + 2.0 * n) / (ab - 1.0 + 2.0 * n) +END IF !! - E( n ) = SQRT( avar ) +E(n) = SQRT(avar) !! END PROCEDURE JacobiJacobiRadauMatrix @@ -178,26 +177,26 @@ MODULE PROCEDURE JacobiGaussRadauQuadrature !! - REAL( DFP ) :: beta0, Z(n+1, n+1), betaCoeff( 0:n ) - INTEGER( I4B ) :: ii +REAL(DFP) :: beta0, Z(n + 1, n + 1), betaCoeff(0:n) +INTEGER(I4B) :: ii !! - CALL JacobiJacobiRadauMatrix( a=a, n=n, alpha=alpha, beta=beta, D=pt, & - & E=wt, betaCoeff=betaCoeff ) +CALL JacobiJacobiRadauMatrix(a=a, n=n, alpha=alpha, beta=beta, D=pt, & + & E=wt, betaCoeff=betaCoeff) !! #ifdef USE_LAPACK95 !! - CALL STEV( D=pt, E=wt, Z=Z ) - DO ii = 1, n+1 - wt( ii ) = betaCoeff( 0 ) * Z( 1, ii )**2 - END DO +CALL STEV(D=pt, E=wt, Z=Z) +DO ii = 1, n + 1 + wt(ii) = betaCoeff(0) * Z(1, ii)**2 +END DO !! #else - CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file = __FILE__, & - & routine= "JacobiGaussRadauQuadrature", & - & line= __LINE__, & - & unitno = stdout ) +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="JacobiGaussRadauQuadrature", & + & line=__LINE__, & + & unitno=stdout) #endif !! END PROCEDURE JacobiGaussRadauQuadrature @@ -208,31 +207,31 @@ MODULE PROCEDURE JacobiJacobiLobattoMatrix !! - REAL( DFP ) :: avar, r1, r2, r3, ab +REAL(DFP) :: avar, r1, r2, r3, ab !! - IF( n .LT. 1 ) RETURN +IF (n .LT. 1) RETURN !! - CALL JacobiJacobiMatrix( & - & n=n+1, & - & alpha=alpha, & - & beta=beta, & - & D=D, & - & E=E, & - & alphaCoeff=alphaCoeff, & - & betaCoeff=betaCoeff ) +CALL JacobiJacobiMatrix( & + & n=n + 1, & + & alpha=alpha, & + & beta=beta, & + & D=D, & + & E=E, & + & alphaCoeff=alphaCoeff, & + & betaCoeff=betaCoeff) !! - r1 = alpha - beta - r2 = 2.0*n + alpha + beta + 2.0_DFP - r3 = 1.0 - avar = r1/r2/r3 - D(n+2) = avar +r1 = alpha - beta +r2 = 2.0 * n + alpha + beta + 2.0_DFP +r3 = 1.0 +avar = r1 / r2 / r3 +D(n + 2) = avar !! - ab = alpha + beta - r1 = 4.0_DFP * (n+alpha+1.0) * (n+beta+1.0) * (n+ab+1.0) - r2 = 2.0*n + ab + 1.0 - r3 = ( r2 + 1.0 )**2 +ab = alpha + beta +r1 = 4.0_DFP * (n + alpha + 1.0) * (n + beta + 1.0) * (n + ab + 1.0) +r2 = 2.0 * n + ab + 1.0 +r3 = (r2 + 1.0)**2 !! - E( n+1 ) = SQRT( r1 / r2 / r3 ) +E(n + 1) = SQRT(r1 / r2 / r3) !! END PROCEDURE JacobiJacobiLobattoMatrix @@ -242,25 +241,25 @@ MODULE PROCEDURE JacobiGaussLobattoQuadrature !! - REAL( DFP ) :: beta0, Z(n+2, n+2), betaCoeff(0:n+1) - INTEGER( I4B ) :: ii +REAL(DFP) :: beta0, Z(n + 2, n + 2), betaCoeff(0:n + 1) +INTEGER(I4B) :: ii !! - CALL JacobiJacobiLobattoMatrix( n=n, alpha=alpha, beta=beta, D=pt, & - & E=wt, betaCoeff=betaCoeff ) +CALL JacobiJacobiLobattoMatrix(n=n, alpha=alpha, beta=beta, D=pt, & + & E=wt, betaCoeff=betaCoeff) !! #ifdef USE_LAPACK95 - CALL STEV( D=pt, E=wt, Z=Z ) - DO ii = 1, n+2 - wt( ii ) = betaCoeff( 0 ) * Z( 1, ii )**2 - END DO +CALL STEV(D=pt, E=wt, Z=Z) +DO ii = 1, n + 2 + wt(ii) = betaCoeff(0) * Z(1, ii)**2 +END DO !! #else - CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file = __FILE__, & - & routine= "JacobiGaussLobattoQuadrature", & - & line= __LINE__, & - & unitno = stdout ) +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="JacobiGaussLobattoQuadrature", & + & line=__LINE__, & + & unitno=stdout) #endif !! END PROCEDURE JacobiGaussLobattoQuadrature @@ -271,27 +270,27 @@ MODULE PROCEDURE JacobiZeros !! - REAL( DFP ) :: E( n ) +REAL(DFP) :: E(n) !! - CALL JacobiJacobiMatrix( & - & n=n, & - & alpha=alpha, & - & beta=beta, & - & D=ans, & - & E=E ) +CALL JacobiJacobiMatrix( & + & n=n, & + & alpha=alpha, & + & beta=beta, & + & D=ans, & + & E=E) !! #ifdef USE_LAPACK95 !! - CALL STEV( D=ans, E=E ) +CALL STEV(D=ans, E=E) !! #else !! - CALL ErrorMsg( & - & msg="The subroutine requires Lapack95 package", & - & file = __FILE__, & - & routine= "JacobiZeros", & - & line= __LINE__, & - & unitno = stdout ) +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="JacobiZeros", & + & line=__LINE__, & + & unitno=stdout) !! #endif !! @@ -301,4 +300,258 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE Methods \ No newline at end of file +MODULE PROCEDURE JacobiQuadrature +INTEGER(I4B) :: order +REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP + !! +SELECT CASE (QuadType) +CASE (Gauss) + order = n + CALL JacobiGaussQuadrature(n=order, alpha=alpha, beta=beta, & + & pt=pt, wt=wt) +CASE (GaussRadau, GaussRadauLeft) + order = n - 1 + CALL JacobiGaussRadauQuadrature(a=left, n=order, alpha=alpha, beta=beta, & + & pt=pt, wt=wt) +CASE (GaussRadauRight) + order = n - 1 + CALL JacobiGaussRadauQuadrature(a=right, n=order, alpha=alpha, beta=beta, & + & pt=pt, wt=wt) +CASE (GaussLobatto) + order = n - 2 + CALL JacobiGaussLobattoQuadrature(n=order, alpha=alpha, beta=beta, & + & pt=pt, wt=wt) +END SELECT +END PROCEDURE JacobiQuadrature + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEvalAll1 +INTEGER(I4B) :: i +REAL(DFP) :: c1 +REAL(DFP) :: c2 +REAL(DFP) :: c3 +REAL(DFP) :: c4 +REAL(DFP) :: r_i +!! +ans = 0.0_DFP +!! +IF (alpha <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (beta <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(2) = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & + & + 0.5_DFP * (alpha - beta) +!! +DO i = 2, n + !! + r_i = real(i, kind=DFP) + !! + c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (2.0_DFP * r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (alpha + beta) * (alpha - beta) + !! + c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & + & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) + !! + ans(i + 1) = ((c3 + c2 * x) * ans(i) + c4 * ans(i - 1)) / c1 + !! +END DO + +END PROCEDURE JacobiEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEvalAll2 +INTEGER(I4B) :: i +REAL(DFP) :: c1 +REAL(DFP) :: c2 +REAL(DFP) :: c3 +REAL(DFP) :: c4 +REAL(DFP) :: r_i +!! +ans = 0.0_DFP +!! +IF (alpha <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (beta <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(:, 1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(:, 2) = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & + & + 0.5_DFP * (alpha - beta) +!! +DO i = 2, n + !! + r_i = real(i, kind=DFP) + !! + c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (2.0_DFP * r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (alpha + beta) * (alpha - beta) + !! + c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & + & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) + !! + ans(:, i + 1) = ((c3 + c2 * x(:)) & + & * ans(:, i) + c4 * ans(:, i - 1)) / c1 + !! +END DO + !! +END PROCEDURE JacobiEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEval1 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, c4, r_i, ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (alpha <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (beta <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & + & + 0.5_DFP * (alpha - beta) +!! +DO i = 2, n + !! + r_i = real(i, kind=DFP) + !! + c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (2.0_DFP * r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (alpha + beta) * (alpha - beta) + !! + c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & + & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) + !! + ans_1 = ans + ans = ((c3 + c2 * x) * ans + c4 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE JacobiEval1 + +!---------------------------------------------------------------------------- +! JacobiEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEval2 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, c4, r_i +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (alpha <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (beta <= -1.0_DFP) THEN + RETURN +END IF +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = (1.0_DFP + 0.5_DFP * (alpha + beta)) * x & + & + 0.5_DFP * (alpha - beta) +!! +DO i = 2, n + !! + r_i = real(i, kind=DFP) + !! + c1 = 2.0_DFP * r_i * (r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c2 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (2.0_DFP * r_i + alpha + beta) & + & * (2.0_DFP * r_i - 2.0_DFP + alpha + beta) + !! + c3 = (2.0_DFP * r_i - 1.0_DFP + alpha + beta) & + & * (alpha + beta) * (alpha - beta) + !! + c4 = -2.0_DFP * (r_i - 1.0_DFP + alpha) & + & * (r_i - 1.0_DFP + beta) * (2.0_DFP * r_i + alpha + beta) + !! + ans_1 = ans + ans = ((c3 + c2 * x) * ans + c4 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE JacobiEval2 + +END SUBMODULE Methods From 3364d0dbc49ed5a902c138ee4198c791a893619e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:34:19 +0900 Subject: [PATCH 22/43] :mod line interpolation --- .../src/LineInterpolationUtility@Methods.F90 | 43 +++++++++++++++++-- 1 file changed, 40 insertions(+), 3 deletions(-) diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 81ecd0c48..27813cb2e 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -122,8 +122,14 @@ MODULE PROCEDURE EquidistancePoint_Line1 CALL Reallocate(ans, order + 1) +IF (order .EQ. 0_I4B) THEN + ans(1) = 0.5_DFP * (xij(1) + xij(2)) + RETURN +END IF +!! ans(1) = xij(1) ans(2) = xij(2) +!! IF (order .GE. 2) THEN ans(3:) = EquidistanceInPoint_Line(order=order, xij=xij) END IF @@ -137,15 +143,32 @@ INTEGER(I4B) :: nsd !! IF (PRESENT(xij)) THEN + !! nsd = SIZE(xij, 1) + !! CALL Reallocate(ans, nsd, order + 1) + !! + IF (order .EQ. 0_I4B) THEN + ans(1:nsd, 1) = 0.5_DFP * (xij(1:nsd, 1) + xij(1:nsd, 2)) + RETURN + END IF + !! ans(1:nsd, 1) = xij(1:nsd, 1) ans(1:nsd, 2) = xij(1:nsd, 2) + !! ELSE nsd = 3_I4B + !! CALL Reallocate(ans, nsd, order + 1) + !! + IF (order .EQ. 0_I4B) THEN + ans(1:nsd, 1) = 0.0_DFP + RETURN + END IF + !! ans(1:nsd, 1) = [-1.0, 0.0, 0.0] ans(1:nsd, 2) = [1.0, 0.0, 0.0] + !! END IF !! IF (order .GE. 2) THEN @@ -155,10 +178,24 @@ END PROCEDURE EquidistancePoint_Line2 !---------------------------------------------------------------------------- -! InterpolationPoint_Line +! InterpolationPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Line1 +SELECT CASE (ipType) +CASE (Equidistance) + ans = EquidistancePoint_Line(xij=xij, order=order) +CASE (GaussLegendre) +CASE (GaussLobatto) +CASE (Chebyshev) +END SELECT +END PROCEDURE InterpolationPoint_Line1 + +!---------------------------------------------------------------------------- +! InterpolationPoint_Line !---------------------------------------------------------------------------- -MODULE PROCEDURE InterpolationPoint_Line +MODULE PROCEDURE InterpolationPoint_Line2 SELECT CASE (ipType) CASE (Equidistance) ans = EquidistancePoint_Line(xij=xij, order=order) @@ -166,7 +203,7 @@ CASE (GaussLobatto) CASE (Chebyshev) END SELECT -END PROCEDURE InterpolationPoint_Line +END PROCEDURE InterpolationPoint_Line2 !---------------------------------------------------------------------------- ! From 69d836c1a55e540f4f165f29216e9b9241a35798 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:34:38 +0900 Subject: [PATCH 23/43] :mod utility --- src/submodules/Utility/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/src/submodules/Utility/CMakeLists.txt b/src/submodules/Utility/CMakeLists.txt index f344ebfe9..76c9371ce 100644 --- a/src/submodules/Utility/CMakeLists.txt +++ b/src/submodules/Utility/CMakeLists.txt @@ -40,4 +40,5 @@ TARGET_SOURCES( ${src_path}/MiscUtility@Methods.F90 ${src_path}/StringUtility@Methods.F90 ${src_path}/IntegerUtility@Methods.F90 + ${src_path}/PushPopUtility@Methods.F90 ) From 49ce2fae0bda558096680584f3fcb52a03bcad4f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:34:52 +0900 Subject: [PATCH 24/43] :added pushpop --- .../Utility/src/PushPopUtility@Methods.F90 | 118 ++++++++++++++++++ 1 file changed, 118 insertions(+) create mode 100644 src/submodules/Utility/src/PushPopUtility@Methods.F90 diff --git a/src/submodules/Utility/src/PushPopUtility@Methods.F90 b/src/submodules/Utility/src/PushPopUtility@Methods.F90 new file mode 100644 index 000000000..0f820b5ef --- /dev/null +++ b/src/submodules/Utility/src/PushPopUtility@Methods.F90 @@ -0,0 +1,118 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(PushPopUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_int8 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_int8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_int16 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_int16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_int32 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_int32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_int64 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_int64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_real32 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_real32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE push_real64 +#include "./PushPop/Push_Scalar.inc" +END PROCEDURE push_real64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_int8 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_int8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_int16 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_int16 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_int32 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_int32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_int64 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_int64 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_real32 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_real32 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE pop_real64 +#include "./PushPop/Pop_Scalar.inc" +END PROCEDURE pop_real64 + +END SUBMODULE Methods From b8228977536e19f96d1e07874d80fd4f8c7b4464 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:35:03 +0900 Subject: [PATCH 25/43] :mod utility --- .../Utility/src/IntegerUtility@Methods.F90 | 97 +++++++++++++++++-- 1 file changed, 88 insertions(+), 9 deletions(-) diff --git a/src/submodules/Utility/src/IntegerUtility@Methods.F90 b/src/submodules/Utility/src/IntegerUtility@Methods.F90 index 10eda75eb..a75e2d08b 100644 --- a/src/submodules/Utility/src/IntegerUtility@Methods.F90 +++ b/src/submodules/Utility/src/IntegerUtility@Methods.F90 @@ -20,6 +20,85 @@ IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Size1 +ans = INT(Binom(n + d, d, 1.0_DFP), KIND=I4B) +END PROCEDURE obj_Size1 + +!---------------------------------------------------------------------------- +! Size +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Size2 +INTEGER(I4B) :: ii +ans = 0_I4B +DO ii = 0, n + ans = ans + Size(n=ii, d=d) +END DO +END PROCEDURE obj_Size2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetMultiIndices1 +INTEGER(I4B) :: ii, m +INTEGER(I4B), ALLOCATABLE :: indx(:, :), acol(:), indx2(:, :) +!! +SELECT CASE (d) +CASE (1_I4B) + !! + ALLOCATE (ans(2, n + 1)) + DO ii = 0, n + ans(1:2, ii + 1) = [ii, n - ii] + END DO + !! +CASE DEFAULT + !! + ALLOCATE (ans(d + 1, 1)) + ans = 0; ans(1, 1) = n + !! + DO ii = n - 1, 0_I4B, -1_I4B + !! + indx = GetMultiIndices(n=n - ii, d=d - 1) + m = SIZE(indx, 2) + acol = ii * ones(m, 1_I4B) + indx2 = acol.ROWCONCAT.indx + ans = indx2.COLCONCAT.ans + !! + END DO + !! +END SELECT +! +IF (ALLOCATED(indx)) DEALLOCATE (indx) +IF (ALLOCATED(acol)) DEALLOCATE (acol) +IF (ALLOCATED(indx2)) DEALLOCATE (indx2) +! +END PROCEDURE obj_GetMultiIndices1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetMultiIndices2 +INTEGER(I4B) :: ii, m, r1, r2 +!! +m = SIZE(n, d, .true.) +ALLOCATE (ans(d + 1, m)) +!! +r1 = 0; r2 = 0 +DO ii = 0, n + m = SIZE(n=ii, d=d) + r1 = r2 + 1_I4B + r2 = r1 + m - 1 + ans(:, r1:r2) = GetMultiIndices(n=ii, d=d) +END DO +!! +END PROCEDURE obj_GetMultiIndices2 + !---------------------------------------------------------------------------- ! IN !---------------------------------------------------------------------------- @@ -65,19 +144,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE in_2a - ans = ANY(a .EQ. b) +ans = ANY(a .EQ. b) END PROCEDURE in_2a MODULE PROCEDURE in_2b - ans = ANY(a .EQ. b) +ans = ANY(a .EQ. b) END PROCEDURE in_2b MODULE PROCEDURE in_2c - ans = ANY(a .EQ. b) +ans = ANY(a .EQ. b) END PROCEDURE in_2c MODULE PROCEDURE in_2d - ans = ANY(a .EQ. b) +ans = ANY(a .EQ. b) END PROCEDURE in_2d !---------------------------------------------------------------------------- @@ -85,22 +164,22 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE RemoveDuplicates_1a - INTEGER(Int8), ALLOCATABLE :: temp(:) +INTEGER(Int8), ALLOCATABLE :: temp(:) #include "./RemoveDuplicates/RemoveDuplicates_1.inc" END PROCEDURE RemoveDuplicates_1a MODULE PROCEDURE RemoveDuplicates_1b - INTEGER(Int16), ALLOCATABLE :: temp(:) +INTEGER(Int16), ALLOCATABLE :: temp(:) #include "./RemoveDuplicates/RemoveDuplicates_1.inc" END PROCEDURE RemoveDuplicates_1b MODULE PROCEDURE RemoveDuplicates_1c - INTEGER(Int32), ALLOCATABLE :: temp(:) +INTEGER(Int32), ALLOCATABLE :: temp(:) #include "./RemoveDuplicates/RemoveDuplicates_1.inc" END PROCEDURE RemoveDuplicates_1c MODULE PROCEDURE RemoveDuplicates_1d - INTEGER(Int64), ALLOCATABLE :: temp(:) +INTEGER(Int64), ALLOCATABLE :: temp(:) #include "./RemoveDuplicates/RemoveDuplicates_1.inc" END PROCEDURE RemoveDuplicates_1d @@ -124,4 +203,4 @@ #include "./Repeat/Repeat_1.inc" END PROCEDURE Repeat_1d -END SUBMODULE Methods \ No newline at end of file +END SUBMODULE Methods From 0ffa8dbbe010a5afd9d1b795bd4563f0601c000f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 7 Sep 2022 12:35:15 +0900 Subject: [PATCH 26/43] :added push pop --- .../Utility/src/PushPop/Pop_Scalar.inc | 40 ++++++++++++++++++ .../Utility/src/PushPop/Push_Scalar.inc | 41 +++++++++++++++++++ 2 files changed, 81 insertions(+) create mode 100644 src/submodules/Utility/src/PushPop/Pop_Scalar.inc create mode 100644 src/submodules/Utility/src/PushPop/Push_Scalar.inc diff --git a/src/submodules/Utility/src/PushPop/Pop_Scalar.inc b/src/submodules/Utility/src/PushPop/Pop_Scalar.inc new file mode 100644 index 000000000..3e54cf768 --- /dev/null +++ b/src/submodules/Utility/src/PushPop/Pop_Scalar.inc @@ -0,0 +1,40 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B) :: n, ii + !! +n = SIZE(vec) +!! +IF (n .EQ. 1) RETURN +!! +IF (pos .GT. n) THEN + ans = vec(1:n - 1) + RETURN +END IF +!! +IF (pos .LT. 1_I4B) THEN + ans = vec(2:n) + RETURN +END IF +!! +DO ii = 1, pos - 1 + ans(ii) = vec(ii) +END DO + +DO ii = pos, n - 1 + ans(ii) = vec(ii + 1) +END DO diff --git a/src/submodules/Utility/src/PushPop/Push_Scalar.inc b/src/submodules/Utility/src/PushPop/Push_Scalar.inc new file mode 100644 index 000000000..7cfd66cec --- /dev/null +++ b/src/submodules/Utility/src/PushPop/Push_Scalar.inc @@ -0,0 +1,41 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +INTEGER(I4B) :: n, ii + !! +n = SIZE(vec) + !! +IF (pos .GT. n) THEN + ans(1:n) = vec + ans(n + 1) = value + RETURN +END IF + !! +IF (pos .LT. 1_I4B) THEN + ans(1) = value + ans(2:n + 1) = vec + RETURN +END IF + !! +ans(pos) = value +DO ii = 1, pos - 1 + ans(ii) = vec(ii) +END DO + +DO ii = pos, n + ans(ii + 1) = vec(ii) +END DO From 1ccb9f564c03146a0143e960c4fb143ea18313f5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 8 Oct 2022 21:02:21 +0900 Subject: [PATCH 27/43] Legendr, Lobatto, and Unscaled Lobatto polynomials added. --- src/modules/BaseType/src/BaseType.F90 | 2 - src/modules/DOF/src/DOF_Method.F90 | 8 +- src/modules/Lapack/src/GE_CompRoutine.inc | 37 + .../Lapack/src/GE_EigenvalueMethods.inc | 17 +- src/modules/Lapack/src/GE_LUMethods.inc | 118 +- src/modules/Lapack/src/GE_Lapack_Method.F90 | 3 +- src/modules/Lapack/src/GE_LinsolveMethods.inc | 136 ++- src/modules/Polynomial/CMakeLists.txt | 3 + .../src/Chebyshev1PolynomialUtility.F90 | 80 +- .../src/JacobiPolynomialUtility.F90 | 6 +- .../src/LegendrePolynomialUtility.F90 | 377 ++++-- .../src/LobattoPolynomialUtility.F90 | 418 +++++++ .../Polynomial/src/PolynomialUtility.F90 | 3 + .../src/UnscaledLobattoPolynomialUtility.F90 | 421 +++++++ .../src/assets/LegendrePolynomials.F90 | 1046 +++++++++++++++++ src/submodules/Lapack/CMakeLists.txt | 1 + .../GE_Lapack_Method@CompRoutineMethods.F90 | 34 + src/submodules/Polynomial/CMakeLists.txt | 3 + .../src/LegendrePolynomialUtility@Methods.F90 | 654 +++++++++++ .../src/LobattoPolynomialUtility@Methods.F90 | 395 +++++++ ...scaledLobattoPolynomialUtility@Methods.F90 | 381 ++++++ 21 files changed, 3847 insertions(+), 296 deletions(-) create mode 100644 src/modules/Lapack/src/GE_CompRoutine.inc create mode 100644 src/modules/Polynomial/src/LobattoPolynomialUtility.F90 create mode 100644 src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 create mode 100644 src/modules/Polynomial/src/assets/LegendrePolynomials.F90 create mode 100644 src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 create mode 100644 src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 create mode 100644 src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index fea832f62..0b764631e 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -232,8 +232,6 @@ MODULE BaseType !> author: Vikas Sharma, Ph. D. ! date: 23 Feb 2021 ! summary: Degree of freedom object type -! -!{!pages/DOF.md!} TYPE :: DOF_ INTEGER(I4B), ALLOCATABLE :: map(:, :) diff --git a/src/modules/DOF/src/DOF_Method.F90 b/src/modules/DOF/src/DOF_Method.F90 index 06b4cd198..e68dcc9f4 100644 --- a/src/modules/DOF/src/DOF_Method.F90 +++ b/src/modules/DOF/src/DOF_Method.F90 @@ -16,11 +16,13 @@ ! !> author: Vikas Sharma, Ph. D. -! date: 23 Feb 2021 -! summary: This module contains methods of [[DOF_]] object +! date: 23 Feb 2021 +! summary: This module contains methods of [[DOF_]] object ! !# Introduction !This module contains methods for derived type called [[DOF_]] +! +!{!pages/DOF.md!} MODULE DOF_Method USE GlobalData @@ -35,4 +37,4 @@ MODULE DOF_Method #include "./GetMethods.inc" #include "./GetValueMethods.inc" -END MODULE DOF_Method \ No newline at end of file +END MODULE DOF_Method diff --git a/src/modules/Lapack/src/GE_CompRoutine.inc b/src/modules/Lapack/src/GE_CompRoutine.inc new file mode 100644 index 000000000..187f619b9 --- /dev/null +++ b/src/modules/Lapack/src/GE_CompRoutine.inc @@ -0,0 +1,37 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!---------------------------------------------------------------------------- +! ConditionNo +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION ge_ConditionNo_1(A, NORM) RESULT(ans) + REAL(DFP), INTENT(IN) :: A(:, :) + !! General matrix + CHARACTER(LEN=1), INTENT(IN) :: NORM + !! "1", "0" + REAL(DFP) :: ans + !! + END FUNCTION ge_ConditionNo_1 +END INTERFACE + +INTERFACE ConditionNo + MODULE PROCEDURE ge_ConditionNo_1 +END INTERFACE ConditionNo + +PUBLIC :: ConditionNo diff --git a/src/modules/Lapack/src/GE_EigenvalueMethods.inc b/src/modules/Lapack/src/GE_EigenvalueMethods.inc index dc667c057..3708d7ce8 100644 --- a/src/modules/Lapack/src/GE_EigenvalueMethods.inc +++ b/src/modules/Lapack/src/GE_EigenvalueMethods.inc @@ -15,9 +15,8 @@ ! along with this program. If not, see ! - !---------------------------------------------------------------------------- -! DGEES@EigenValue +! DGEES@EigenValue !---------------------------------------------------------------------------- INTERFACE @@ -76,12 +75,12 @@ INTERFACE ! ! SDIM: -MODULE SUBROUTINE dgees_1( A, WR, WI, SchurForm ) - REAL( DFP ), INTENT( IN ) :: A( :, : ) - REAL( DFP ), INTENT( INOUT ) :: WR( : ) + MODULE SUBROUTINE dgees_1(A, WR, WI, SchurForm) + REAL(DFP), INTENT(IN) :: A(:, :) + REAL(DFP), INTENT(INOUT) :: WR(:) !! Real part of the eigenvalue - REAL( DFP ), INTENT( INOUT ) :: WI( : ) + REAL(DFP), INTENT(INOUT) :: WI(:) !! Imaginary part of the eigenvalue - REAL( DFP ), INTENT( INOUT ) :: SchurForm( :, : ) -END SUBROUTINE dgees_1 -END INTERFACE \ No newline at end of file + REAL(DFP), INTENT(INOUT) :: SchurForm(:, :) + END SUBROUTINE dgees_1 +END INTERFACE diff --git a/src/modules/Lapack/src/GE_LUMethods.inc b/src/modules/Lapack/src/GE_LUMethods.inc index 50a228622..3c9b94b93 100644 --- a/src/modules/Lapack/src/GE_LUMethods.inc +++ b/src/modules/Lapack/src/GE_LUMethods.inc @@ -58,23 +58,23 @@ PUBLIC :: Inv ! INTERFACE -MODULE SUBROUTINE getLU_1(A, LU, IPIV, RCOND, NORM, info) - REAL( DFP ), INTENT( IN ) :: A( :, : ) + MODULE SUBROUTINE getLU_1(A, LU, IPIV, RCOND, NORM, info) + REAL(DFP), INTENT(IN) :: A(:, :) !! Matrix to be factored - REAL( DFP ), INTENT( OUT ) :: LU( :, : ) + REAL(DFP), INTENT(OUT) :: LU(:, :) !! LU factorization, the unit diagonal elements of L are not stored. - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: IPIV( : ) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) !! IPIV is INTEGER array,row i of the matrix was interchanged with row !! IPIV(i). !! IPIV is INTEGER array, dimension (min(M,N)) !! The pivot indices; for 1 <= i <= min(M,N), row i of the !! matrix was interchanged with row IPIV(i). - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: RCOND - !! Condition number - CHARACTER( LEN = 1 ), OPTIONAL, INTENT( IN ) :: NORM + REAL(DFP), OPTIONAL, INTENT(OUT) :: RCOND + !! Inverse of Condition number + CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: NORM !! NORM "1", "0" - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info -END SUBROUTINE getLU_1 + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE getLU_1 END INTERFACE INTERFACE getLU @@ -91,26 +91,26 @@ END INTERFACE getLU ! !# Introduction ! -! This routine is same as `getLU_1` however in this routine LU +! This routine is same as `getLU_1` however in this routine LU ! factorization is computed in A matrix on return. INTERFACE -MODULE SUBROUTINE getLU_2(A, IPIV, RCOND, NORM, info) - REAL( DFP ), INTENT( INOUT ) :: A( :, : ) + MODULE SUBROUTINE getLU_2(A, IPIV, RCOND, NORM, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) !! Matrix to be factored, on return it contains LU factorization, !! the unit diagonal elements of L are not stored. - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: IPIV( : ) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) !! IPIV is INTEGER array,row i of the matrix was interchanged with row !! IPIV(i). !! IPIV is INTEGER array, dimension (min(M,N)) !! The pivot indices; for 1 <= i <= min(M,N), row i of the !! matrix was interchanged with row IPIV(i). - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: RCOND - !! If present then condition number is returned - CHARACTER( LEN = 1 ), OPTIONAL, INTENT( IN ) :: NORM + REAL(DFP), OPTIONAL, INTENT(OUT) :: RCOND + !! If present then inverse of condition number is returned + CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: NORM !! "1", "0" - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info -END SUBROUTINE getLU_2 + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE getLU_2 END INTERFACE INTERFACE getLU @@ -126,18 +126,18 @@ END INTERFACE getLU ! summary: Solve LUx=y INTERFACE -MODULE SUBROUTINE LUSolve_1( A, B, IPIV, isTranspose, info ) - REAL( DFP ), INTENT( INOUT ) :: A( :, : ) + MODULE SUBROUTINE LUSolve_1(A, B, IPIV, isTranspose, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) !! LU decomposition of matrix A, see getLU - REAL( DFP ), INTENT( INOUT ) :: B(:) + REAL(DFP), INTENT(INOUT) :: B(:) !! RHS, on return solution will be in B - INTEGER( I4B ), INTENT( IN ) :: IPIV(:) + INTEGER(I4B), INTENT(IN) :: IPIV(:) !! IPIV returned from getLU - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose !! if isTranspose true then we solve A^Tx=y - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info !! info -END SUBROUTINE LUSolve_1 + END SUBROUTINE LUSolve_1 END INTERFACE INTERFACE LUSolve @@ -153,17 +153,17 @@ END INTERFACE LUSolve ! summary: Solve LUx=y INTERFACE -MODULE SUBROUTINE LUSolve_2( A, B, IPIV, isTranspose, info ) - REAL( DFP ), INTENT( INOUT ) :: A( :, : ) + MODULE SUBROUTINE LUSolve_2(A, B, IPIV, isTranspose, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) !! LU Decomposition of A returned from getLU - REAL( DFP ), INTENT( INOUT ) :: B(:,:) + REAL(DFP), INTENT(INOUT) :: B(:, :) !! Several rhs, on return solution will be in B - INTEGER( I4B ), INTENT( IN ) :: IPIV(:) + INTEGER(I4B), INTENT(IN) :: IPIV(:) !! pivoting returned from getLU - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose !! if true we solve A^Tx = y - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info -END SUBROUTINE LUSolve_2 + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE LUSolve_2 END INTERFACE INTERFACE LUSolve @@ -179,20 +179,20 @@ END INTERFACE LUSolve ! summary: Solve LUx=y INTERFACE -MODULE SUBROUTINE LUSolve_3( X, A, B, IPIV, isTranspose, info ) - REAL( DFP ), INTENT( OUT ) :: X(:) + MODULE SUBROUTINE LUSolve_3(X, A, B, IPIV, isTranspose, info) + REAL(DFP), INTENT(OUT) :: X(:) !! RHS, on return solution will be in B - REAL( DFP ), INTENT( INOUT ) :: A( :, : ) + REAL(DFP), INTENT(INOUT) :: A(:, :) !! LU decomposition of matrix A, see getLU - REAL( DFP ), INTENT( IN ) :: B(:) + REAL(DFP), INTENT(IN) :: B(:) !! RHS - INTEGER( I4B ), INTENT( IN ) :: IPIV(:) + INTEGER(I4B), INTENT(IN) :: IPIV(:) !! IPIV returned from getLU - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose !! if isTranspose true then we solve A^Tx=y - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info !! info -END SUBROUTINE LUSolve_3 + END SUBROUTINE LUSolve_3 END INTERFACE INTERFACE LUSolve @@ -208,19 +208,19 @@ END INTERFACE LUSolve ! summary: Solve LUx=y INTERFACE -MODULE SUBROUTINE LUSolve_4( X, A, B, IPIV, isTranspose, info ) - REAL( DFP ), INTENT( OUT ) :: X(:,:) + MODULE SUBROUTINE LUSolve_4(X, A, B, IPIV, isTranspose, info) + REAL(DFP), INTENT(OUT) :: X(:, :) !! solution - REAL( DFP ), INTENT( INOUT ) :: A( :, : ) + REAL(DFP), INTENT(INOUT) :: A(:, :) !! LU Decomposition of A returned from getLU - REAL( DFP ), INTENT( IN ) :: B(:,:) + REAL(DFP), INTENT(IN) :: B(:, :) !! several RHS - INTEGER( I4B ), INTENT( IN ) :: IPIV(:) + INTEGER(I4B), INTENT(IN) :: IPIV(:) !! pivoting returned from getLU - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose !! if true we solve A^Tx = y - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info -END SUBROUTINE LUSolve_4 + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE LUSolve_4 END INTERFACE INTERFACE LUSolve @@ -236,15 +236,15 @@ END INTERFACE LUSolve ! summary: get inverse of square matrix from LU decomposition INTERFACE -MODULE SUBROUTINE Inv_1( A, invA, IPIV, info ) - REAL( DFP ), INTENT( IN ) :: A( :, : ) + MODULE SUBROUTINE Inv_1(A, invA, IPIV, info) + REAL(DFP), INTENT(IN) :: A(:, :) !! LU Decomposition - REAL( DFP ), INTENT( INOUT ) :: invA(:, :) + REAL(DFP), INTENT(INOUT) :: invA(:, :) !! inverse of A - INTEGER( I4B ), INTENT( IN ) :: IPIV(:) + INTEGER(I4B), INTENT(IN) :: IPIV(:) !! returned from getLU - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info -END SUBROUTINE Inv_1 + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE Inv_1 END INTERFACE INTERFACE Inv @@ -260,13 +260,13 @@ END INTERFACE Inv ! summary: get inverse of square matrix from LU decomposition INTERFACE -MODULE SUBROUTINE Inv_2( A, IPIV, info ) - REAL( DFP ), INTENT( INOUT ) :: A( :, : ) + MODULE SUBROUTINE Inv_2(A, IPIV, info) + REAL(DFP), INTENT(INOUT) :: A(:, :) !! LU Decomposition, inverse will be returned in A - INTEGER( I4B ), INTENT( IN ) :: IPIV(:) + INTEGER(I4B), INTENT(IN) :: IPIV(:) !! returned from getLU - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info -END SUBROUTINE Inv_2 + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info + END SUBROUTINE Inv_2 END INTERFACE INTERFACE Inv diff --git a/src/modules/Lapack/src/GE_Lapack_Method.F90 b/src/modules/Lapack/src/GE_Lapack_Method.F90 index c3d3e54a4..979d8505f 100644 --- a/src/modules/Lapack/src/GE_Lapack_Method.F90 +++ b/src/modules/Lapack/src/GE_Lapack_Method.F90 @@ -40,5 +40,6 @@ MODULE GE_Lapack_Method #include "./GE_LinsolveMethods.inc" !#include "./GE_EigenvalueMethods.inc" #include "./GE_LUMethods.inc" +#include "./GE_CompRoutine.inc" -END MODULE GE_Lapack_Method \ No newline at end of file +END MODULE GE_Lapack_Method diff --git a/src/modules/Lapack/src/GE_LinsolveMethods.inc b/src/modules/Lapack/src/GE_LinsolveMethods.inc index 6331c8328..d5bf8b34c 100644 --- a/src/modules/Lapack/src/GE_LinsolveMethods.inc +++ b/src/modules/Lapack/src/GE_LinsolveMethods.inc @@ -158,35 +158,35 @@ PUBLIC :: LinSolve INTERFACE MODULE SUBROUTINE ge_solve_1(X, A, B, IPIV, SolverName, isTranspose, RANK, & & RCOND, S, info) - REAL( DFP ), INTENT( INOUT ) :: X( : ) + REAL(DFP), INTENT(INOUT) :: X(:) !! Unknown vector - REAL( DFP ), INTENT( IN ) :: A( :, : ) + REAL(DFP), INTENT(IN) :: A(:, :) !! General square matrix - REAL( DFP ), INTENT( IN ) :: B( : ) + REAL(DFP), INTENT(IN) :: B(:) !! RHS of Ax=B - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: IPIV( : ) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) !! Used for GESV - ! IPIV is INTEGER array, dimension (N) - ! The pivot indices that define the permutation matrix P; - ! row i of the matrix was interchanged with row IPIV(i). - CHARACTER( LEN = * ), OPTIONAL, INTENT( IN ) :: SolverName + ! IPIV is INTEGER array, dimension (N) + ! The pivot indices that define the permutation matrix P; + ! row i of the matrix was interchanged with row IPIV(i). + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: SolverName !! Name of the solver, when A is not square, default is GELS - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose !! If true then we solve $A^{T} x = y$ - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: RANK + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK !! Used in case of GELSD and GELSS !! The effective rank of A, i.e., the number of singular values !! which are greater than RCOND*S(1). - REAL( DFP ), OPTIONAL, INTENT( IN ) :: RCOND + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND !! RCOND is used to determine the effective rank of A. !! Singular values S(i) <= RCOND*S(1) are treated as zero. !! If RCOND < 0, machine precision is used instead. - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: S( : ) + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) !! Used in case of GELSD and GELSS !! S is DOUBLE PRECISION array, dimension (min(M,N)) !! The singular values of A in decreasing order. !! The condition number of A in the 2-norm = S(1)/S(min(m,n)). - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info END SUBROUTINE ge_solve_1 END INTERFACE @@ -213,22 +213,22 @@ END INTERFACE Solve INTERFACE MODULE SUBROUTINE ge_solve_2(X, A, B, IPIV, SolverName, isTranspose, RANK, & & RCOND, S, info) - REAL( DFP ), INTENT( INOUT ) :: X( :, : ) + REAL(DFP), INTENT(INOUT) :: X(:, :) !! Unknown vector - REAL( DFP ), INTENT( IN ) :: A( :, : ) + REAL(DFP), INTENT(IN) :: A(:, :) !! General square matrix - REAL( DFP ), INTENT( IN ) :: B( :, : ) + REAL(DFP), INTENT(IN) :: B(:, :) !! RHS of Ax=B - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: IPIV( : ) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) !! inverse of permuation - CHARACTER( LEN = * ), OPTIONAL, INTENT( IN ) :: SolverName + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: SolverName !! Name of the solver, when A is not square, default is GELS - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose !! If true then we solve A^T x = y. - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: RANK - REAL( DFP ), OPTIONAL, INTENT( IN ) :: RCOND - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: S( : ) - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info END SUBROUTINE ge_solve_2 END INTERFACE @@ -322,39 +322,38 @@ END INTERFACE Solve ! On exit, the first min(m,n) rows of A are overwritten with ! its right singular vectors, stored rowwise. - INTERFACE MODULE SUBROUTINE ge_linsolve_1(X, A, B, IPIV, SolverName, & & isTranspose, RANK, RCOND, S, info) - REAL( DFP ), INTENT( INOUT ) :: X( : ) + REAL(DFP), INTENT(INOUT) :: X(:) !! Unknown vector solution - REAL( DFP ), INTENT( INOUT ) :: A( :, : ) + REAL(DFP), INTENT(INOUT) :: A(:, :) !! General square/rectangle matrix, it will be modified on return - REAL( DFP ), INTENT( IN ) :: B( : ) + REAL(DFP), INTENT(IN) :: B(:) !! RHS of Ax=B - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: IPIV( : ) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) !! Used for GESV - ! IPIV is INTEGER array, dimension (N) - ! The pivot indices that define the permutation matrix P; - ! row i of the matrix was interchanged with row IPIV(i). - CHARACTER( LEN = * ), OPTIONAL, INTENT( IN ) :: SolverName + ! IPIV is INTEGER array, dimension (N) + ! The pivot indices that define the permutation matrix P; + ! row i of the matrix was interchanged with row IPIV(i). + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: SolverName !! Name of the solver, when A is not square, default is GELS - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose !! If true then we solve $A^{T} x = y$ - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: RANK + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK !! Used in case of GELSD and GELSS !! The effective rank of A, i.e., the number of singular values !! which are greater than RCOND*S(1). - REAL( DFP ), OPTIONAL, INTENT( IN ) :: RCOND + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND !! RCOND is used to determine the effective rank of A. !! Singular values S(i) <= RCOND*S(1) are treated as zero. !! If RCOND < 0, machine precision is used instead. - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: S( : ) + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) !! Used in case of GELSD and GELSS !! S is DOUBLE PRECISION array, dimension (min(M,N)) !! The singular values of A in decreasing order. !! The condition number of A in the 2-norm = S(1)/S(min(m,n)). - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info END SUBROUTINE ge_linsolve_1 END INTERFACE @@ -381,22 +380,22 @@ END INTERFACE LinSolve INTERFACE MODULE SUBROUTINE ge_linsolve_2(X, A, B, IPIV, SolverName, isTranspose, & & RANK, RCOND, S, info) - REAL( DFP ), INTENT( INOUT ) :: X( :, : ) + REAL(DFP), INTENT(INOUT) :: X(:, :) !! Unknown vector or solution - REAL( DFP ), INTENT( INOUT ) :: A( :, : ) + REAL(DFP), INTENT(INOUT) :: A(:, :) !! General square/ rectangle matrix, its content will be destroyed - REAL( DFP ), INTENT( IN ) :: B( :, : ) + REAL(DFP), INTENT(IN) :: B(:, :) !! RHS of Ax=B - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: IPIV( : ) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) !! inverse of permuation - CHARACTER( LEN = * ), OPTIONAL, INTENT( IN ) :: SolverName + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: SolverName !! Name of the solver, when A is not square, default is GELS - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose !! If true then we solve A^T x = y. - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: RANK - REAL( DFP ), OPTIONAL, INTENT( IN ) :: RCOND - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: S( : ) - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info END SUBROUTINE ge_linsolve_2 END INTERFACE @@ -419,38 +418,37 @@ END INTERFACE LinSolve ! We do not make any copy of B. The solution is returned in B. This ! means B will be destroyed on return. - INTERFACE MODULE SUBROUTINE ge_linsolve_3(A, B, IPIV, SolverName, & & isTranspose, RANK, RCOND, S, info) - REAL( DFP ), INTENT( INOUT ) :: A( :, : ) + REAL(DFP), INTENT(INOUT) :: A(:, :) !! General square/ rectangle matrix, its content will be modified on !! return - REAL( DFP ), INTENT( INOUT ) :: B( : ) + REAL(DFP), INTENT(INOUT) :: B(:) !! RHS of Ax=B, it will contain the solution on return - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: IPIV( : ) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) !! Used for GESV - ! IPIV is INTEGER array, dimension (N) - ! The pivot indices that define the permutation matrix P; - ! row i of the matrix was interchanged with row IPIV(i). - CHARACTER( LEN = * ), OPTIONAL, INTENT( IN ) :: SolverName + ! IPIV is INTEGER array, dimension (N) + ! The pivot indices that define the permutation matrix P; + ! row i of the matrix was interchanged with row IPIV(i). + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: SolverName !! Name of the solver, when A is not square, default is GELS - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose !! If true then we solve $A^{T} x = y$ - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: RANK + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK !! Used in case of GELSD and GELSS !! The effective rank of A, i.e., the number of singular values !! which are greater than RCOND*S(1). - REAL( DFP ), OPTIONAL, INTENT( IN ) :: RCOND + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND !! RCOND is used to determine the effective rank of A. !! Singular values S(i) <= RCOND*S(1) are treated as zero. !! If RCOND < 0, machine precision is used instead. - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: S( : ) + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) !! Used in case of GELSD and GELSS !! S is DOUBLE PRECISION array, dimension (min(M,N)) !! The singular values of A in decreasing order. !! The condition number of A in the 2-norm = S(1)/S(min(m,n)). - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info END SUBROUTINE ge_linsolve_3 END INTERFACE @@ -480,22 +478,22 @@ END INTERFACE Solve INTERFACE MODULE SUBROUTINE ge_linsolve_4(A, B, IPIV, SolverName, isTranspose, & & RANK, RCOND, S, info) - REAL( DFP ), INTENT( INOUT ) :: A( :, : ) + REAL(DFP), INTENT(INOUT) :: A(:, :) !! General square/rectangle matrix, its content will be modifie !! on return - REAL( DFP ), INTENT( INOUT ) :: B( :, : ) + REAL(DFP), INTENT(INOUT) :: B(:, :) !! RHS of Ax=B, it will be modified such that it contains solution on !! return - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: IPIV( : ) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: IPIV(:) !! inverse of permuation - CHARACTER( LEN = * ), OPTIONAL, INTENT( IN ) :: SolverName + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: SolverName !! Name of the solver, when A is not square, default is GELS - LOGICAL( LGT ), OPTIONAL, INTENT( IN ) :: isTranspose + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose !! If true then we solve A^T x = y. - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: RANK - REAL( DFP ), OPTIONAL, INTENT( IN ) :: RCOND - REAL( DFP ), OPTIONAL, INTENT( OUT ) :: S( : ) - INTEGER( I4B ), OPTIONAL, INTENT( OUT ) :: info + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: RANK + REAL(DFP), OPTIONAL, INTENT(IN) :: RCOND + REAL(DFP), OPTIONAL, INTENT(OUT) :: S(:) + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: info END SUBROUTINE ge_linsolve_4 END INTERFACE diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index 40fbacf2f..5912b52e1 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -22,6 +22,9 @@ TARGET_SOURCES( ${src_path}/LagrangeUtility.F90 ${src_path}/OrthogonalPolynomialUtility.F90 ${src_path}/JacobiPolynomialUtility.F90 + ${src_path}/LegendrePolynomialUtility.F90 + ${src_path}/LobattoPolynomialUtility.F90 + ${src_path}/UnscaledLobattoPolynomialUtility.F90 ${src_path}/Chebyshev1PolynomialUtility.F90 ${src_path}/LineInterpolationUtility.F90 ${src_path}/TriangleInterpolationUtility.F90 diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 index ca4f3b1ce..710be588c 100644 --- a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 @@ -34,12 +34,12 @@ MODULE Chebyshev1PolynomialUtility ! These recurrence coefficients are for monic jacobi polynomials. INTERFACE -MODULE PURE SUBROUTINE GetChebyshev1RecurrenceCoeff( n, alphaCoeff, & - & betaCoeff ) - INTEGER( I4B ), INTENT( IN ) :: n - REAL( DFP ), INTENT( OUT ) :: alphaCoeff(0:n-1) - REAL( DFP ), INTENT( OUT ) :: betaCoeff(0:n-1) -END SUBROUTINE GetChebyshev1RecurrenceCoeff + MODULE PURE SUBROUTINE GetChebyshev1RecurrenceCoeff(n, alphaCoeff, & + & betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) + REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) + END SUBROUTINE GetChebyshev1RecurrenceCoeff END INTERFACE PUBLIC :: GetChebyshev1RecurrenceCoeff @@ -53,12 +53,12 @@ END SUBROUTINE GetChebyshev1RecurrenceCoeff ! summary: Leading coefficient of Chebyshev1 polynomial INTERFACE -MODULE PURE FUNCTION Chebyshev1LeadingCoeff( n ) RESULT( ans ) - INTEGER( I4B ), INTENT( IN ) :: n + MODULE PURE FUNCTION Chebyshev1LeadingCoeff(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n !! order of Chebyshev1 polynomial - REAL( DFP ) :: ans + REAL(DFP) :: ans !! answer -END FUNCTION Chebyshev1LeadingCoeff + END FUNCTION Chebyshev1LeadingCoeff END INTERFACE PUBLIC :: Chebyshev1LeadingCoeff @@ -72,12 +72,12 @@ END FUNCTION Chebyshev1LeadingCoeff ! summary: Square norm of Chebyshev1 polynomial INTERFACE -MODULE PURE FUNCTION Chebyshev1NormSQR( n, alpha, beta ) RESULT( ans ) - INTEGER( I4B ), INTENT( IN ) :: n - REAL( DFP ), INTENT( IN ) :: alpha - REAL( DFP ), INTENT( IN ) :: beta - REAL( DFP ) :: ans -END FUNCTION Chebyshev1NormSQR + MODULE PURE FUNCTION Chebyshev1NormSQR(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans + END FUNCTION Chebyshev1NormSQR END INTERFACE !---------------------------------------------------------------------------- @@ -86,16 +86,16 @@ END FUNCTION Chebyshev1NormSQR !> author: Vikas Sharma, Ph. D. ! date: 3 Aug 2022 -! summary: Returns the Gauss quadrature points for Chebyshev1 Polynomial +! summary: Returns the Gauss quadrature points for Chebyshev1 Polynomial INTERFACE -MODULE SUBROUTINE Chebyshev1GaussQuadrature( n, pt, wt ) - INTEGER( I4B ), INTENT( IN ) :: n - REAL( DFP ), INTENT( OUT ) :: pt(:) + MODULE SUBROUTINE Chebyshev1GaussQuadrature(n, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(OUT) :: pt(:) !! the size is 1 to n - REAL( DFP ), INTENT( OUT ) :: wt(:) + REAL(DFP), INTENT(OUT) :: wt(:) !! the size is 1 to n -END SUBROUTINE Chebyshev1GaussQuadrature + END SUBROUTINE Chebyshev1GaussQuadrature END INTERFACE PUBLIC :: Chebyshev1GaussQuadrature @@ -106,18 +106,18 @@ END SUBROUTINE Chebyshev1GaussQuadrature !> author: Vikas Sharma, Ph. D. ! date: 3 Aug 2022 -! summary: Returns the GaussRadau quadrature points for Chebyshev1 Polynomial +! summary: Returns the GaussRadau quadrature points for Chebyshev1 Polynomial INTERFACE -MODULE SUBROUTINE Chebyshev1GaussRadauQuadrature( n, a, pt, wt ) - INTEGER( I4B ), INTENT( IN ) :: n - REAL( DFP ), INTENT( IN ) :: a + MODULE SUBROUTINE Chebyshev1GaussRadauQuadrature(n, a, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: a !! +1.0 or -1.0 - REAL( DFP ), INTENT( OUT ) :: pt(:) + REAL(DFP), INTENT(OUT) :: pt(:) !! the size is 1 to n+1 - REAL( DFP ), INTENT( OUT ) :: wt(:) + REAL(DFP), INTENT(OUT) :: wt(:) !! the size is 1 to n+1 -END SUBROUTINE Chebyshev1GaussRadauQuadrature + END SUBROUTINE Chebyshev1GaussRadauQuadrature END INTERFACE PUBLIC :: Chebyshev1GaussRadauQuadrature @@ -128,17 +128,17 @@ END SUBROUTINE Chebyshev1GaussRadauQuadrature !> author: Vikas Sharma, Ph. D. ! date: 3 Aug 2022 -! summary: Returns the GaussLobatto quadrature points for Chebyshev1 +! summary: Returns the GaussLobatto quadrature points for Chebyshev1 ! Polynomial INTERFACE -MODULE SUBROUTINE Chebyshev1GaussLobattoQuadrature( n, pt, wt ) - INTEGER( I4B ), INTENT( IN ) :: n - REAL( DFP ), INTENT( OUT ) :: pt(:) + MODULE SUBROUTINE Chebyshev1GaussLobattoQuadrature(n, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(OUT) :: pt(:) !! the size is 1 to n+2 - REAL( DFP ), INTENT( OUT ) :: wt(:) + REAL(DFP), INTENT(OUT) :: wt(:) !! the size is 1 to n+2 -END SUBROUTINE Chebyshev1GaussLobattoQuadrature + END SUBROUTINE Chebyshev1GaussLobattoQuadrature END INTERFACE PUBLIC :: Chebyshev1GaussLobattoQuadrature @@ -148,12 +148,12 @@ END SUBROUTINE Chebyshev1GaussLobattoQuadrature !---------------------------------------------------------------------------- INTERFACE -MODULE FUNCTION Chebyshev1Zeros( n ) RESULT( ans ) - INTEGER( I4B ), INTENT( IN ) :: n - REAL( DFP ) :: ans( n ) -END FUNCTION Chebyshev1Zeros + MODULE FUNCTION Chebyshev1Zeros(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(n) + END FUNCTION Chebyshev1Zeros END INTERFACE PUBLIC :: Chebyshev1Zeros -END MODULE Chebyshev1PolynomialUtility \ No newline at end of file +END MODULE Chebyshev1PolynomialUtility diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index 03f14b9d9..cd9551c1f 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -39,10 +39,10 @@ MODULE JacobiPolynomialUtility ! These recurrence coefficients are for monic jacobi polynomials. INTERFACE - MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff(n, alpha, beta, alphaCoeff, & - & betaCoeff) + MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff(n, alpha, beta, & + & alphaCoeff, betaCoeff) INTEGER(I4B), INTENT(IN) :: n - !! order of jacobi polynomial, it should be greater than 1 + !! order of jacobi polynomial, it should be greater than 1 REAL(DFP), INTENT(IN) :: alpha REAL(DFP), INTENT(IN) :: beta REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 index 4ffc15d2d..ea8dca7d9 100644 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -31,20 +31,33 @@ MODULE LegendrePolynomialUtility !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 +! date: 8 Sept 2022 ! summary: Return the recurrence coefficient for nth order polynomial ! !# Introduction ! ! These recurrence coefficients are for monic Legendre polynomials. +! +!$$ +! \pi_{n+1}=\left(x-\alpha_{n}\right)\pi_{n}-\beta_{n}\pi_{n-1},\quad n=0,1,2 +!$$ +! +!$$ +! \alpha_{n}=0,n\ge0 +!$$ +! +!$$ +! \beta_{0}=2 +!$$ +! +!$$ +! \beta_{n\ge1}=\frac{n^{2}}{4n^{2}-1} +!$$ INTERFACE - MODULE PURE SUBROUTINE GetLegendreRecurrenceCoeff(n, alpha, beta, & - & alphaCoeff, betaCoeff) + MODULE PURE SUBROUTINE GetLegendreRecurrenceCoeff(n, alphaCoeff, betaCoeff) INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomial, it should be greater than 1 - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) END SUBROUTINE GetLegendreRecurrenceCoeff @@ -57,17 +70,22 @@ END SUBROUTINE GetLegendreRecurrenceCoeff !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 +! date: 8 Sept 2022 ! summary: Leading coefficient of Legendre polynomial +! +!# Introduction +! +! Leading coefficient of legendre polynomial +! +!$$ +! k_{n}=\frac{\left(2n\right)!}{2^{n}\left(n!\right)^{2}} +!$$ +! INTERFACE - MODULE PURE FUNCTION LegendreLeadingCoeff(n, alpha, beta) RESULT(ans) + MODULE PURE FUNCTION LegendreLeadingCoeff(n) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha in Legendre poly - REAL(DFP), INTENT(IN) :: beta - !! beta in Legendre poly REAL(DFP) :: ans !! answer END FUNCTION LegendreLeadingCoeff @@ -80,50 +98,48 @@ END FUNCTION LegendreLeadingCoeff !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2 Aug 2022 +! date: 8 Sept 2022 ! summary: Square norm of Legendre polynomial ! !# Introduction ! -! This function returns the following +! This function returns the square norm of legendre polynomial ! !$$ -!\Vert P_{n}^{\alpha,\beta}\Vert_{d\lambda}^{2}=\int_{-1}^{+1}P_{n}^ -!{\alpha,\beta}P_{n}^{\alpha,\beta}(1-x)^{\alpha}(1+x)^{\beta}dx +! \Vert P_{n}\Vert^{2}=:h_{n}=\frac{2}{2n+1} !$$ INTERFACE - MODULE PURE FUNCTION LegendreNormSQR(n, alpha, beta) RESULT(ans) + MODULE PURE FUNCTION LegendreNormSQR(n) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta REAL(DFP) :: ans END FUNCTION LegendreNormSQR END INTERFACE !---------------------------------------------------------------------------- -! LegendreLegendreMatrix +! LegendreJacobiMatrix !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the Jacobi matrix for Legendre polynomial + INTERFACE - MODULE PURE SUBROUTINE LegendreLegendreMatrix(n, alpha, beta, D, E, & - & alphaCoeff, betaCoeff) + MODULE PURE SUBROUTINE LegendreJacobiMatrix(n, D, E, alphaCoeff, betaCoeff) INTEGER(I4B), INTENT(IN) :: n !! n should be greater than or equal to 1 - REAL(DFP), INTENT(IN) :: alpha - !! alpha of jacobu poly - REAL(DFP), INTENT(IN) :: beta - !! beta of Legendre poly REAL(DFP), INTENT(OUT) :: D(:) !! the size should be 1:n REAL(DFP), INTENT(OUT) :: E(:) !! the size should be 1:n-1 REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + !! recurrence coefficient of monic legendre polynomial, from 0 to n-1 REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE LegendreLegendreMatrix + !! recurrence coefficient of monic legendre polynomial, from 0 to n-1 + END SUBROUTINE LegendreJacobiMatrix END INTERFACE -PUBLIC :: LegendreLegendreMatrix +PUBLIC :: LegendreJacobiMatrix !---------------------------------------------------------------------------- ! LegendreGaussQuadrature @@ -131,7 +147,7 @@ END SUBROUTINE LegendreLegendreMatrix !> author: Vikas Sharma, Ph. D. ! date: 3 Aug 2022 -! summary: Returns the Gauss quadrature points for Legendre Polynomial +! summary: Returns the Gauss quadrature points for Legendre Polynomial ! !# Introduction ! @@ -142,11 +158,9 @@ END SUBROUTINE LegendreLegendreMatrix ! All Gauss-Quadrature points are inside $(-1, 1)$ INTERFACE - MODULE SUBROUTINE LegendreGaussQuadrature(n, alpha, beta, pt, wt) + MODULE SUBROUTINE LegendreGaussQuadrature(n, pt, wt) INTEGER(I4B), INTENT(IN) :: n !! It represents the order of Legendre polynomial - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta REAL(DFP), INTENT(OUT) :: pt(:) !! the size is 1 to n REAL(DFP), INTENT(OUT) :: wt(:) @@ -157,30 +171,26 @@ END SUBROUTINE LegendreGaussQuadrature PUBLIC :: LegendreGaussQuadrature !---------------------------------------------------------------------------- -! LegendreLegendreRadauMatrix +! LegendreJacobiRadauMatrix !---------------------------------------------------------------------------- INTERFACE - MODULE PURE SUBROUTINE LegendreLegendreRadauMatrix(a, n, alpha, beta, D, & - & E, alphaCoeff, betaCoeff) + MODULE PURE SUBROUTINE LegendreJacobiRadauMatrix(a, n, D, E, alphaCoeff, & + & betaCoeff) REAL(DFP), INTENT(IN) :: a !! one of the end of the domain INTEGER(I4B), INTENT(IN) :: n !! n should be greater than or equal to 1 - REAL(DFP), INTENT(IN) :: alpha - !! alpha of jacobu poly - REAL(DFP), INTENT(IN) :: beta - !! beta of Legendre poly REAL(DFP), INTENT(OUT) :: D(:) !! the size should be 1:n+1 REAL(DFP), INTENT(OUT) :: E(:) !! the size should be 1:n REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE LegendreLegendreRadauMatrix + END SUBROUTINE LegendreJacobiRadauMatrix END INTERFACE -PUBLIC :: LegendreLegendreRadauMatrix +PUBLIC :: LegendreJacobiRadauMatrix !---------------------------------------------------------------------------- ! LegendreGaussRadauQuadrature @@ -208,16 +218,12 @@ END SUBROUTINE LegendreLegendreRadauMatrix ! If $a=-1$ then 1st quadrature point will be -1 INTERFACE - MODULE SUBROUTINE LegendreGaussRadauQuadrature(a, n, alpha, beta, pt, wt) + MODULE SUBROUTINE LegendreGaussRadauQuadrature(a, n, pt, wt) REAL(DFP), INTENT(IN) :: a !! the value of one of the end points !! it should be either -1 or +1 INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomial - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Legendre polynomial - REAL(DFP), INTENT(IN) :: beta - !! beta of Legendre polynomial REAL(DFP), INTENT(OUT) :: pt(:) !! n+1 quadrature points from 1 to n+1 REAL(DFP), INTENT(OUT) :: wt(:) @@ -228,28 +234,24 @@ END SUBROUTINE LegendreGaussRadauQuadrature PUBLIC :: LegendreGaussRadauQuadrature !---------------------------------------------------------------------------- -! LegendreLegendreLobattoMatrix +! LegendreLegendreLobattoMatrix !---------------------------------------------------------------------------- INTERFACE - MODULE PURE SUBROUTINE LegendreLegendreLobattoMatrix(n, alpha, beta, D, & - & E, alphaCoeff, betaCoeff) + MODULE PURE SUBROUTINE LegendreJacobiLobattoMatrix(n, D, E, alphaCoeff, & + & betaCoeff) INTEGER(I4B), INTENT(IN) :: n !! n should be greater than or equal to 1 - REAL(DFP), INTENT(IN) :: alpha - !! alpha of jacobu poly - REAL(DFP), INTENT(IN) :: beta - !! beta of Legendre poly REAL(DFP), INTENT(OUT) :: D(:) !! the size should be 1:n+2 REAL(DFP), INTENT(OUT) :: E(:) !! the size should be 1:n+1 REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) - END SUBROUTINE LegendreLegendreLobattoMatrix + END SUBROUTINE LegendreJacobiLobattoMatrix END INTERFACE -PUBLIC :: LegendreLegendreLobattoMatrix +PUBLIC :: LegendreJacobiLobattoMatrix !---------------------------------------------------------------------------- ! LegendreGaussLobattoQuadrature @@ -278,11 +280,9 @@ END SUBROUTINE LegendreLegendreLobattoMatrix ! Here n is the order of Legendre polynomial. INTERFACE - MODULE SUBROUTINE LegendreGaussLobattoQuadrature(n, alpha, beta, pt, wt) + MODULE SUBROUTINE LegendreGaussLobattoQuadrature(n, pt, wt) INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomials - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta REAL(DFP), INTENT(OUT) :: pt(:) !! n+2 quad points indexed from 1 to n+2 REAL(DFP), INTENT(OUT) :: wt(:) @@ -301,11 +301,9 @@ END SUBROUTINE LegendreGaussLobattoQuadrature ! summary: Returns zeros of Legendre polynomials INTERFACE - MODULE FUNCTION LegendreZeros(n, alpha, beta) RESULT(ans) + MODULE FUNCTION LegendreZeros(n) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n !! order of Legendre polynomial - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta REAL(DFP) :: ans(n) END FUNCTION LegendreZeros END INTERFACE @@ -318,7 +316,8 @@ END FUNCTION LegendreZeros !> author: Vikas Sharma, Ph. D. ! date: 6 Sept 2022 -! summary: This routine can return Legendre-Gauss, Legendre-Radau, Legendre-Lobatto +! summary: This routine can return Legendre-Gauss, Legendre-Radau, +! Legendre-Lobatto ! !# Introduction ! @@ -336,16 +335,12 @@ END FUNCTION LegendreZeros ! INTERFACE - MODULE SUBROUTINE LegendreQuadrature(n, alpha, beta, pt, wt, quadType) + MODULE SUBROUTINE LegendreQuadrature(n, pt, wt, quadType, onlyInside) INTEGER(I4B), INTENT(IN) :: n !! number of quadrature points, the order will be computed as follows !! for quadType = Gauss, n is same as order of Legendre polynomial !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 !! for quadType = GaussLobatto, n = order+2 - REAL(DFP), INTENT(IN) :: alpha - !! alpha of Legendre polynomial - REAL(DFP), INTENT(IN) :: beta - !! beta of Legendre polynomial REAL(DFP), INTENT(OUT) :: pt(n) !! n+1 quadrature points from 1 to n+1 REAL(DFP), INTENT(OUT) :: wt(n) @@ -355,13 +350,15 @@ MODULE SUBROUTINE LegendreQuadrature(n, alpha, beta, pt, wt, quadType) !! GaussRadauLeft !! GaussRadauRight !! GaussLobatto + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: onlyInside + !! only inside END SUBROUTINE LegendreQuadrature END INTERFACE PUBLIC :: LegendreQuadrature !---------------------------------------------------------------------------- -! LegendreEvalAll +! LegendreEval !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -380,25 +377,22 @@ END SUBROUTINE LegendreQuadrature ! X. INTERFACE - MODULE PURE FUNCTION LegendreEvalAll1(n, alpha, beta, x) RESULT(ans) + MODULE PURE FUNCTION LegendreEval1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans(n + 1) - !! Evaluate Legendre polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION LegendreEvalAll1 + REAL(DFP) :: ans + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreEval1 END INTERFACE -INTERFACE LegendreEvalAll - MODULE PROCEDURE LegendreEvalAll1 -END INTERFACE LegendreEvalAll +INTERFACE LegendreEval + MODULE PROCEDURE LegendreEval1 +END INTERFACE LegendreEval -PUBLIC :: LegendreEvalAll +PUBLIC :: LegendreEval !---------------------------------------------------------------------------- -! LegendreEvalUpto +! LegendreEval !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -417,23 +411,20 @@ END FUNCTION LegendreEvalAll1 ! X. INTERFACE - MODULE PURE FUNCTION LegendreEvalAll2(n, alpha, beta, x) RESULT(ans) + MODULE PURE FUNCTION LegendreEval2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x), n + 1) - !! Evaluate Legendre polynomial of order = 0 to n (total n+1) - !! at point x - END FUNCTION LegendreEvalAll2 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreEval2 END INTERFACE -INTERFACE LegendreEvalAll - MODULE PROCEDURE LegendreEvalAll2 -END INTERFACE LegendreEvalAll +INTERFACE LegendreEval + MODULE PROCEDURE LegendreEval2 +END INTERFACE LegendreEval !---------------------------------------------------------------------------- -! LegendreEval +! LegendreEvalAll !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -452,24 +443,23 @@ END FUNCTION LegendreEvalAll2 ! X. INTERFACE - MODULE PURE FUNCTION LegendreEval1(n, alpha, beta, x) RESULT(ans) + MODULE PURE FUNCTION LegendreEvalAll1(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta REAL(DFP), INTENT(IN) :: x - REAL(DFP) :: ans - !! Evaluate Legendre polynomial of order n at point x - END FUNCTION LegendreEval1 + REAL(DFP) :: ans(n + 1) + !! Evaluate Legendre polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LegendreEvalAll1 END INTERFACE -INTERFACE LegendreEval - MODULE PROCEDURE LegendreEval1 -END INTERFACE LegendreEval +INTERFACE LegendreEvalAll + MODULE PROCEDURE LegendreEvalAll1 +END INTERFACE LegendreEvalAll -PUBLIC :: LegendreEval +PUBLIC :: LegendreEvalAll !---------------------------------------------------------------------------- -! LegendreEvalUpto +! LegendreEvalAll !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -488,18 +478,185 @@ END FUNCTION LegendreEval1 ! X. INTERFACE - MODULE PURE FUNCTION LegendreEval2(n, alpha, beta, x) RESULT(ans) + MODULE PURE FUNCTION LegendreEvalAll2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta REAL(DFP), INTENT(IN) :: x(:) - REAL(DFP) :: ans(SIZE(x)) - !! Evaluate Legendre polynomial of order n at point x - END FUNCTION LegendreEval2 + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Legendre polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LegendreEvalAll2 END INTERFACE -INTERFACE LegendreEval - MODULE PROCEDURE LegendreEval2 -END INTERFACE LegendreEval +INTERFACE LegendreEvalAll + MODULE PROCEDURE LegendreEvalAll2 +END INTERFACE LegendreEvalAll + +!---------------------------------------------------------------------------- +! LegendreMonomialExpansionAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of all legendre polynomials +! +!# Introduction +! +! Returns all the monomial expansion of all legendre polynomials +! +!- n : is the order of the polynomial +!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 +! +! for example, n=5, we have following structure of ans +! +! | P0 | P1 | P2 | P3 | P4 | P5 | +! |----|----|------|------|-------|-------| +! | 1 | 0 | -0.5 | -0 | 0.375 | 0 | +! | 0 | 1 | 0 | -1.5 | -0 | 1.875 | +! | 0 | 0 | 1.5 | 0 | -3.75 | -0 | +! | 0 | 0 | 0 | 2.5 | 0 | -8.75 | +! | 0 | 0 | 0 | 0 | 4.375 | 0 | +! | 0 | 0 | 0 | 0 | 0 | 7.875 | + +INTERFACE + MODULE PURE FUNCTION LegendreMonomialExpansionAll(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1, 1:n + 1) + END FUNCTION LegendreMonomialExpansionAll +END INTERFACE + +PUBLIC :: LegendreMonomialExpansionAll + +!---------------------------------------------------------------------------- +! LegendreMonomialExpansion +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of a legendre polynomials +! +!# Introduction +! +! Returns all the monomial expansion of a legendre polynomials +! +!- n : is the order of the polynomial +!- ans(:) contains the coefficient of monomials for polynomial order=n +! + +INTERFACE + MODULE PURE FUNCTION LegendreMonomialExpansion(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1) + END FUNCTION LegendreMonomialExpansion +END INTERFACE + +PUBLIC :: LegendreMonomialExpansion + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of legendre polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of legendre polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(1:n + 1) + END FUNCTION LegendreGradientEvalAll1 +END INTERFACE +!! + +INTERFACE LegendreGradientEvalAll + MODULE PROCEDURE LegendreGradientEvalAll1 +END INTERFACE LegendreGradientEvalAll + +PUBLIC :: LegendreGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of legendre polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of legendre polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) + END FUNCTION LegendreGradientEvalAll2 +END INTERFACE +!! + +INTERFACE LegendreGradientEvalAll + MODULE PROCEDURE LegendreGradientEvalAll2 +END INTERFACE LegendreGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of legendre polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of legendre polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION LegendreGradientEval1 +END INTERFACE +!! + +INTERFACE LegendreGradientEval + MODULE PROCEDURE LegendreGradientEval1 +END INTERFACE LegendreGradientEval + +PUBLIC :: LegendreGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of legendre polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of legendre polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x)) + END FUNCTION LegendreGradientEval2 +END INTERFACE +!! + +INTERFACE LegendreGradientEval + MODULE PROCEDURE LegendreGradientEval2 +END INTERFACE LegendreGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- END MODULE LegendrePolynomialUtility diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 new file mode 100644 index 000000000..51ee1a58d --- /dev/null +++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 @@ -0,0 +1,418 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Utility related to Lobatto Polynomials is defined. +! +!{!pages/LobattoPolynomialUtility.md!} + +MODULE LobattoPolynomialUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! LobattoLeadingCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Leading coefficient of Lobatto polynomial + +INTERFACE + MODULE PURE FUNCTION LobattoLeadingCoeff(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Lobatto polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION LobattoLeadingCoeff +END INTERFACE + +PUBLIC :: LobattoLeadingCoeff + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of Lobatto polynomial +! + +INTERFACE + MODULE PURE FUNCTION LobattoNormSQR(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans + END FUNCTION LobattoNormSQR +END INTERFACE + +!---------------------------------------------------------------------------- +! LobattoZeros +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Returns zeros of Lobatto polynomials + +INTERFACE + MODULE FUNCTION LobattoZeros(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Lobatto polynomial, should be greater than equal to 2 + REAL(DFP) :: ans(n) + !! + END FUNCTION LobattoZeros +END INTERFACE + +PUBLIC :: LobattoZeros + +!---------------------------------------------------------------------------- +! LobattoEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Lobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LobattoEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + !! Evaluate Lobatto polynomial of order n at point x + END FUNCTION LobattoEval1 +END INTERFACE + +INTERFACE LobattoEval + MODULE PROCEDURE LobattoEval1 +END INTERFACE LobattoEval + +PUBLIC :: LobattoEval + +!---------------------------------------------------------------------------- +! LobattoEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Lobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LobattoEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Lobatto polynomial of order n at point x + END FUNCTION LobattoEval2 +END INTERFACE + +INTERFACE LobattoEval + MODULE PROCEDURE LobattoEval2 +END INTERFACE LobattoEval + +!---------------------------------------------------------------------------- +! LobattoEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Lobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LobattoEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(n + 1) + !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LobattoEvalAll1 +END INTERFACE + +INTERFACE LobattoEvalAll + MODULE PROCEDURE LobattoEvalAll1 +END INTERFACE LobattoEvalAll + +PUBLIC :: LobattoEvalAll + +!---------------------------------------------------------------------------- +! LobattoEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate Lobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point +! X. + +INTERFACE + MODULE PURE FUNCTION LobattoEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LobattoEvalAll2 +END INTERFACE + +INTERFACE LobattoEvalAll + MODULE PROCEDURE LobattoEvalAll2 +END INTERFACE LobattoEvalAll + +!---------------------------------------------------------------------------- +! LobattoMonomialExpansionAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of all Lobatto polynomials +! +!# Introduction +! +! Returns all the monomial expansion of all Lobatto polynomials +! +!- n : is the order of the polynomial +!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 +! +! for example, n=5, we have following structure of ans +! +! | P0 | P1 | P2 | P3 | P4 | P5 | +! |----|----|------|------|-------|-------| +! | 1 | 0 | -0.5 | -0 | 0.375 | 0 | +! | 0 | 1 | 0 | -1.5 | -0 | 1.875 | +! | 0 | 0 | 1.5 | 0 | -3.75 | -0 | +! | 0 | 0 | 0 | 2.5 | 0 | -8.75 | +! | 0 | 0 | 0 | 0 | 4.375 | 0 | +! | 0 | 0 | 0 | 0 | 0 | 7.875 | + +INTERFACE + MODULE PURE FUNCTION LobattoMonomialExpansionAll(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1, 1:n + 1) + END FUNCTION LobattoMonomialExpansionAll +END INTERFACE + +PUBLIC :: LobattoMonomialExpansionAll + +!---------------------------------------------------------------------------- +! LobattoMonomialExpansion +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of a Lobatto polynomials +! +!# Introduction +! +! Returns all the monomial expansion of a Lobatto polynomials +! +!- n : is the order of the polynomial +!- ans(:) contains the coefficient of monomials for polynomial order=n +! + +INTERFACE + MODULE PURE FUNCTION LobattoMonomialExpansion(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1) + END FUNCTION LobattoMonomialExpansion +END INTERFACE + +PUBLIC :: LobattoMonomialExpansion + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Lobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Lobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LobattoGradientEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(1:n + 1) + END FUNCTION LobattoGradientEvalAll1 +END INTERFACE +!! + +INTERFACE LobattoGradientEvalAll + MODULE PROCEDURE LobattoGradientEvalAll1 +END INTERFACE LobattoGradientEvalAll + +PUBLIC :: LobattoGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Lobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Lobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LobattoGradientEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) + END FUNCTION LobattoGradientEvalAll2 +END INTERFACE +!! + +INTERFACE LobattoGradientEvalAll + MODULE PROCEDURE LobattoGradientEvalAll2 +END INTERFACE LobattoGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Lobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Lobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LobattoGradientEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION LobattoGradientEval1 +END INTERFACE +!! + +INTERFACE LobattoGradientEval + MODULE PROCEDURE LobattoGradientEval1 +END INTERFACE LobattoGradientEval + +PUBLIC :: LobattoGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Lobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Lobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION LobattoGradientEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x)) + END FUNCTION LobattoGradientEval2 +END INTERFACE + +INTERFACE LobattoGradientEval + MODULE PROCEDURE LobattoGradientEval2 +END INTERFACE LobattoGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Lobatto mass matrix + +INTERFACE + MODULE PURE FUNCTION LobattoMassMatrix(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(n + 1, n + 1) + END FUNCTION LobattoMassMatrix +END INTERFACE + +PUBLIC :: LobattoMassMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Lobatto mass matrix + +INTERFACE + MODULE PURE FUNCTION LobattoStiffnessMatrix(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(n + 1, n + 1) + END FUNCTION LobattoStiffnessMatrix +END INTERFACE + +PUBLIC :: LobattoStiffnessMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE LobattoPolynomialUtility diff --git a/src/modules/Polynomial/src/PolynomialUtility.F90 b/src/modules/Polynomial/src/PolynomialUtility.F90 index 1779d2d06..041110030 100644 --- a/src/modules/Polynomial/src/PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/PolynomialUtility.F90 @@ -20,6 +20,9 @@ MODULE PolynomialUtility USE LagrangeUtility USE OrthogonalPolynomialUtility USE JacobiPolynomialUtility +USE LegendrePolynomialUtility +USE LobattoPolynomialUtility +USE UnscaledLobattoPolynomialUtility USE Chebyshev1PolynomialUtility USE LineInterpolationUtility USE TriangleInterpolationUtility diff --git a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 new file mode 100644 index 000000000..afde6420c --- /dev/null +++ b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 @@ -0,0 +1,421 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Utility related to UnscaledLobatto Polynomials is defined. +! +!{!pages/UnscaledLobattoPolynomialUtility.md!} + +MODULE UnscaledLobattoPolynomialUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! UnscaledLobattoLeadingCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Leading coefficient of UnscaledLobatto polynomial + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoLeadingCoeff(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of UnscaledLobatto polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION UnscaledLobattoLeadingCoeff +END INTERFACE + +PUBLIC :: UnscaledLobattoLeadingCoeff + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of UnscaledLobatto polynomial +! + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoNormSQR(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans + END FUNCTION UnscaledLobattoNormSQR +END INTERFACE + +!---------------------------------------------------------------------------- +! UnscaledLobattoZeros +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Returns zeros of UnscaledLobatto polynomials + +INTERFACE + MODULE FUNCTION UnscaledLobattoZeros(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of UnscaledLobatto polynomial, should be greater than equal to 2 + REAL(DFP) :: ans(n) + !! + END FUNCTION UnscaledLobattoZeros +END INTERFACE + +PUBLIC :: UnscaledLobattoZeros + +!---------------------------------------------------------------------------- +! UnscaledLobattoEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! +!# Introduction +! +! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto +! polynomials at the point X. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + !! Evaluate UnscaledLobatto polynomial of order n at point x + END FUNCTION UnscaledLobattoEval1 +END INTERFACE + +INTERFACE UnscaledLobattoEval + MODULE PROCEDURE UnscaledLobattoEval1 +END INTERFACE UnscaledLobattoEval + +PUBLIC :: UnscaledLobattoEval + +!---------------------------------------------------------------------------- +! UnscaledLobattoEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at +! several points +! +!# Introduction +! +! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at +! the point X. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate UnscaledLobatto polynomial of order n at point x + END FUNCTION UnscaledLobattoEval2 +END INTERFACE + +INTERFACE UnscaledLobattoEval + MODULE PROCEDURE UnscaledLobattoEval2 +END INTERFACE UnscaledLobattoEval + +!---------------------------------------------------------------------------- +! UnscaledLobattoEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at +! several points +! +!# Introduction +! +! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at +! the point X. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(n + 1) + !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION UnscaledLobattoEvalAll1 +END INTERFACE + +INTERFACE UnscaledLobattoEvalAll + MODULE PROCEDURE UnscaledLobattoEvalAll1 +END INTERFACE UnscaledLobattoEvalAll + +PUBLIC :: UnscaledLobattoEvalAll + +!---------------------------------------------------------------------------- +! UnscaledLobattoEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at +! several points +! +!# Introduction +! +! Evaluate UnscaledLobatto polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at +! the point X. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION UnscaledLobattoEvalAll2 +END INTERFACE + +INTERFACE UnscaledLobattoEvalAll + MODULE PROCEDURE UnscaledLobattoEvalAll2 +END INTERFACE UnscaledLobattoEvalAll + +!---------------------------------------------------------------------------- +! UnscaledLobattoMonomialExpansionAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary:Returns the monomial expansion of all UnscaledLobatto polynomials +! +!# Introduction +! +! Returns all the monomial expansion of all UnscaledLobatto polynomials +! +!- n : is the order of the polynomial +!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 +! +! for example, n=5, we have following structure of ans +! +! | P0 | P1 | P2 | P3 | P4 | P5 | +! |----|----|------|------|-------|-------| +! | 1 | 0 | -0.5 | -0 | 0.375 | 0 | +! | 0 | 1 | 0 | -1.5 | -0 | 1.875 | +! | 0 | 0 | 1.5 | 0 | -3.75 | -0 | +! | 0 | 0 | 0 | 2.5 | 0 | -8.75 | +! | 0 | 0 | 0 | 0 | 4.375 | 0 | +! | 0 | 0 | 0 | 0 | 0 | 7.875 | + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoMonomialExpansionAll(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1, 1:n + 1) + END FUNCTION UnscaledLobattoMonomialExpansionAll +END INTERFACE + +PUBLIC :: UnscaledLobattoMonomialExpansionAll + +!---------------------------------------------------------------------------- +! UnscaledLobattoMonomialExpansion +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of a UnscaledLobatto polynomials +! +!# Introduction +! +! Returns all the monomial expansion of a UnscaledLobatto polynomials +! +!- n : is the order of the polynomial +!- ans(:) contains the coefficient of monomials for polynomial order=n +! + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoMonomialExpansion(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1) + END FUNCTION UnscaledLobattoMonomialExpansion +END INTERFACE + +PUBLIC :: UnscaledLobattoMonomialExpansion + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of UnscaledLobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoGradientEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(1:n + 1) + END FUNCTION UnscaledLobattoGradientEvalAll1 +END INTERFACE +!! + +INTERFACE UnscaledLobattoGradientEvalAll + MODULE PROCEDURE UnscaledLobattoGradientEvalAll1 +END INTERFACE UnscaledLobattoGradientEvalAll + +PUBLIC :: UnscaledLobattoGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of UnscaledLobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoGradientEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) + END FUNCTION UnscaledLobattoGradientEvalAll2 +END INTERFACE +!! + +INTERFACE UnscaledLobattoGradientEvalAll + MODULE PROCEDURE UnscaledLobattoGradientEvalAll2 +END INTERFACE UnscaledLobattoGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of UnscaledLobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoGradientEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION UnscaledLobattoGradientEval1 +END INTERFACE +!! + +INTERFACE UnscaledLobattoGradientEval + MODULE PROCEDURE UnscaledLobattoGradientEval1 +END INTERFACE UnscaledLobattoGradientEval + +PUBLIC :: UnscaledLobattoGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of UnscaledLobatto polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoGradientEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x)) + END FUNCTION UnscaledLobattoGradientEval2 +END INTERFACE + +INTERFACE UnscaledLobattoGradientEval + MODULE PROCEDURE UnscaledLobattoGradientEval2 +END INTERFACE UnscaledLobattoGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: UnscaledLobatto mass matrix + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoMassMatrix(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(n + 1, n + 1) + END FUNCTION UnscaledLobattoMassMatrix +END INTERFACE + +PUBLIC :: UnscaledLobattoMassMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: UnscaledLobatto mass matrix + +INTERFACE + MODULE PURE FUNCTION UnscaledLobattoStiffnessMatrix(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(n + 1, n + 1) + END FUNCTION UnscaledLobattoStiffnessMatrix +END INTERFACE + +PUBLIC :: UnscaledLobattoStiffnessMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE UnscaledLobattoPolynomialUtility diff --git a/src/modules/Polynomial/src/assets/LegendrePolynomials.F90 b/src/modules/Polynomial/src/assets/LegendrePolynomials.F90 new file mode 100644 index 000000000..4be39c35e --- /dev/null +++ b/src/modules/Polynomial/src/assets/LegendrePolynomials.F90 @@ -0,0 +1,1046 @@ +subroutine p_polynomial_prime2(m, n, x, vpp) + +!*****************************************************************************80 +! +!! P_POLYNOMIAL_PRIME2: second derivative of Legendre polynomials P(n,x). +! +! Discussion: +! +! P(0,X) = 1 +! P(1,X) = X +! P(N,X) = ( (2*N-1)*X*P(N-1,X)-(N-1)*P(N-2,X) ) / N +! +! P'(0,X) = 0 +! P'(1,X) = 1 +! P'(N,X) = ( (2*N-1)*(P(N-1,X)+X*P'(N-1,X)-(N-1)*P'(N-2,X) ) / N +! +! P"(0,X) = 0 +! P"(1,X) = 0 +! P"(N,X) = ( (2*N-1)*(2*P(N-1,X)+X*P"(N-1,X)-(N-1)*P"(N-2,X) ) / N +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 May 2013 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Daniel Zwillinger, editor, +! CRC Standard Mathematical Tables and Formulae, +! 30th Edition, +! CRC Press, 1996. +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the number of evaluation points. +! +! Input, integer ( kind = 4 ) N, the highest order polynomial to evaluate. +! Note that polynomials 0 through N will be evaluated. +! +! Input, real ( kind = rk ) X(M), the evaluation points. +! +! Output, real ( kind = rk ) VPP(M,0:N), the second derivative of the +! Legendre polynomials of order 0 through N. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) i + real(kind=rk) v(m, 0:n) + real(kind=rk) vp(m, 0:n) + real(kind=rk) vpp(m, 0:n) + real(kind=rk) x(m) + + if (n < 0) then + return + end if + + v(1:m, 0) = 1.0D+00 + vp(1:m, 0) = 0.0D+00 + vpp(1:m, 0) = 0.0D+00 + + if (n < 1) then + return + end if + + v(1:m, 1) = x(1:m) + vp(1:m, 1) = 1.0D+00 + vpp(1:m, 1) = 0.0D+00 + + do i = 2, n + + v(1:m, i) = & + (real(2 * i - 1, kind=rk) * x(1:m) * v(1:m, i - 1) & + - real(i - 1, kind=rk) * v(1:m, i - 2)) & + / real(i, kind=rk) + + vp(1:m, i) = & + (real(2 * i - 1, kind=rk) * (v(1:m, i - 1) + x(1:m) * vp(1:m, i - 1)) & + - real(i - 1, kind=rk) * vp(1:m, i - 2)) & + / real(i, kind=rk) + + vpp(1:m, i) = & + (real(2 * i - 1, kind=rk) * (2.0D+00 * vp(1:m, i - 1) & + + x(1:m) * vpp(1:m, i - 1)) & + - real(i - 1, kind=rk) * vpp(1:m, i - 2)) & + / real(i, kind=rk) + + end do + + return +end +subroutine p_polynomial_value(m, n, x, v) + +!*****************************************************************************80 +! +!! P_POLYNOMIAL_VALUE evaluates the Legendre polynomials P(n,x). +! +! Discussion: +! +! P(n,1) = 1. +! P(n,-1) = (-1)^N. +! | P(n,x) | <= 1 in [-1,1]. +! +! The N zeroes of P(n,x) are the abscissas used for Gauss-Legendre +! quadrature of the integral of a function F(X) with weight function 1 +! over the interval [-1,1]. +! +! The Legendre polynomials are orthogonal under the inner product defined +! as integration from -1 to 1: +! +! Integral ( -1 <= X <= 1 ) P(I,X) * P(J,X) dX +! = 0 if I =/= J +! = 2 / ( 2*I+1 ) if I = J. +! +! Except for P(0,X), the integral of P(I,X) from -1 to 1 is 0. +! +! A function F(X) defined on [-1,1] may be approximated by the series +! C0*P(0,x) + C1*P(1,x) + ... + CN*P(n,x) +! where +! C(I) = (2*I+1)/(2) * Integral ( -1 <= X <= 1 ) F(X) P(I,x) dx. +! +! The formula is: +! +! P(n,x) = (1/2^N) * sum ( 0 <= M <= N/2 ) C(N,M) C(2N-2M,N) X^(N-2*M) +! +! Differential equation: +! +! (1-X*X) * P(n,x)'' - 2 * X * P(n,x)' + N * (N+1) = 0 +! +! First terms: +! +! P( 0,x) = 1 +! P( 1,x) = 1 X +! P( 2,x) = ( 3 X^2 - 1)/2 +! P( 3,x) = ( 5 X^3 - 3 X)/2 +! P( 4,x) = ( 35 X^4 - 30 X^2 + 3)/8 +! P( 5,x) = ( 63 X^5 - 70 X^3 + 15 X)/8 +! P( 6,x) = ( 231 X^6 - 315 X^4 + 105 X^2 - 5)/16 +! P( 7,x) = ( 429 X^7 - 693 X^5 + 315 X^3 - 35 X)/16 +! P( 8,x) = ( 6435 X^8 - 12012 X^6 + 6930 X^4 - 1260 X^2 + 35)/128 +! P( 9,x) = (12155 X^9 - 25740 X^7 + 18018 X^5 - 4620 X^3 + 315 X)/128 +! P(10,x) = (46189 X^10-109395 X^8 + 90090 X^6 - 30030 X^4 + 3465 X^2-63)/256 +! +! Recursion: +! +! P(0,x) = 1 +! P(1,x) = x +! P(n,x) = ( (2*n-1)*x*P(n-1,x)-(n-1)*P(n-2,x) ) / n +! +! P'(0,x) = 0 +! P'(1,x) = 1 +! P'(N,x) = ( (2*N-1)*(P(N-1,x)+X*P'(N-1,x)-(N-1)*P'(N-2,x) ) / N +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 March 2012 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Daniel Zwillinger, editor, +! CRC Standard Mathematical Tables and Formulae, +! 30th Edition, +! CRC Press, 1996. +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the number of evaluation points. +! +! Input, integer ( kind = 4 ) N, the highest order polynomial to evaluate. +! Note that polynomials 0 through N will be evaluated. +! +! Input, real ( kind = rk ) X(M), the evaluation points. +! +! Output, real ( kind = rk ) V(M,0:N), the values of the Legendre polynomials +! of order 0 through N at the points X. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) i + real(kind=rk) v(m, 0:n) + real(kind=rk) x(m) + + if (n < 0) then + return + end if + + v(1:m, 0) = 1.0D+00 + + if (n < 1) then + return + end if + + v(1:m, 1) = x(1:m) + + do i = 2, n + + v(1:m, i) = (real(2 * i - 1, kind=rk) * x(1:m) * v(1:m, i - 1) & + - real(i - 1, kind=rk) * v(1:m, i - 2)) & + / real(i, kind=rk) + + end do + + return +end + +subroutine p_polynomial_zeros(nt, t) + +!*****************************************************************************80 +! +!! P_POLYNOMIAL_ZEROS: zeros of Legendre function P(n,x). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 March 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) NT, the order of the rule. +! +! Output, real ( kind = rk ) T(NT), the zeros. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) nt + + real(kind=rk) bj(nt) + integer(kind=4) i + real(kind=rk) t(nt) + real(kind=rk) wts(nt) + + t(1:nt) = 0.0D+00 + + do i = 1, nt + bj(i) = real(i * i, kind=rk) / real(4 * i * i - 1, kind=rk) + end do + bj(1:nt) = sqrt(bj(1:nt)) + + wts(1:nt) = 0.0D+00 + wts(1) = sqrt(2.0D+00) + + call imtqlx(nt, t, bj, wts) + + return +end +subroutine p_power_product(p, e, table) + +!*****************************************************************************80 +! +!! P_POWER_PRODUCT: power products for Legendre polynomial P(n,x). +! +! Discussion: +! +! Let P(n,x) represent the Legendre polynomial of degree n. +! +! For polynomial chaos applications, it is of interest to know the +! value of the integrals of products of X with every possible pair +! of basis functions. That is, we'd like to form +! +! Tij = Integral ( -1.0 <= X <= +1.0 ) X^E * P(i,x) * P(j,x) dx +! +! We will estimate these integrals using Gauss-Legendre quadrature. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 May 2013 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) P, the maximum degree of the polyonomial +! factors. 0 <= P. +! +! Input, integer ( kind = 4 ) E, the exponent of X in the integrand. +! 0 <= E. +! +! Output, real ( kind = rk ) TABLE(0:P,0:P), the table of integrals. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) p + + integer(kind=4) e + real(kind=rk) h_table(0:p) + integer(kind=4) i + integer(kind=4) j + integer(kind=4) k + integer(kind=4) order + real(kind=rk) table(0:p, 0:p) + real(kind=rk), allocatable :: w_table(:) + real(kind=rk) x(1) + real(kind=rk), allocatable :: x_table(:) + + table(0:p, 0:p) = 0.0D+00 + + order = p + 1 + ((e + 1) / 2) + + allocate (x_table(order)) + allocate (w_table(order)) + + call p_quadrature_rule(order, x_table, w_table) + + do k = 1, order + + x(1) = x_table(k) + call p_polynomial_value(1, p, x, h_table) +! +! The following formula is an outer product in H_TABLE. +! + if (e == 0) then + do i = 0, p + do j = 0, p + table(i, j) = table(i, j) + w_table(k) * h_table(i) * h_table(j) + end do + end do + else + do i = 0, p + do j = 0, p + table(i, j) = table(i, j) & + + w_table(k) * x(1)**e * h_table(i) * h_table(j) + end do + end do + end if + + end do + + deallocate (w_table) + deallocate (x_table) + + return +end +subroutine p_quadrature_rule(nt, t, wts) + +!*****************************************************************************80 +! +!! P_QUADRATURE_RULE: quadrature for Legendre function P(n,x). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 March 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) NT, the order of the rule. +! +! Output, real ( kind = rk ) T(NT), WTS(NT), the points and weights +! of the rule. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) nt + + real(kind=rk) bj(nt) + integer(kind=4) i + real(kind=rk) t(nt) + real(kind=rk) wts(nt) + + t(1:nt) = 0.0D+00 + + do i = 1, nt + bj(i) = real(i * i, kind=rk) / real(4 * i * i - 1, kind=rk) + end do + bj(1:nt) = sqrt(bj(1:nt)) + + wts(1) = sqrt(2.0D+00) + wts(2:nt) = 0.0D+00 + + call imtqlx(nt, t, bj, wts) + + wts(1:nt) = wts(1:nt)**2 + + return +end +subroutine pm_polynomial_value(mm, n, m, x, cx) + +!*****************************************************************************80 +! +!! PM_POLYNOMIAL_VALUE evaluates the Legendre polynomials Pm(n,m,x). +! +! Differential equation: +! +! (1-X*X) * Y'' - 2 * X * Y + ( N (N+1) - (M*M/(1-X*X)) * Y = 0 +! +! First terms: +! +! M = 0 ( = Legendre polynomials of first kind P(N,X) ) +! +! Pm(0,0,x) = 1 +! Pm(1,0,x) = 1 X +! Pm(2,0,x) = ( 3 X^2 - 1)/2 +! Pm(3,0,x) = ( 5 X^3 - 3 X)/2 +! Pm(4,0,x) = ( 35 X^4 - 30 X^2 + 3)/8 +! Pm(5,0,x) = ( 63 X^5 - 70 X^3 + 15 X)/8 +! Pm(6,0,x) = (231 X^6 - 315 X^4 + 105 X^2 - 5)/16 +! Pm(7,0,x) = (429 X^7 - 693 X^5 + 315 X^3 - 35 X)/16 +! +! M = 1 +! +! Pm(0,1,x) = 0 +! Pm(1,1,x) = 1 * SQRT(1-X^2) +! Pm(2,1,x) = 3 * SQRT(1-X^2) * X +! Pm(3,1,x) = 1.5 * SQRT(1-X^2) * (5*X^2-1) +! Pm(4,1,x) = 2.5 * SQRT(1-X^2) * (7*X^3-3*X) +! +! M = 2 +! +! Pm(0,2,x) = 0 +! Pm(1,2,x) = 0 +! Pm(2,2,x) = 3 * (1-X^2) +! Pm(3,2,x) = 15 * (1-X^2) * X +! Pm(4,2,x) = 7.5 * (1-X^2) * (7*X^2-1) +! +! M = 3 +! +! Pm(0,3,x) = 0 +! Pm(1,3,x) = 0 +! Pm(2,3,x) = 0 +! Pm(3,3,x) = 15 * (1-X^2)^1.5 +! Pm(4,3,x) = 105 * (1-X^2)^1.5 * X +! +! M = 4 +! +! Pm(0,4,x) = 0 +! Pm(1,4,x) = 0 +! Pm(2,4,x) = 0 +! Pm(3,4,x) = 0 +! Pm(4,4,x) = 105 * (1-X^2)^2 +! +! Recursion: +! +! if N < M: +! Pm(N,M,x) = 0 +! if N = M: +! Pm(N,M,x) = (2*M-1)!! * (1-X*X)^(M/2) where N!! means the product of +! all the odd integers less than or equal to N. +! if N = M+1: +! Pm(N,M,x) = X*(2*M+1)*Pm(M,M,x) +! if M+1 < N: +! Pm(N,M,x) = ( X*(2*N-1)*Pm(N-1,M,x) - (N+M-1)*Pm(N-2,M,x) )/(N-M) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 May 2004 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Parameters: +! +! Input, integer ( kind = 4 ) MM, the number of evaluation points. +! +! Input, integer ( kind = 4 ) N, the maximum first index of the Legendre +! function, which must be at least 0. +! +! Input, integer ( kind = 4 ) M, the second index of the Legendre function, +! which must be at least 0, and no greater than N. +! +! Input, real ( kind = rk ) X(MM), the point at which the function is to be +! evaluated. +! +! Output, real ( kind = rk ) CX(MM,0:N), the function values. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) mm + integer(kind=4) n + + real(kind=rk) cx(mm, 0:n) + real(kind=rk) fact + integer(kind=4) j + integer(kind=4) m + real(kind=rk) x(mm) + + cx(1:mm, 0:n) = 0.0D+00 +! +! J = M is the first nonzero function. +! + if (m <= n) then + cx(1:mm, m) = 1.0D+00 + + fact = 1.0D+00 + do j = 1, m + cx(1:mm, m) = -cx(1:mm, m) * fact * sqrt(1.0D+00 - x(1:mm)**2) + fact = fact + 2.0D+00 + end do + + end if +! +! J = M + 1 is the second nonzero function. +! + if (m + 1 <= n) then + cx(1:mm, m + 1) = x(1:mm) * real(2 * m + 1, kind=rk) * cx(1:mm, m) + end if +! +! Now we use a three term recurrence. +! + do j = m + 2, n + cx(1:mm, j) = (real(2 * j - 1, kind=rk) * x(1:mm) * cx(1:mm, j - 1) & + + real(-j - m + 1, kind=rk) * cx(1:mm, j - 2)) & + / real(j - m, kind=rk) + end do + + return +end + +subroutine pmn_polynomial_value(mm, n, m, x, cx) + +!*****************************************************************************80 +! +!! PMN_POLYNOMIAL_VALUE: normalized Legendre polynomial Pmn(n,m,x). +! +! Discussion: +! +! The unnormalized associated Legendre functions P_N^M(X) have +! the property that +! +! Integral ( -1 <= X <= 1 ) ( P_N^M(X) )^2 dX +! = 2 * ( N + M )! / ( ( 2 * N + 1 ) * ( N - M )! ) +! +! By dividing the function by the square root of this term, +! the normalized associated Legendre functions have norm 1. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 March 2005 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Parameters: +! +! Input, integer ( kind = 4 ) MM, the number of evaluation points. +! +! Input, integer ( kind = 4 ) N, the maximum first index of the Legendre +! function, which must be at least 0. +! +! Input, integer ( kind = 4 ) M, the second index of the Legendre function, +! which must be at least 0, and no greater than N. +! +! Input, real ( kind = rk ) X(MM), the evaluation points. +! +! Output, real ( kind = rk ) CX(MM,0:N), the function values. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) mm + integer(kind=4) n + + real(kind=rk) cx(mm, 0:n) + real(kind=rk) factor + integer(kind=4) j + integer(kind=4) m + real(kind=rk) r8_factorial + real(kind=rk) x(mm) + + if (m < 0) then + write (*, '(a)') ' ' + write (*, '(a)') 'PMN_POLYNOMIAL_VALUE - Fatal error!' + write (*, '(a,i8)') ' Input value of M is ', m + write (*, '(a)') ' but M must be nonnegative.' + stop 1 + end if + + if (n < m) then + write (*, '(a)') ' ' + write (*, '(a)') 'PMN_POLYNOMIAL_VALUE - Fatal error!' + write (*, '(a,i8)') ' Input value of M = ', m + write (*, '(a,i8)') ' Input value of N = ', n + write (*, '(a)') ' but M must be less than or equal to N.' + stop 1 + end if + + cx(1:mm, 0:n) = 0.0D+00 + + if (m <= n) then + cx(1:mm, m) = 1.0D+00 + factor = 1.0D+00 + do j = 1, m + cx(1:mm, m) = -cx(1:mm, m) * factor * sqrt(1.0D+00 - x(1:mm)**2) + factor = factor + 2.0D+00 + end do + end if + + if (m + 1 <= n) then + cx(1:mm, m + 1) = x(1:mm) * real(2 * m + 1, kind=rk) * cx(1:mm, m) + end if + + do j = m + 2, n + cx(1:mm, j) = (real(2 * j - 1, kind=rk) * x(1:mm) * cx(1:mm, j - 1) & + + real(-j - m + 1, kind=rk) * cx(1:mm, j - 2)) & + / real(j - m, kind=rk) + end do +! +! Normalization. +! + do j = m, n + factor = sqrt((real(2 * j + 1, kind=rk) * r8_factorial(j - m)) & + / (2.0D+00 * r8_factorial(j + m))) + cx(1:mm, j) = cx(1:mm, j) * factor + end do + + return +end + +subroutine pmns_polynomial_value(mm, n, m, x, cx) + +!*****************************************************************************80 +! +!! PMNS_POLYNOMIAL_VALUE: sphere-normalized Legendre polynomial Pmns(n,m,x). +! +! Discussion: +! +! The unnormalized associated Legendre functions P_N^M(X) have +! the property that +! +! Integral ( -1 <= X <= 1 ) ( P_N^M(X) )^2 dX +! = 2 * ( N + M )! / ( ( 2 * N + 1 ) * ( N - M )! ) +! +! By dividing the function by the square root of this term, +! the normalized associated Legendre functions have norm 1. +! +! However, we plan to use these functions to build spherical +! harmonics, so we use a slightly different normalization factor of +! +! sqrt ( ( ( 2 * N + 1 ) * ( N - M )! ) / ( 4 * pi * ( N + M )! ) ) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 May 2013 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Parameters: +! +! Input, integer ( kind = 4 ) MM, the number of evaluation points. +! +! Input, integer ( kind = 4 ) N, the maximum first index of the Legendre +! function, which must be at least 0. +! +! Input, integer ( kind = 4 ) M, the second index of the Legendre function, +! which must be at least 0, and no greater than N. +! +! Input, real ( kind = rk ) X(MM), the evaluation points. +! +! Output, real ( kind = rk ) CX(MM,0:N), the function values. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) mm + integer(kind=4) n + + real(kind=rk) cx(mm, 0:n) + real(kind=rk) factor + integer(kind=4) j + integer(kind=4) m + real(kind=rk) r8_factorial + real(kind=rk), parameter :: r8_pi = 3.141592653589793D+00 + real(kind=rk) x(mm) + + cx(1:mm, 0:n) = 0.0D+00 + + if (m <= n) then + cx(1:mm, m) = 1.0D+00 + factor = 1.0D+00 + do j = 1, m + cx(1:mm, m) = -cx(1:mm, m) * factor * sqrt(1.0D+00 - x(1:mm)**2) + factor = factor + 2.0D+00 + end do + end if + + if (m + 1 <= n) then + cx(1:mm, m + 1) = x(1:mm) * real(2 * m + 1, kind=rk) * cx(1:mm, m) + end if + + do j = m + 2, n + cx(1:mm, j) = (real(2 * j - 1, kind=rk) * x(1:mm) * cx(1:mm, j - 1) & + + real(-j - m + 1, kind=rk) * cx(1:mm, j - 2)) & + / real(j - m, kind=rk) + end do +! +! Normalization. +! + do j = m, n + factor = sqrt((real(2 * j + 1, kind=rk) * r8_factorial(j - m)) & + / (4.0D+00 * r8_pi * r8_factorial(j + m))) + cx(1:mm, j) = cx(1:mm, j) * factor + end do + + return +end + +subroutine pn_pair_product(p, table) + +!*****************************************************************************80 +! +!! PN_PAIR_PRODUCT: pair products for normalized Legendre polynomial Pn(n,x). +! +! Discussion: +! +! Let Pn(n,x) represent the normalized Legendre polynomial of degree n. +! +! To check orthonormality, we compute +! +! Tij = Integral ( -1.0 <= X <= +1.0 ) Pn(i,x) * Pn(j,x) dx +! +! We will estimate these integrals using Gauss-Legendre quadrature. +! +! The computed table should be the identity matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 03 May 2013 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) P, the maximum degree of the polyonomial +! factors. 0 <= P. +! +! Output, real ( kind = rk ) TABLE(0:P,0:P), the table of integrals. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) p + + real(kind=rk) h_table(0:p) + integer(kind=4) i + integer(kind=4) j + integer(kind=4) k + integer(kind=4) order + real(kind=rk) table(0:p, 0:p) + real(kind=rk), allocatable :: w_table(:) + real(kind=rk) x(1) + real(kind=rk), allocatable :: x_table(:) + + table(0:p, 0:p) = 0.0D+00 + + order = p + 1 + + allocate (x_table(order)) + allocate (w_table(order)) + + call p_quadrature_rule(order, x_table, w_table) + + do k = 1, order + + x(1) = x_table(k) + call pn_polynomial_value(1, p, x, h_table) + + do i = 0, p + do j = 0, p + table(i, j) = table(i, j) + w_table(k) * h_table(i) * h_table(j) + end do + end do + + end do + + deallocate (w_table) + deallocate (x_table) + + return +end +subroutine pn_polynomial_coefficients(n, c) + +!*****************************************************************************80 +! +!! PN_POLYNOMIAL_COEFFICIENTS: coefficients of normalized Legendre Pn(n,x). +! +! Discussion: +! +! Pn(n,x) = P(n,x) * sqrt ( (2n+1)/2 ) +! +! 1 x x^2 x^3 x^4 x^5 x^6 x^7 +! +! 0 0.707 +! 1 0.000 1.224 +! 2 -0.790 0.000 2.371 +! 3 0.000 -2.806 0.000 4.677 +! 4 0.795 0.000 -7.954 0.000 9.280 +! 5 0.000 4.397 0.000 -20.520 0.000 18.468 +! 6 -0.796 0.000 16.731 0.000 -50.193 0.000 36.808 +! 7 0.000 -5.990 0.000 53.916 0.000 -118.616 0.000 73.429 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 October 2014 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Daniel Zwillinger, editor, +! CRC Standard Mathematical Tables and Formulae, +! 30th Edition, +! CRC Press, 1996. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the highest order polynomial to evaluate. +! Note that polynomials 0 through N will be evaluated. +! +! Output, real ( kind = rk ) C(0:N,0:N), the coefficients of the +! normalized Legendre polynomials of degree 0 through N. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) n + + real(kind=rk) c(0:n, 0:n) + integer(kind=4) i + real(kind=rk) t + + if (n < 0) then + return + end if +! +! Compute P(i,x) coefficients. +! + c(0:n, 0:n) = 0.0D+00 + + c(0, 0) = 1.0D+00 + + if (0 < n) then + c(1, 1) = 1.0D+00 + end if + + do i = 2, n + c(i, 0:i - 2) = real(-i + 1, kind=rk) * c(i - 2, 0:i - 2) & + / real(i, kind=rk) + c(i, 1:i) = c(i, 1:i) + real(i + i - 1, kind=rk) * c(i - 1, 0:i - 1) & + / real(i, kind=rk) + end do +! +! Normalize them. +! + do i = 0, n + t = sqrt(real(2 * i + 1, kind=rk) / 2.0D+00) + c(i, 0:i) = c(i, 0:i) * t + end do + + return +end +subroutine pn_polynomial_value(m, n, x, v) + +!*****************************************************************************80 +! +!! PN_POLYNOMIAL_VALUE evaluates the normalized Legendre polynomials Pn(n,x). +! +! Discussion: +! +! The normalized Legendre polynomials are orthonormal under the inner product +! defined as integration from -1 to 1: +! +! Integral ( -1 <= x <= +1 ) Pn(i,x) * Pn(j,x) dx = delta(i,j) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 March 2012 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Daniel Zwillinger, editor, +! CRC Standard Mathematical Tables and Formulae, +! 30th Edition, +! CRC Press, 1996. +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, the number of evaluation points. +! +! Input, integer ( kind = 4 ) N, the highest order polynomial to evaluate. +! Note that polynomials 0 through N will be evaluated. +! +! Input, real ( kind = rk ) X(M), the evaluation points. +! +! Output, real ( kind = rk ) V(M,0:N), the values of the Legendre polynomials +! of order 0 through N at the points X. +! + implicit none + + integer, parameter :: rk = kind(1.0D+00) + + integer(kind=4) m + integer(kind=4) n + + integer(kind=4) j + real(kind=rk) norm + real(kind=rk) v(m, 0:n) + real(kind=rk) x(m) + + call p_polynomial_value(m, n, x, v) + + do j = 0, n + norm = sqrt(2.0D+00 / real(2 * j + 1, kind=rk)) + v(1:m, j) = v(1:m, j) / norm + end do + + return +end diff --git a/src/submodules/Lapack/CMakeLists.txt b/src/submodules/Lapack/CMakeLists.txt index 0fe45c35b..2ea2aedac 100644 --- a/src/submodules/Lapack/CMakeLists.txt +++ b/src/submodules/Lapack/CMakeLists.txt @@ -22,6 +22,7 @@ IF( USE_LAPACK95 ) ${src_path}/GE_Lapack_Method@LinearSolveMethods.F90 ${src_path}/GE_Lapack_Method@LUMethods.F90 # ${src_path}/GE_Lapack_Method@EigenvalueMethods.F90 + ${src_path}/GE_Lapack_Method@CompRoutineMethods.F90 ) ENDIF( ) diff --git a/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 b/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 new file mode 100644 index 000000000..e04f05e3a --- /dev/null +++ b/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 @@ -0,0 +1,34 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(GE_Lapack_Method) CompRoutineMethods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! ConditionNo +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_ConditionNo_1 +REAL(DFP), DIMENSION(SIZE(A, 1), SIZE(A, 2)) :: tempA +tempA = A +CALL getLU(A=tempA, RCOND=ans, NORM=NORM) +ans = 1.0_DFP / ans +END PROCEDURE ge_ConditionNo_1 + +END SUBMODULE CompRoutineMethods diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index 29325c639..61c2f3b47 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -28,6 +28,9 @@ TARGET_SOURCES( ${src_path}/InterpolationUtility@Methods.F90 ${src_path}/LagrangeUtility@Methods.F90 ${src_path}/JacobiPolynomialUtility@Methods.F90 + ${src_path}/LegendrePolynomialUtility@Methods.F90 + ${src_path}/LobattoPolynomialUtility@Methods.F90 + ${src_path}/UnscaledLobattoPolynomialUtility@Methods.F90 ${src_path}/Chebyshev1PolynomialUtility@Methods.F90 ${src_path}/OrthogonalPolynomialUtility@Methods.F90 ${src_path}/RecursiveNodesUtility@Methods.F90 diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 new file mode 100644 index 000000000..a7377dbf3 --- /dev/null +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -0,0 +1,654 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modIFy +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. IF not, see +! + +SUBMODULE(LegendrePolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetLegendreRecurrenceCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetLegendreRecurrenceCoeff +REAL(DFP), PARAMETER :: one = 1.0_DFP, two = 2.0_DFP, four = 4.0_DFP +REAL(DFP) :: avar +INTEGER(I4B) :: ii +!! +IF (n .LE. 0) RETURN +!! +alphaCoeff = 0.0_DFP +betaCoeff(0) = two +IF (n .EQ. 1) RETURN +!! +DO ii = 1, n - 1 + avar = REAL(ii**2, KIND=DFP) + betaCoeff(ii) = avar / (four * avar - one) +END DO +!! +END PROCEDURE GetLegendreRecurrenceCoeff + +!---------------------------------------------------------------------------- +! LegendreLeadingCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreLeadingCoeff +REAL(DFP) :: a1, a2, a3 +a1 = REAL(Factorial(2 * n), KIND=DFP) +a2 = REAL(Factorial(n)**2, KIND=DFP) +a3 = REAL(2**n, KIND=DFP) +ans = a1 / a2 / a3 +END PROCEDURE LegendreLeadingCoeff + +!---------------------------------------------------------------------------- +! LegendreNormSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreNormSqr +ans = 2.0_DFP / (2.0_DFP * n + 1.0_DFP) +END PROCEDURE LegendreNormSqr + +!---------------------------------------------------------------------------- +! LegendreJacobiMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreJacobiMatrix +REAL(DFP), DIMENSION(0:n - 1) :: alphaCoeff0, betaCoeff0 +!! +IF (n .LT. 1) RETURN +!! +CALL GetLegendreRecurrenceCoeff(n=n, alphaCoeff=alphaCoeff0, & + & betaCoeff=betaCoeff0) +IF (PRESENT(alphaCoeff)) alphaCoeff(0:n - 1) = alphaCoeff0 +IF (PRESENT(betaCoeff)) betaCoeff(0:n - 1) = betaCoeff0 +!! +CALL JacobiMatrix(alphaCoeff=alphaCoeff0, & + & betaCoeff=betaCoeff0, D=D, E=E) +!! +END PROCEDURE LegendreJacobiMatrix + +!---------------------------------------------------------------------------- +! LegendreGaussQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGaussQuadrature +REAL(DFP) :: pn(n), fixvar +INTEGER(I4B) :: ii +!! +CALL LegendreJacobiMatrix(n=n, D=pt, E=wt) +!! +#ifdef USE_LAPACK95 +CALL STEV(D=pt, E=wt) +pn = LegendreEval(n=n - 1, x=pt) +fixvar = 2.0_DFP / REAL(n**2, KIND=DFP) +DO ii = 1, n + wt(ii) = fixvar * (1.0_DFP - pt(ii)**2) / (pn(ii)**2) +END DO + !! +#else +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="LegendreGaussQuadrature", & + & line=__LINE__, & + & unitno=stdout) +#endif + !! +END PROCEDURE LegendreGaussQuadrature + +!---------------------------------------------------------------------------- +! LegendreJacobiRadauMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreJacobiRadauMatrix +REAL(DFP) :: avar, r1, r2 +!! +IF (n .LT. 1) RETURN +!! +CALL LegendreJacobiMatrix(n=n, D=D, E=E, & + & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +!! +r1 = a * REAL(n + 1, KIND=DFP) +r2 = REAL(2 * n + 1, KIND=DFP) +D(n + 1) = r1 / r2 +!! +r1 = REAL(n**2, KIND=DFP) +r2 = 4.0_DFP * r1 - 1.0_DFP +!! +E(n) = SQRT(r1 / r2) +!! +END PROCEDURE LegendreJacobiRadauMatrix + +!---------------------------------------------------------------------------- +! LegendreGaussRadauQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGaussRadauQuadrature +REAL(DFP) :: pn(n + 1), fixvar +INTEGER(I4B) :: ii + !! +CALL LegendreJacobiRadauMatrix(a=a, n=n, D=pt, E=wt) +!! +#ifdef USE_LAPACK95 +!! +CALL STEV(D=pt, E=wt) +pn = LegendreEval(n=n, x=pt) +fixvar = 1.0_DFP / REAL((n + 1)**2, KIND=DFP) +!! +DO ii = 1, n + 1 + wt(ii) = fixvar * (1.0_DFP + a * pt(ii)) / (pn(ii)**2) +END DO + !! +#else +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="LegendreGaussRadauQuadrature", & + & line=__LINE__, & + & unitno=stdout) +#endif + !! +END PROCEDURE LegendreGaussRadauQuadrature + +!---------------------------------------------------------------------------- +! LegendreJacobiLobattoMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreJacobiLobattoMatrix + !! +REAL(DFP) :: r1, r2 + !! +IF (n .LT. 1) RETURN + !! +CALL LegendreJacobiMatrix( & + & n=n + 1, & + & D=D, & + & E=E, & + & alphaCoeff=alphaCoeff, & + & betaCoeff=betaCoeff) + !! +D(n + 2) = 0.0_DFP +r1 = REAL(n + 1, KIND=DFP) +r2 = REAL(2 * n + 1, KIND=DFP) + !! +E(n + 1) = SQRT(r1 / r2) + !! +END PROCEDURE LegendreJacobiLobattoMatrix + +!---------------------------------------------------------------------------- +! LegendreGaussLobattoQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGaussLobattoQuadrature +REAL(DFP) :: pn(n + 2), fixvar +INTEGER(I4B) :: ii + !! +CALL LegendreJacobiLobattoMatrix(n=n, D=pt, E=wt) +!! +#ifdef USE_LAPACK95 +!! +CALL STEV(D=pt, E=wt) +pn = LegendreEval(n=n + 1, x=pt) +fixvar = 2.0_DFP / REAL((n + 1) * (n + 2), KIND=DFP) +!! +DO ii = 1, n + 2 + wt(ii) = fixvar / (pn(ii)**2) +END DO + !! +#else +CALL ErrorMsg( & + & msg="The subroutine requires Lapack95 package", & + & file=__FILE__, & + & routine="LegendreGaussLobattoQuadrature", & + & line=__LINE__, & + & unitno=stdout) +#endif + !! +END PROCEDURE LegendreGaussLobattoQuadrature + +!---------------------------------------------------------------------------- +! LegendreZeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreZeros +ans = JacobiZeros(alpha=0.0_DFP, beta=0.0_DFP, n=n) +END PROCEDURE LegendreZeros + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreQuadrature +INTEGER(I4B) :: order +REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP +REAL(DFP), ALLOCATABLE :: p(:), w(:) +LOGICAL(LGT) :: inside +!! +IF (PRESENT(onlyInside)) THEN + inside = onlyInside +ELSE + inside = .FALSE. +END IF +!! +SELECT CASE (QuadType) +CASE (Gauss) + !! + order = n + CALL LegendreGaussQuadrature(n=order, pt=pt, wt=wt) + !! +CASE (GaussRadau, GaussRadauLeft) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=p, wt=w) + pt = p(2:); wt = w(2:) + DEALLOCATE (p, w) + ELSE + order = n - 1 + CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussRadauRight) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=p, wt=w) + pt = p(1:n); wt = w(1:n) + ELSE + order = n - 1 + CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussLobatto) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 2), w(n + 2)) + CALL LegendreGaussLobattoQuadrature(n=order, pt=p, wt=w) + pt = p(2:n + 1); wt = w(2:n + 1) + ELSE + order = n - 2 + CALL LegendreGaussLobattoQuadrature(n=order, pt=pt, wt=wt) + END IF +END SELECT +END PROCEDURE LegendreQuadrature + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEval1 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, r_i, ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = x +!! +DO i = 1, n - 1 + !! + r_i = real(i, kind=DFP) + c1 = r_i + 1.0_DFP + c2 = 2.0_DFP * r_i + 1.0_DFP + c3 = -r_i + !! + ans_1 = ans + ans = ((c2 * x) * ans + c3 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE LegendreEval1 + +!---------------------------------------------------------------------------- +! LegendreEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEval2 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, r_i +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = x +!! +DO i = 1, n - 1 + !! + r_i = real(i, kind=DFP) + c1 = r_i + 1.0_DFP + c2 = 2.0_DFP * r_i + 1.0_DFP + c3 = -r_i + !! + ans_1 = ans + ans = ((c2 * x) * ans + c3 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE LegendreEval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEvalAll1 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, r_i +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(2) = x +!! +DO i = 2, n + !! + r_i = real(i, kind=DFP) + c1 = r_i + c2 = 2.0_DFP * r_i - 1.0_DFP + c3 = -r_i + 1.0_DFP + !! + ans(i + 1) = ((c2 * x) * ans(i) + c3 * ans(i - 1)) / c1 + !! +END DO + +END PROCEDURE LegendreEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEvalAll2 +INTEGER(I4B) :: i +REAL(DFP) :: c1, c2, c3, r_i +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(:, 1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(:, 2) = x +!! +DO i = 2, n + !! + r_i = real(i, kind=DFP) + c1 = r_i + c2 = 2.0_DFP * r_i - 1.0_DFP + c3 = -r_i + 1.0_DFP + !! + ans(:, i + 1) = ((c2 * x) * ans(:, i) + c3 * ans(:, i - 1)) / c1 + !! +END DO +END PROCEDURE LegendreEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreMonomialExpansionAll +REAL(DFP) :: r_i +INTEGER(I4B) :: ii + !! +IF (n < 0) THEN + RETURN +END IF + !! +ans = 0.0_DFP +ans(1, 1) = 1.0_DFP + !! +IF (n .EQ. 0) THEN + RETURN +END IF + !! +ans(2, 2) = 1.0_DFP + !! +DO ii = 2, n + !! + r_i = REAL(ii, KIND=DFP) + !! + ans(1:ii - 1, ii + 1) = & + & (-r_i + 1.0) * ans(1:ii - 1, ii - 1) / r_i + !! + ans(2:ii + 1, ii + 1) = ans(2:ii + 1, ii + 1) & + & + (2.0 * r_i - 1.0) * ans(1:ii, ii) / r_i + !! +END DO +END PROCEDURE LegendreMonomialExpansionAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreMonomialExpansion +REAL(DFP) :: coeff(n + 1, n + 1) +coeff = LegendreMonomialExpansionAll(n) +ans = coeff(:, n + 1) +END PROCEDURE LegendreMonomialExpansion + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalAll1 + !! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p(1:n + 1) +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(1) = 1.0_DFP +ans(1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +p(2) = x +ans(2) = 1.0_DFP +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p(ii + 1) = ((2.0_DFP * r_ii - 1) * x * p(ii) & + & - (r_ii - 1.0_DFP) * p(ii - 1)) & + & / r_ii + !! + ans(ii + 1) = (2.0_DFP * r_ii - 1.0_DFP) * p(ii) + ans(ii - 1) + !! +END DO +!! +END PROCEDURE LegendreGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalAll2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p(1:SIZE(x), 1:n + 1) +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(:, 1) = 1.0_DFP +ans(:, 1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +p(:, 2) = x +ans(:, 2) = 1.0_DFP +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p(:, ii + 1) = ((2.0_DFP * r_ii - 1) * x * p(:, ii) & + & - (r_ii - 1.0_DFP) * p(:, ii - 1)) & + & / r_ii + !! + ans(:, ii + 1) = (2.0_DFP * r_ii - 1.0_DFP) * p(:, ii) + ans(:, ii - 1) + !! +END DO +!! +END PROCEDURE LegendreGradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEval1 + !! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p, p_1, p_2 +REAL(DFP) :: ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +p = x +ans = 1.0_DFP +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + p = ((2.0_DFP * r_ii - 1) * x * p & + & - (r_ii - 1.0_DFP) * p_2) & + & / r_ii + !! + p_2 = p_1 + !! + ans_1 = ans + ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE LegendreGradientEval1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEval2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2 +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +p = x +ans = 1.0_DFP +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + p = ((2.0_DFP * r_ii - 1) * x * p & + & - (r_ii - 1.0_DFP) * p_2) & + & / r_ii + !! + p_2 = p_1 + !! + ans_1 = ans + ans = (2.0_DFP * r_ii - 1.0_DFP) * p_1 + ans_2 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE LegendreGradientEval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 new file mode 100644 index 000000000..e33d5835a --- /dev/null +++ b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 @@ -0,0 +1,395 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modIFy +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. IF not, see +! + +SUBMODULE(LobattoPolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! LobattoLeadingCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoLeadingCoeff +REAL(DFP) :: avar, m + !! +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP +CASE (1) + ans = -0.5_DFP +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + m = LegendreLeadingCoeff(n=n) + ans = m * avar +END SELECT +END PROCEDURE LobattoLeadingCoeff + +!---------------------------------------------------------------------------- +! LobattoNormSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoNormSqr +REAL(DFP) :: m, a1, a2 +SELECT CASE (n) +CASE (0, 1) + ans = 2.0_DFP / 3.0_DFP +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + a1 = (2.0_DFP * m + 1) + a2 = (2.0_DFP * m + 5) + ans = 2.0_DFP / a1 / a2 +END SELECT +END PROCEDURE LobattoNormSqr + +!---------------------------------------------------------------------------- +! LobattoZeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoZeros +SELECT CASE (n) +CASE (1) + ans(1) = 1.0_DFP +CASE (2) + ans(1) = -1.0_DFP + ans(2) = 1.0_DFP +CASE DEFAULT + ans(1) = -1.0_DFP + ans(n) = 1.0_DFP + ans(2:n - 1) = JacobiZeros(alpha=1.0_DFP, beta=1.0_DFP, n=n - 2_I4B) +END SELECT +END PROCEDURE LobattoZeros + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoEval1 +REAL(DFP) :: avar, m +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) +END SELECT +END PROCEDURE LobattoEval1 + +!---------------------------------------------------------------------------- +! LobattoEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoEval2 +REAL(DFP) :: avar, m + !! +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) +END SELECT +END PROCEDURE LobattoEval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoEvalAll1 +REAL(DFP) :: avar, m +REAL(DFP) :: p(n + 1) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(1) = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans(1) = 0.5_DFP * (1.0_DFP - x) + ans(2) = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + ans(1) = 0.5_DFP * (1.0_DFP - x) + ans(2) = 0.5_DFP * (1.0_DFP + x) + p = LegendreEvalAll(n=n, x=x) + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + ans(2 + ii) = avar * (p(ii + 2) - p(ii)) + END DO +END SELECT +END PROCEDURE LobattoEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoEvalAll2 +REAL(DFP) :: avar, m +REAL(DFP) :: p(SIZE(x), n + 1) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) + ans(:, 2) = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) + ans(:, 2) = 0.5_DFP * (1.0_DFP + x) + p = LegendreEvalAll(n=n, x=x) + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + ans(:, 2 + ii) = avar * (p(:, ii + 2) - p(:, ii)) + END DO +END SELECT +END PROCEDURE LobattoEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoMonomialExpansionAll +REAL(DFP) :: avar, m +REAL(DFP) :: p(n + 1, n + 1) +INTEGER(I4B) :: ii +!! +ans = 0.0_DFP +!! +SELECT CASE (n) +CASE (0) + ans(1, 1) = 0.5_DFP +CASE (1) + ans(1, 1) = 0.5_DFP + ans(2, 1) = -0.5_DFP + ans(1, 2) = 0.5_DFP + ans(2, 2) = 0.5_DFP +CASE DEFAULT + ans(1, 1) = 0.5_DFP + ans(2, 1) = -0.5_DFP + ans(1, 2) = 0.5_DFP + ans(2, 2) = 0.5_DFP + !! + p = LegendreMonomialExpansionAll(n=n) + !! + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / SQRT(2.0_DFP * (2.0_DFP * m + 3.0_DFP)) + ans(:, ii + 2) = avar * (p(:, ii + 2) - p(:, ii)) + END DO + !! +END SELECT +END PROCEDURE LobattoMonomialExpansionAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoMonomialExpansion +REAL(DFP) :: coeff(n + 1, n + 1) +coeff = LobattoMonomialExpansionAll(n) +ans = coeff(:, n + 1) +END PROCEDURE LobattoMonomialExpansion + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoGradientEvalAll1 +REAL(DFP) :: p(n), avar, m +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(1) = -0.5_DFP +CASE (1) + ans(1) = -0.5_DFP + ans(2) = 0.5_DFP +CASE DEFAULT + ans(1) = -0.5_DFP + ans(2) = 0.5_DFP + !! + p = LegendreEvalAll(n=n - 1_I4B, x=x) + !! + DO ii = 1, n - 1 + m = REAL(ii - 1, DFP) + avar = SQRT((2.0_DFP * m + 3.0) / 2.0) + ans(ii + 2) = avar * p(ii + 1) + ! ans(3:) = p(2:) + END DO + !! +END SELECT +END PROCEDURE LobattoGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoGradientEvalAll2 +REAL(DFP) :: p(SIZE(x), n), avar, m +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(:, 1) = -0.5_DFP +CASE (1) + ans(:, 1) = -0.5_DFP + ans(:, 2) = 0.5_DFP +CASE DEFAULT + ans(:, 1) = -0.5_DFP + ans(:, 2) = 0.5_DFP + !! + p = LegendreEvalAll(n=n - 1_I4B, x=x) + !! + DO ii = 1, n - 1 + m = REAL(ii - 1, DFP) + avar = SQRT((2.0_DFP * m + 3.0) / 2.0) + ans(:, ii + 2) = avar * p(:, ii + 1) + ! ans(3:) = p(2:) + END DO + !! +END SELECT +END PROCEDURE LobattoGradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoGradientEval1 +REAL(DFP) :: p, avar, m + !! +SELECT CASE (n) +CASE (0) + ans = -0.5_DFP +CASE (1) + ans = 0.5_DFP +CASE DEFAULT + !! + p = LegendreEval(n=n - 1_I4B, x=x) + m = REAL(n - 2, DFP) + avar = SQRT((2.0_DFP * m + 3.0) / 2.0) + ans = avar * p +END SELECT +END PROCEDURE LobattoGradientEval1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoGradientEval2 +REAL(DFP) :: p(SIZE(x)), avar, m + !! +SELECT CASE (n) +CASE (0) + ans = -0.5_DFP +CASE (1) + ans = 0.5_DFP +CASE DEFAULT + !! + p = LegendreEval(n=n - 1_I4B, x=x) + m = REAL(n - 2, DFP) + avar = SQRT((2.0_DFP * m + 3.0) / 2.0) + ans = avar * p +END SELECT +END PROCEDURE LobattoGradientEval2 + +!---------------------------------------------------------------------------- +! LobattoMassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoMassMatrix +INTEGER(I4B) :: ii +REAL(DFP) :: m +!! +ans = 0.0_DFP +!! +DO ii = 1, n + 1 + ans(ii, ii) = LobattoNormSQR(n=ii - 1_I4B) +END DO +!! +IF (n .EQ. 0_I4B) RETURN +!! +ans(1, 2) = 1.0_DFP / 3.0_DFP +ans(2, 1) = ans(1, 2) +!! +IF (n .EQ. 1_I4B) RETURN +!! +ans(1, 3) = -1.0_DFP / SQRT(6.0_DFP) +ans(3, 1) = ans(1, 3) +ans(2, 3) = ans(1, 3) +ans(3, 2) = ans(2, 3) +!! +IF (n .EQ. 2_I4B) RETURN +!! +ans(1, 4) = 1.0_DFP / SQRT(90.0_DFP) +ans(4, 1) = ans(1, 4) +ans(2, 4) = -ans(1, 4) +ans(4, 2) = ans(2, 4) +!! +IF (n .EQ. 3_I4B) RETURN +!! +DO ii = 3, n + 1 + !! + m = REAL(ii - 3, DFP) + !! + IF (ii + 2 .LE. n + 1) THEN + ans(ii, ii + 2) = -1.0_DFP / (2.0_DFP * m + 5.0_DFP) / & + & SQRT((2.0_DFP * m + 7.0_DFP) * (2.0_DFP * m + 3.0_DFP)) + !! + ans(ii + 2, ii) = ans(ii, ii + 2) + END IF + !! +END DO +!! +END PROCEDURE LobattoMassMatrix + +!---------------------------------------------------------------------------- +! LobattoStiffnessMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoStiffnessMatrix +INTEGER(I4B) :: ii +REAL(DFP) :: m +!! +ans = 0.0_DFP +!! +DO ii = 1, n + 1 + ans(ii, ii) = 1.0_DFP +END DO +!! +ans(1, 1) = 0.5_DFP +!! +IF (n .EQ. 0_I4B) RETURN +!! +ans(2, 2) = 0.5_DFP +ans(1, 2) = -0.5_DFP +ans(2, 1) = ans(1, 2) +!! +END PROCEDURE LobattoStiffnessMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 new file mode 100644 index 000000000..9092e9e12 --- /dev/null +++ b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 @@ -0,0 +1,381 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modIFy +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. IF not, see +! + +SUBMODULE(UnscaledLobattoPolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! UnscaledLobattoLeadingCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoLeadingCoeff +REAL(DFP) :: avar, m + !! +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP +CASE (1) + ans = -0.5_DFP +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + m = LegendreLeadingCoeff(n=n) + ans = m * avar +END SELECT +END PROCEDURE UnscaledLobattoLeadingCoeff + +!---------------------------------------------------------------------------- +! UnscaledLobattoNormSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoNormSqr +REAL(DFP) :: m, a1, a2, a3 +SELECT CASE (n) +CASE (0, 1) + ans = 2.0_DFP / 3.0_DFP +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + a1 = (2.0_DFP * m + 1) + a2 = (2.0_DFP * m + 3) + a3 = (2.0_DFP * m + 5) + ans = 4.0_DFP / a1 / a2 / a3 +END SELECT +END PROCEDURE UnscaledLobattoNormSqr + +!---------------------------------------------------------------------------- +! UnscaledLobattoZeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoZeros +SELECT CASE (n) +CASE (1) + ans(1) = 1.0_DFP +CASE (2) + ans(1) = -1.0_DFP + ans(2) = 1.0_DFP +CASE DEFAULT + ans(1) = -1.0_DFP + ans(n) = 1.0_DFP + ans(2:n - 1) = JacobiZeros(alpha=1.0_DFP, beta=1.0_DFP, n=n - 2_I4B) +END SELECT +END PROCEDURE UnscaledLobattoZeros + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoEval1 +REAL(DFP) :: avar, m +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) +END SELECT +END PROCEDURE UnscaledLobattoEval1 + +!---------------------------------------------------------------------------- +! UnscaledLobattoEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoEval2 +REAL(DFP) :: avar, m + !! +SELECT CASE (n) +CASE (0) + ans = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + m = REAL(n, KIND=DFP) - 2.0_DFP + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + ans = avar * (LegendreEval(n=n, x=x) - LegendreEval(n=n - 2_I4B, x=x)) +END SELECT +END PROCEDURE UnscaledLobattoEval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoEvalAll1 +REAL(DFP) :: avar, m +REAL(DFP) :: p(n + 1) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(1) = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans(1) = 0.5_DFP * (1.0_DFP - x) + ans(2) = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + ans(1) = 0.5_DFP * (1.0_DFP - x) + ans(2) = 0.5_DFP * (1.0_DFP + x) + p = LegendreEvalAll(n=n, x=x) + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + ans(2 + ii) = avar * (p(ii + 2) - p(ii)) + END DO +END SELECT +END PROCEDURE UnscaledLobattoEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoEvalAll2 +REAL(DFP) :: avar, m +REAL(DFP) :: p(SIZE(x), n + 1) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) +CASE (1) + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) + ans(:, 2) = 0.5_DFP * (1.0_DFP + x) +CASE DEFAULT + ans(:, 1) = 0.5_DFP * (1.0_DFP - x) + ans(:, 2) = 0.5_DFP * (1.0_DFP + x) + p = LegendreEvalAll(n=n, x=x) + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + ans(:, 2 + ii) = avar * (p(:, ii + 2) - p(:, ii)) + END DO +END SELECT +END PROCEDURE UnscaledLobattoEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoMonomialExpansionAll +REAL(DFP) :: avar, m +REAL(DFP) :: p(n + 1, n + 1) +INTEGER(I4B) :: ii +!! +ans = 0.0_DFP +!! +SELECT CASE (n) +CASE (0) + ans(1, 1) = 0.5_DFP +CASE (1) + ans(1, 1) = 0.5_DFP + ans(2, 1) = -0.5_DFP + ans(1, 2) = 0.5_DFP + ans(2, 2) = 0.5_DFP +CASE DEFAULT + ans(1, 1) = 0.5_DFP + ans(2, 1) = -0.5_DFP + ans(1, 2) = 0.5_DFP + ans(2, 2) = 0.5_DFP + !! + p = LegendreMonomialExpansionAll(n=n) + !! + DO ii = 1, n - 1 + m = REAL(ii - 1, KIND=DFP) + avar = 1.0_DFP / (2.0_DFP * m + 3.0_DFP) + ans(:, ii + 2) = avar * (p(:, ii + 2) - p(:, ii)) + END DO + !! +END SELECT +END PROCEDURE UnscaledLobattoMonomialExpansionAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoMonomialExpansion +REAL(DFP) :: coeff(n + 1, n + 1) +coeff = UnscaledLobattoMonomialExpansionAll(n) +ans = coeff(:, n + 1) +END PROCEDURE UnscaledLobattoMonomialExpansion + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoGradientEvalAll1 +REAL(DFP) :: p(n) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(1) = -0.5_DFP +CASE (1) + ans(1) = -0.5_DFP + ans(2) = 0.5_DFP +CASE DEFAULT + ans(1) = -0.5_DFP + ans(2) = 0.5_DFP + !! + p = LegendreEvalAll(n=n - 1_I4B, x=x) + !! + DO ii = 1, n - 1 + ans(ii + 2) = p(ii + 1) + ! ans(3:) = p(2:) + END DO + !! +END SELECT +END PROCEDURE UnscaledLobattoGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoGradientEvalAll2 +REAL(DFP) :: p(SIZE(x), n) +INTEGER(I4B) :: ii + !! +SELECT CASE (n) +CASE (0) + ans(:, 1) = -0.5_DFP +CASE (1) + ans(:, 1) = -0.5_DFP + ans(:, 2) = 0.5_DFP +CASE DEFAULT + ans(:, 1) = -0.5_DFP + ans(:, 2) = 0.5_DFP + !! + p = LegendreEvalAll(n=n - 1_I4B, x=x) + !! + DO ii = 1, n - 1 + ans(:, ii + 2) = p(:, ii + 1) + ! ans(3:) = p(2:) + END DO + !! +END SELECT +END PROCEDURE UnscaledLobattoGradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoGradientEval1 + !! +SELECT CASE (n) +CASE (0) + ans = -0.5_DFP +CASE (1) + ans = 0.5_DFP +CASE DEFAULT + ans = LegendreEval(n=n - 1_I4B, x=x) +END SELECT +END PROCEDURE UnscaledLobattoGradientEval1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoGradientEval2 +SELECT CASE (n) +CASE (0) + ans = -0.5_DFP +CASE (1) + ans = 0.5_DFP +CASE DEFAULT + ans = LegendreEval(n=n - 1_I4B, x=x) +END SELECT +END PROCEDURE UnscaledLobattoGradientEval2 + +!---------------------------------------------------------------------------- +! UnscaledLobattoMassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoMassMatrix +INTEGER(I4B) :: ii +REAL(DFP) :: m +!! +ans = 0.0_DFP +!! +DO ii = 1, n + 1 + ans(ii, ii) = UnscaledLobattoNormSQR(n=ii - 1_I4B) +END DO +!! +IF (n .EQ. 0_I4B) RETURN +!! +ans(1, 2) = 1.0_DFP / 3.0_DFP +ans(2, 1) = ans(1, 2) +!! +IF (n .EQ. 1_I4B) RETURN +!! +ans(1, 3) = -1.0_DFP / 3.0_DFP +ans(3, 1) = ans(1, 3) +ans(2, 3) = ans(1, 3) +ans(3, 2) = ans(2, 3) +!! +IF (n .EQ. 2_I4B) RETURN +!! +ans(1, 4) = 1.0_DFP / 15.0_DFP +ans(4, 1) = ans(1, 4) +ans(2, 4) = -ans(1, 4) +ans(4, 2) = ans(2, 4) +!! +IF (n .EQ. 3_I4B) RETURN +!! +DO ii = 3, n + 1 + !! + m = REAL(ii - 3, DFP) + !! + IF (ii + 2 .LE. n + 1) THEN + ans(ii, ii + 2) = -2.0_DFP / (2.0_DFP * m + 3.0_DFP) / & + & (2.0_DFP * m + 5.0_DFP) / (2.0_DFP * m + 7.0_DFP) + !! + ans(ii + 2, ii) = ans(ii, ii + 2) + END IF + !! +END DO +!! +END PROCEDURE UnscaledLobattoMassMatrix + +!---------------------------------------------------------------------------- +! UnscaledLobattoStiffnessMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UnscaledLobattoStiffnessMatrix +INTEGER(I4B) :: ii +REAL(DFP) :: m +!! +ans = 0.0_DFP +!! +ans(1, 1) = 0.5_DFP +!! +IF (n .EQ. 0_I4B) RETURN +!! +ans(2, 2) = 0.5_DFP +ans(1, 2) = -0.5_DFP +ans(2, 1) = ans(1, 2) +!! +DO ii = 3, n + 1 + m = REAL(ii - 3, DFP) + ans(ii, ii) = 2.0_DFP / (2.0_DFP * m + 3.0_DFP) +END DO +END PROCEDURE UnscaledLobattoStiffnessMatrix + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods From f95bfa6a94cdcd419bc2038194cde86b5b7e855a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:44:45 +0900 Subject: [PATCH 28/43] undefined --- src/modules/BaseType/src/BaseType.F90 | 44 ++++++++++++++++++++++++++- 1 file changed, 43 insertions(+), 1 deletion(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 0b764631e..e35b6eb82 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -659,7 +659,7 @@ MODULE BaseType PUBLIC :: ReferenceElementPointer_ INTERFACE - PURE SUBROUTINE highorder_refelem(obj, order, highOrderobj, ipType) + SUBROUTINE highorder_refelem(obj, order, highOrderobj, ipType) IMPORT :: ReferenceElement_, I4B CLASS(ReferenceElement_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: order @@ -1500,6 +1500,48 @@ END FUNCTION iface_TimeFunction PUBLIC :: iface_TimeFunction +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_1DFunction(x) RESULT(ans) + IMPORT :: DFP + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION iface_1DFunction +END INTERFACE + +PUBLIC :: iface_1DFunction + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_2DFunction(x, y) RESULT(ans) + IMPORT :: DFP + REAL(DFP), INTENT(IN) :: x, y + REAL(DFP) :: ans + END FUNCTION iface_2DFunction +END INTERFACE + +PUBLIC :: iface_2DFunction + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + PURE FUNCTION iface_3DFunction(x, y, z) RESULT(ans) + IMPORT :: DFP + REAL(DFP), INTENT(IN) :: x, y, z + REAL(DFP) :: ans + END FUNCTION iface_3DFunction +END INTERFACE + +PUBLIC :: iface_3DFunction + !---------------------------------------------------------------------------- ! MultiIndices_ !---------------------------------------------------------------------------- From 0d12939540af0b3ef80bffb885c035fde9343a76 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:44:55 +0900 Subject: [PATCH 29/43] undefined --- .../ErrorHandling/src/ErrorHandling.F90 | 126 +++++++++--------- 1 file changed, 63 insertions(+), 63 deletions(-) diff --git a/src/modules/ErrorHandling/src/ErrorHandling.F90 b/src/modules/ErrorHandling/src/ErrorHandling.F90 index 78c58fa35..23389ff5b 100644 --- a/src/modules/ErrorHandling/src/ErrorHandling.F90 +++ b/src/modules/ErrorHandling/src/ErrorHandling.F90 @@ -15,7 +15,6 @@ ! along with this program. If not, see ! - !> [[ErrorHandling]] module contains error handling routines. MODULE ErrorHandling @@ -27,6 +26,7 @@ MODULE ErrorHandling PUBLIC :: Errormsg, Warningmsg, fileError, AllocationErr CONTAINS + !---------------------------------------------------------------------------- ! Errormsg !---------------------------------------------------------------------------- @@ -45,25 +45,25 @@ MODULE ErrorHandling ! ) ! ``` -SUBROUTINE Errormsg( msg, file, routine, line, unitno ) - CHARACTER( LEN = * ), INTENT( IN ) :: msg +SUBROUTINE Errormsg(msg, file, routine, line, unitno) + CHARACTER(LEN=*), INTENT(IN) :: msg !! Message - CHARACTER( LEN = * ), INTENT( IN ) :: file + CHARACTER(LEN=*), INTENT(IN) :: file !! Name of the file - CHARACTER( LEN = * ), INTENT( IN ) :: routine + CHARACTER(LEN=*), INTENT(IN) :: routine !! Name of the routine where error has occured - INTEGER( I4B ), INTENT( IN ) :: line + INTEGER(I4B), INTENT(IN) :: line !! line number where error has occured - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: unitno + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno !! Unit number !! - CALL Display( file, "ERROR :: In file :: ", unitno = unitno ) - CALL Display( LINE, "at line number :: ", unitno = unitno ) - CALL Display( " ", "in routine named :: "// TRIM(routine) // & - & " with following message :: ", unitno = unitno ) - CALL Dashline(unitno = unitno) - CALL Display( msg, unitno = unitno ) - CALL Dashline(unitno = unitno) + CALL Display(file, "ERROR :: In file :: ", unitno=unitno) + CALL Display(LINE, "at line number :: ", unitno=unitno) + CALL Display(" ", "in routine named :: "//TRIM(routine)// & + & " with following message :: ", unitno=unitno) + CALL Dashline(unitno=unitno) + CALL Display(msg, unitno=unitno) + CALL Dashline(unitno=unitno) END SUBROUTINE Errormsg !---------------------------------------------------------------------------- @@ -74,26 +74,26 @@ END SUBROUTINE Errormsg ! ! This subroutine prints the warning message -SUBROUTINE Warningmsg( msg, file, routine, line, unitno ) +SUBROUTINE Warningmsg(msg, file, routine, line, unitno) !! This subroutine prints the warning message - CHARACTER( LEN = * ), INTENT( IN ) :: msg + CHARACTER(LEN=*), INTENT(IN) :: msg !! Message - CHARACTER( LEN = * ), INTENT( IN ) :: file + CHARACTER(LEN=*), INTENT(IN) :: file !! Name of the file - CHARACTER( LEN = * ), INTENT( IN ) :: routine + CHARACTER(LEN=*), INTENT(IN) :: routine !! Name of the routine where error has occured - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: unitno + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno !! file id to write the message to - INTEGER( I4B ), INTENT( IN ) :: line + INTEGER(I4B), INTENT(IN) :: line !! line number !! - CALL Display( file, "WARNING :: In file ::", unitno = unitno ) - CALL Display( LINE, "line number ::", unitno = unitno ) - CALL Display( " ", "in routine named :: "// TRIM(routine) // & - & " with following message :: ", unitno = unitno ) - CALL Dashline(unitno = unitno) - CALL Display( msg, unitno = unitno ) - CALL Dashline(unitno = unitno) + CALL Display(file, "WARNING :: In file ::", unitno=unitno) + CALL Display(LINE, "line number ::", unitno=unitno) + CALL Display(" ", "in routine named :: "//TRIM(routine)// & + & " with following message :: ", unitno=unitno) + CALL Dashline(unitno=unitno) + CALL Display(msg, unitno=unitno) + CALL Dashline(unitno=unitno) END SUBROUTINE Warningmsg !---------------------------------------------------------------------------- @@ -104,46 +104,46 @@ END SUBROUTINE Warningmsg ! ! This subroutine prints error while handling a file -SUBROUTINE fileError(istat, filename, flg, unitno, file, routine, line ) +SUBROUTINE fileError(istat, filename, flg, unitno, file, routine, line) ! Dummy argumnet - INTEGER( I4B ), INTENT( IN ) :: istat + INTEGER(I4B), INTENT(IN) :: istat !! Result of iostat=istat for open,read,write,close - CHARACTER(len=*), INTENT( IN ) :: filename + CHARACTER(len=*), INTENT(IN) :: filename !! Name of the file (IO related) - INTEGER( I4B ), INTENT( IN ) :: flg + INTEGER(I4B), INTENT(IN) :: flg !! IO_OPEN=Open, IO_READ=Read, IO_WRITE=Write, IO_CLOSE=Close - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: unitno + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno !! file id to write the error to - CHARACTER( LEN = * ), INTENT( IN ) :: file, routine + CHARACTER(LEN=*), INTENT(IN) :: file, routine !! Name of the source code file and routine name - INTEGER( I4B ), INTENT( IN ) :: line + INTEGER(I4B), INTENT(IN) :: line !! line number !! ! Define internal variables - CHARACTER(len=:),allocatable :: Amsg + CHARACTER(len=:), allocatable :: Amsg !! ! Return if no error - IF ( istat == 0 ) THEN + IF (istat == 0) THEN RETURN END IF !! Amsg = "" !! - SELECT CASE(flg) - CASE(OPT_OPEN) - Amsg='Opening file: '// TRIM(filename) - CASE(OPT_READ) - Amsg='Reading from: '// TRIM(filename) - CASE(OPT_WRITE) - Amsg='Writing to file: '// TRIM(filename) - CASE(OPT_CLOSE) - Amsg='Closing file: '// TRIM(filename) + SELECT CASE (flg) + CASE (OPT_OPEN) + Amsg = 'Opening file: '//TRIM(filename) + CASE (OPT_READ) + Amsg = 'Reading from: '//TRIM(filename) + CASE (OPT_WRITE) + Amsg = 'Writing to file: '//TRIM(filename) + CASE (OPT_CLOSE) + Amsg = 'Closing file: '//TRIM(filename) CASE DEFAULT - Amsg='Error:Invalid error flag [1-4]' + Amsg = 'Error:Invalid error flag [1-4]' END SELECT !! - CALL Errormsg( msg=Amsg, unitno=unitno, file=file, line=line, & - & routine=routine ) + CALL Errormsg(msg=Amsg, unitno=unitno, file=file, line=line, & + & routine=routine) !! END SUBROUTINE fileError @@ -160,33 +160,33 @@ END SUBROUTINE fileError ! allocate(x(nz,ny,nx), stat=istat); call AllocationErr(istat,'x',1) ! deallocate(x, stat=istat); call AllocationErr(istat,'x',2) -SUBROUTINE AllocationErr( istat, amsg, alloc, unitno, file, routine, line) - INTEGER( I4B ), INTENT( IN ) :: istat +SUBROUTINE AllocationErr(istat, amsg, alloc, unitno, file, routine, line) + INTEGER(I4B), INTENT(IN) :: istat !! results of stat=istat in (de)allocate - CHARACTER(LEN=*), INTENT( IN ) :: amsg + CHARACTER(LEN=*), INTENT(IN) :: amsg !! Message associated with the (de)allocate - INTEGER( I4B ), INTENT( IN ) :: alloc + INTEGER(I4B), INTENT(IN) :: alloc !! For OPT_ALLOC = allocate, for OPT_DEALLOC = deallocate - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: unitno + INTEGER(I4B), OPTIONAL, INTENT(IN) :: unitno !! Optional file id to write the message to - CHARACTER( LEN = * ), INTENT( IN ) :: file, routine + CHARACTER(LEN=*), INTENT(IN) :: file, routine !! filename and routine name - INTEGER( I4B ), INTENT( IN ) :: line + INTEGER(I4B), INTENT(IN) :: line !! ! Define internal variables - CHARACTER( LEN = : ), ALLOCATABLE :: tmp + CHARACTER(LEN=:), ALLOCATABLE :: tmp !! - IF ( istat == 0 ) RETURN + IF (istat == 0) RETURN !! tmp = "" - SELECT CASE( alloc ) - CASE( OPT_ALLOC ) - tmp='Allocating Memory: '// TRIM( amsg ) - CASE( OPT_DEALLOC ) - tmp='Deallocating Memory: '// TRIM( amsg ) + SELECT CASE (alloc) + CASE (OPT_ALLOC) + tmp = 'Allocating Memory: '//TRIM(amsg) + CASE (OPT_DEALLOC) + tmp = 'Deallocating Memory: '//TRIM(amsg) END SELECT !! - CALL Errormsg( msg=tmp, unitno=unitno, file=file, line=line, & + CALL Errormsg(msg=tmp, unitno=unitno, file=file, line=line, & & routine=routine) !! END SUBROUTINE AllocationErr From ee1cf972184d7d0d98f10a4e4a6f3b9c87cc3022 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:45:00 +0900 Subject: [PATCH 30/43] undefined --- src/modules/FPL/src/ErrorMessages.F90 | 181 +++++++++++++------------- 1 file changed, 88 insertions(+), 93 deletions(-) diff --git a/src/modules/FPL/src/ErrorMessages.F90 b/src/modules/FPL/src/ErrorMessages.F90 index b7e01602b..6236d06e7 100644 --- a/src/modules/FPL/src/ErrorMessages.F90 +++ b/src/modules/FPL/src/ErrorMessages.F90 @@ -18,106 +18,101 @@ ! License along with this library. !----------------------------------------------------------------- -module ErrorMessages - -USE iso_fortran_env, only: OUTPUT_UNIT, ERROR_UNIT -USE PENF, only: I4P, str - -implicit none -private - - integer(I4P), public, parameter :: FPLSuccess = 0 - integer(I4P), public, parameter :: FPLWrapperFactoryError = -1 - integer(I4P), public, parameter :: FPLWrapperError = -2 - integer(I4P), public, parameter :: FPLSublistError = -3 - integer(I4P), public, parameter :: FPLParameterListIteratorError = -4 - - type :: MessageHandler_t - private - character(len=5) :: prefix = '[FPL]' - contains - procedure, non_overridable :: Print => MessageHandler_Print - procedure, non_overridable :: Warn => MessageHandler_Warn - procedure, non_overridable :: Error => MessageHandler_Error - end type +MODULE ErrorMessages +USE ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT, ERROR_UNIT +USE PENF, ONLY: I4P, str + +IMPLICIT none +PRIVATE + +integer(I4P), public, parameter :: FPLSuccess = 0 +integer(I4P), public, parameter :: FPLWrapperFactoryError = -1 +integer(I4P), public, parameter :: FPLWrapperError = -2 +integer(I4P), public, parameter :: FPLSublistError = -3 +integer(I4P), public, parameter :: FPLParameterListIteratorError = -4 + +type :: MessageHandler_t + private + character(len=5) :: prefix = '[FPL]' +contains + procedure, non_overridable :: Print => MessageHandler_Print + procedure, non_overridable :: Warn => MessageHandler_Warn + procedure, non_overridable :: Error => MessageHandler_Error +end type - type(MessageHandler_t), save :: msg - !$OMP THREADPRIVATE(msg) +type(MessageHandler_t), save :: msg +!$OMP THREADPRIVATE(msg) public :: msg contains - - subroutine MessageHandler_Print(this, txt, unit, iostat, iomsg) - !----------------------------------------------------------------- - !< Print a txt message preceding for prefix - !----------------------------------------------------------------- - class(MessageHandler_t), intent(IN) :: this !< Message handler - character(len=*), intent(IN) :: txt !< Text to print - integer(I4P), optional, intent(IN) :: unit !< Unit where to print - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - integer(I4P) :: iostatd !< Real IO error. - integer(I4P) :: u !< Real unit - character(500) :: iomsgd !< Real IO error message. - !----------------------------------------------------------------- - u = OUTPUT_UNIT; if(present(unit)) u = unit; iostatd = 0 ; iomsgd = '' - write(unit=u, fmt='(A)',iostat=iostatd,iomsg=iomsgd) this%Prefix//' '//txt - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine - - - subroutine MessageHandler_Warn(this, txt, unit, file, line, iostat, iomsg) - !----------------------------------------------------------------- - !< Warn a with txt message preceding for WARNING! - !----------------------------------------------------------------- - class(MessageHandler_t), intent(IN) :: this !< Message handler - character(len=*), intent(IN) :: txt !< Text to print - integer(I4P), optional, intent(IN) :: unit !< Unit where to print - character(*), optional, intent(IN) :: file !< Source file - integer(I4P), optional, intent(IN) :: line !< Number of line in source file - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: loc !< Warning location string - integer(I4P) :: iostatd !< Real IO error. - integer(I4P) :: u !< Real unit - character(500) :: iomsgd !< Real IO error message. - !----------------------------------------------------------------- - u = ERROR_UNIT; if(present(unit)) u = unit; iostatd = 0 ; iomsgd = ''; loc='' - if(present(file) .and. present(line)) & - loc='('//file//':'//trim(str(no_sign=.true.,n=line))//') ' +subroutine MessageHandler_Print(this, txt, unit, iostat, iomsg) + !----------------------------------------------------------------- + !< Print a txt message preceding for prefix + !----------------------------------------------------------------- + class(MessageHandler_t), intent(IN) :: this !< Message handler + character(len=*), intent(IN) :: txt !< Text to print + integer(I4P), optional, intent(IN) :: unit !< Unit where to print + integer(I4P), optional, intent(OUT) :: iostat !< IO error. + character(*), optional, intent(OUT) :: iomsg !< IO error message. + integer(I4P) :: iostatd !< Real IO error. + integer(I4P) :: u !< Real unit + character(500) :: iomsgd !< Real IO error message. + !----------------------------------------------------------------- + u = OUTPUT_UNIT; if (present(unit)) u = unit; iostatd = 0; iomsgd = '' + write (unit=u, fmt='(A)', iostat=iostatd, iomsg=iomsgd) this%Prefix//' '//txt + if (present(iostat)) iostat = iostatd + if (present(iomsg)) iomsg = iomsgd +end subroutine + +subroutine MessageHandler_Warn(this, txt, unit, file, line, iostat, iomsg) + !----------------------------------------------------------------- + !< Warn a with txt message preceding for WARNING! + !----------------------------------------------------------------- + class(MessageHandler_t), intent(IN) :: this !< Message handler + character(len=*), intent(IN) :: txt !< Text to print + integer(I4P), optional, intent(IN) :: unit !< Unit where to print + character(*), optional, intent(IN) :: file !< Source file + integer(I4P), optional, intent(IN) :: line !< Number of line in source file + integer(I4P), optional, intent(OUT) :: iostat !< IO error. + character(*), optional, intent(OUT) :: iomsg !< IO error message. + character(len=:), allocatable :: loc !< Warning location string + integer(I4P) :: iostatd !< Real IO error. + integer(I4P) :: u !< Real unit + character(500) :: iomsgd !< Real IO error message. + !----------------------------------------------------------------- + u = ERROR_UNIT; if (present(unit)) u = unit; iostatd = 0; iomsgd = ''; loc = '' + if (present(file) .and. present(line)) & + loc = '('//file//':'//trim(str(no_sign=.true., n=line))//') ' call this%Print('WARNING! '//trim(adjustl(loc//txt)), unit=u, iostat=iostatd, iomsg=iomsgd) - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine - - - subroutine MessageHandler_Error(this, txt, unit, file, line, iostat, iomsg) - !----------------------------------------------------------------- - !< Print a txt message preceding for ERROR! - !----------------------------------------------------------------- - class(MessageHandler_t), intent(IN) :: this !< Message handler - character(len=*), intent(IN) :: txt !< Text to print - integer(I4P), optional, intent(IN) :: unit !< Unit where to print - character(*), optional, intent(IN) :: file !< Source file - integer(I4P), optional, intent(IN) :: line !< Number of line in source file - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: loc !< Error location string - integer(I4P) :: iostatd !< Real IO error. - integer(I4P) :: u !< Real unit - character(500) :: iomsgd !< Real IO error message. - !----------------------------------------------------------------- - u = ERROR_UNIT; if(present(unit)) u = unit; iostatd = 0 ; iomsgd = '' - loc = '' - if(present(file) .and. present(line)) & - loc='('//file//':'//trim(str(no_sign=.true.,n=line))//') ' + if (present(iostat)) iostat = iostatd + if (present(iomsg)) iomsg = iomsgd +end subroutine + +subroutine MessageHandler_Error(this, txt, unit, file, line, iostat, iomsg) + !----------------------------------------------------------------- + !< Print a txt message preceding for ERROR! + !----------------------------------------------------------------- + class(MessageHandler_t), intent(IN) :: this !< Message handler + character(len=*), intent(IN) :: txt !< Text to print + integer(I4P), optional, intent(IN) :: unit !< Unit where to print + character(*), optional, intent(IN) :: file !< Source file + integer(I4P), optional, intent(IN) :: line !< Number of line in source file + integer(I4P), optional, intent(OUT) :: iostat !< IO error. + character(*), optional, intent(OUT) :: iomsg !< IO error message. + character(len=:), allocatable :: loc !< Error location string + integer(I4P) :: iostatd !< Real IO error. + integer(I4P) :: u !< Real unit + character(500) :: iomsgd !< Real IO error message. + !----------------------------------------------------------------- + u = ERROR_UNIT; if (present(unit)) u = unit; iostatd = 0; iomsgd = '' + loc = '' + if (present(file) .and. present(line)) & + loc = '('//file//':'//trim(str(no_sign=.true., n=line))//') ' call this%Print('ERROR! '//trim(adjustl(loc//txt)), unit=u, iostat=iostatd, iomsg=iomsgd) - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine - + if (present(iostat)) iostat = iostatd + if (present(iomsg)) iomsg = iomsgd +end subroutine end module From afe5457fa593e7a618f7ab2ad61b8987cf64792f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:45:22 +0900 Subject: [PATCH 31/43] undefined --- src/modules/Geometry/src/ReferenceElement_Method.F90 | 2 +- src/modules/Geometry/src/ReferenceLine_Method.F90 | 8 ++++---- src/modules/Geometry/src/ReferenceTriangle_Method.F90 | 8 ++++---- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 index 0a932e400..d96e06793 100644 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -733,7 +733,7 @@ END FUNCTION Facet_Matrix_RefElem ! summary: This routine returns the facet elements INTERFACE - MODULE PURE FUNCTION RefElem_FacetElements(RefElem) RESULT(ans) + MODULE FUNCTION RefElem_FacetElements(RefElem) RESULT(ans) CLASS(ReferenceElement_), INTENT(IN) :: RefElem TYPE(ReferenceElement_), ALLOCATABLE :: ans(:) END FUNCTION RefElem_FacetElements diff --git a/src/modules/Geometry/src/ReferenceLine_Method.F90 b/src/modules/Geometry/src/ReferenceLine_Method.F90 index 948b834a0..f34668972 100644 --- a/src/modules/Geometry/src/ReferenceLine_Method.F90 +++ b/src/modules/Geometry/src/ReferenceLine_Method.F90 @@ -56,7 +56,7 @@ MODULE ReferenceLine_Method !``` INTERFACE - MODULE PURE SUBROUTINE initiate_ref_Line(obj, nsd, xij) + MODULE SUBROUTINE initiate_ref_Line(obj, nsd, xij) CLASS(ReferenceLine_), INTENT(INOUT) :: obj !! The instance INTEGER(I4B), INTENT(IN) :: nsd @@ -101,7 +101,7 @@ END SUBROUTINE initiate_ref_Line !``` INTERFACE - MODULE PURE FUNCTION reference_line(nsd, xij) RESULT(obj) + MODULE FUNCTION reference_line(nsd, xij) RESULT(obj) INTEGER(I4B), INTENT(IN) :: nsd REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) TYPE(ReferenceLine_) :: obj @@ -143,7 +143,7 @@ END FUNCTION reference_line !``` INTERFACE - MODULE PURE FUNCTION reference_line_pointer_1(nsd, xij) RESULT(obj) + MODULE FUNCTION reference_line_pointer_1(nsd, xij) RESULT(obj) INTEGER(I4B), INTENT(IN) :: nsd REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) CLASS(ReferenceLine_), POINTER :: obj @@ -181,7 +181,7 @@ END FUNCTION reference_line_pointer_1 !``` INTERFACE - MODULE PURE SUBROUTINE highorderElement_Line(refelem, order, obj, & + MODULE SUBROUTINE highorderElement_Line(refelem, order, obj, & & ipType) CLASS(ReferenceElement_), INTENT(IN) :: refelem !! Linear line element diff --git a/src/modules/Geometry/src/ReferenceTriangle_Method.F90 b/src/modules/Geometry/src/ReferenceTriangle_Method.F90 index 741e8b417..6ce572c19 100644 --- a/src/modules/Geometry/src/ReferenceTriangle_Method.F90 +++ b/src/modules/Geometry/src/ReferenceTriangle_Method.F90 @@ -57,7 +57,7 @@ MODULE ReferenceTriangle_Method !``` INTERFACE - MODULE PURE SUBROUTINE initiate_ref_Triangle(obj, nsd, xij) + MODULE SUBROUTINE initiate_ref_Triangle(obj, nsd, xij) CLASS(ReferenceTriangle_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: nsd REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) @@ -96,7 +96,7 @@ END SUBROUTINE initiate_ref_Triangle !``` INTERFACE - MODULE PURE FUNCTION reference_Triangle(nsd, xij) RESULT(obj) + MODULE FUNCTION reference_Triangle(nsd, xij) RESULT(obj) INTEGER(I4B), INTENT(IN) :: nsd REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) TYPE(ReferenceTriangle_) :: obj @@ -135,7 +135,7 @@ END FUNCTION reference_Triangle !``` INTERFACE - MODULE PURE FUNCTION reference_Triangle_pointer(nsd, xij) RESULT(obj) + MODULE FUNCTION reference_Triangle_pointer(nsd, xij) RESULT(obj) INTEGER(I4B), INTENT(IN) :: nsd REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) CLASS(ReferenceTriangle_), POINTER :: obj @@ -177,7 +177,7 @@ END FUNCTION reference_Triangle_pointer !``` INTERFACE - MODULE PURE SUBROUTINE highorderElement_Triangle(refelem, order, obj, & + MODULE SUBROUTINE highorderElement_Triangle(refelem, order, obj, & & ipType) CLASS(ReferenceElement_), INTENT(IN) :: refelem INTEGER(I4B), INTENT(IN) :: order From 8e321fd84bf0e080a66ce1b9ad5f19b99e5deadc Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:45:28 +0900 Subject: [PATCH 32/43] undefined --- src/modules/GlobalData/src/GlobalData.F90 | 143 ++++++++++++++++++---- 1 file changed, 119 insertions(+), 24 deletions(-) diff --git a/src/modules/GlobalData/src/GlobalData.F90 b/src/modules/GlobalData/src/GlobalData.F90 index 868c8947e..4022cd154 100755 --- a/src/modules/GlobalData/src/GlobalData.F90 +++ b/src/modules/GlobalData/src/GlobalData.F90 @@ -249,12 +249,12 @@ MODULE GlobalData INTEGER(DIP), PARAMETER :: BYInt = BIT_SIZE(MaxInt) / 8_DIP !default in bytes INTEGER(DIP), PARAMETER :: BYI4B = BIT_SIZE(MaxInt) / 8_DIP ! default in bytes REAL(DFP), PARAMETER :: Pi = 3.14159265359_DFP -REAL(DFP), PARAMETER, DIMENSION(3, 3) :: Eye3 = RESHAPE( & - (/1.0_DFP, 0.0_DFP, 0.0_DFP, & - 0.0_DFP, 1.0_DFP, 0.0_DFP, & - 0.0_DFP, 0.0_DFP, 1.0_DFP/), (/3, 3/)) -REAL(DFP), PARAMETER, DIMENSION(2, 2) :: Eye2 = RESHAPE( & - (/1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP/), (/2, 2/)) +REAL(DFP), PARAMETER :: Eye3(3, 3) = RESHAPE( & + & [1.0_DFP, 0.0_DFP, 0.0_DFP, & + & 0.0_DFP, 1.0_DFP, 0.0_DFP, & + & 0.0_DFP, 0.0_DFP, 1.0_DFP], [3, 3]) +REAL(DFP), PARAMETER :: Eye2(2, 2) = RESHAPE( & + & [1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP], [2, 2]) ! Parameters for iteration data INTEGER(I4B), PARAMETER :: RelativeConvergence = 1 INTEGER(I4B), PARAMETER :: AbsoluteConvergence = 2 @@ -265,32 +265,74 @@ MODULE GlobalData INTEGER(I4B), PARAMETER :: NormL1 = 1 INTEGER(I4B), PARAMETER :: NormL2 = 2 INTEGER(I4B), PARAMETER :: NormInfinity = 3 -! Type of shape functions +!! +!! Type of polynomial for scale interpolation +!! INTEGER(I4B), PARAMETER :: LagrangePolynomial = 1 INTEGER(I4B), PARAMETER :: SerendipityPolynomial = 2 INTEGER(I4B), PARAMETER :: HeirarchicalPolynomial = 3 +INTEGER(I4B), PARAMETER :: Jacobi = 4 +INTEGER(I4B), PARAMETER :: Ultraspherical = 5 +INTEGER(I4B), PARAMETER :: Legendre = 6 +INTEGER(I4B), PARAMETER :: Chebyshev = 7 +INTEGER(I4B), PARAMETER :: Lobatto = 8 +!! +!! Quadrature types +!! INTEGER(I4B), PARAMETER :: Equidistance = 1 -INTEGER(I4B), PARAMETER :: GaussLegendre = 2 -INTEGER(I4B), PARAMETER :: GaussLobatto = 3 -INTEGER(I4B), PARAMETER :: Chebyshev = 4 -INTEGER(I4B), PARAMETER :: Gauss = 5 -INTEGER(I4B), PARAMETER :: GaussRadau = 6 -INTEGER(I4B), PARAMETER :: GaussRadauLeft = 7 -INTEGER(I4B), PARAMETER :: GaussRadauRight = 8 -! Type of Lagrange Interpolation Poitns -INTEGER(I4B), PARAMETER :: EquidistanceLIP = Equidistance -INTEGER(I4B), PARAMETER :: GaussLobattoLIP = GaussLobatto -INTEGER(I4B), PARAMETER :: GaussLegendreLIP = GaussLegendre -INTEGER(I4B), PARAMETER :: ChebyshevLIP = Chebyshev -! Type of quadrature points -INTEGER(I4B), PARAMETER :: GaussLegendreQP = GaussLegendre -INTEGER(I4B), PARAMETER :: GaussLobattoQP = GaussLobatto -INTEGER(I4B), PARAMETER :: ChebyshevQP = Chebyshev +INTEGER(I4B), PARAMETER :: Gauss = 2 +INTEGER(I4B), PARAMETER :: GaussRadau = 3 +INTEGER(I4B), PARAMETER :: GaussRadauLeft = 4 +INTEGER(I4B), PARAMETER :: GaussRadauRight = 5 +INTEGER(I4B), PARAMETER :: GaussLobatto = 6 +!! +INTEGER(I4B), PARAMETER :: GaussLegendre = 7 +INTEGER(I4B), PARAMETER :: GaussLegendreLobatto = 8 +INTEGER(I4B), PARAMETER :: GaussLegendreRadau = 9 +INTEGER(I4B), PARAMETER :: GaussLegendreRadauLeft = 10 +INTEGER(I4B), PARAMETER :: GaussLegendreRadauRight = 11 +!! +INTEGER(I4B), PARAMETER :: GaussChebyshev = 12 +INTEGER(I4B), PARAMETER :: GaussChebyshevRadau = 13 +INTEGER(I4B), PARAMETER :: GaussChebyshevRadauLeft = 14 +INTEGER(I4B), PARAMETER :: GaussChebyshevRadauRight = 15 +INTEGER(I4B), PARAMETER :: GaussChebyshevLobatto = 16 +!! +INTEGER(I4B), PARAMETER :: GaussJacobi = 17 +INTEGER(I4B), PARAMETER :: GaussJacobiRadau = 18 +INTEGER(I4B), PARAMETER :: GaussJacobiRadauLeft = 19 +INTEGER(I4B), PARAMETER :: GaussJacobiRadauRight = 20 +INTEGER(I4B), PARAMETER :: GaussJacobiLobatto = 21 +!! +!! Type of quadrature points +!! INTEGER(I4B), PARAMETER :: GaussQP = Gauss +INTEGER(I4B), PARAMETER :: GaussLegendreQP = GaussLegendre INTEGER(I4B), PARAMETER :: GaussRadauQP = GaussRadau INTEGER(I4B), PARAMETER :: GaussRadauLeftQP = GaussRadauLeft INTEGER(I4B), PARAMETER :: GaussRadauRightQP = GaussRadauRight -! Types of Elements +INTEGER(I4B), PARAMETER :: GaussLobattoQP = GaussLobatto +INTEGER(I4B), PARAMETER :: GaussChebyshevQP = GaussChebyshev +!! +INTEGER(I4B), PARAMETER :: ChenBabuska = 22 !! for triangle nodes +INTEGER(I4B), PARAMETER :: Hesthaven = 23 !! for triangle nodes +INTEGER(I4B), PARAMETER :: Feket = 24 !! for triangle nodes +!! +INTEGER(I4B), PARAMETER :: BlythPozLegendre = 25 !! for triangle +INTEGER(I4B), PARAMETER :: BlythPozChebyshev = 26 !! for triangle +!! +INTEGER(I4B), PARAMETER :: IsaacLegendre = 27 !! for triangle +INTEGER(I4B), PARAMETER :: IsaacChebyshev = 28 !! for triangle +!! +!! Type of Lagrange Interpolation Poitns +!! +INTEGER(I4B), PARAMETER :: EquidistanceLIP = Equidistance +INTEGER(I4B), PARAMETER :: GaussLobattoLIP = GaussLobatto +INTEGER(I4B), PARAMETER :: GaussLegendreLIP = GaussLegendre +INTEGER(I4B), PARAMETER :: ChebyshevLIP = Chebyshev +!! +!! Types of Element domain +!! INTEGER(I4B), PARAMETER :: Line = 1 INTEGER(I4B), PARAMETER :: Line2 = 1 INTEGER(I4B), PARAMETER :: Line3 = 8 @@ -507,3 +549,56 @@ MODULE GlobalData ! !---------------------------------------------------------------------------- END MODULE GlobalData + +! INTEGER(I4B), PARAMETER :: LagrangePolynomial = 1 +! INTEGER(I4B), PARAMETER :: SerendipityPolynomial = 2 +! INTEGER(I4B), PARAMETER :: HeirarchicalPolynomial = 3 +! INTEGER(I4B), PARAMETER :: Jacobi = 10 +! INTEGER(I4B), PARAMETER :: Ultraspherical = 15 +! INTEGER(I4B), PARAMETER :: Legendre = 2 +! INTEGER(I4B), PARAMETER :: Chebyshev = 4 +! INTEGER(I4B), PARAMETER :: Lobatto = 5 +! !! +! !! Quadrature types +! !! +! INTEGER(I4B), PARAMETER :: Equidistance = 1 +! INTEGER(I4B), PARAMETER :: Gauss = 5 +! INTEGER(I4B), PARAMETER :: GaussRadau = 6 +! INTEGER(I4B), PARAMETER :: GaussRadauLeft = 7 +! INTEGER(I4B), PARAMETER :: GaussRadauRight = 8 +! INTEGER(I4B), PARAMETER :: GaussLobatto = 3 +! INTEGER(I4B), PARAMETER :: GaussLegendre = Legendre +! INTEGER(I4B), PARAMETER :: GaussLegendreLobatto = GaussLobatto +! !! +! INTEGER(I4B), PARAMETER :: GaussChebyshev = Chebyshev +! INTEGER(I4B), PARAMETER :: GaussChebyshevLobatto = 9 +! !! +! INTEGER(I4B), PARAMETER :: GaussJacobi = Jacobi +! INTEGER(I4B), PARAMETER :: GaussJacobiLobatto = 11 +! !! +! INTEGER(I4B), PARAMETER :: ChenBabuska = 21 !! for triangle nodes +! INTEGER(I4B), PARAMETER :: Hesthaven = 22 !! for triangle nodes +! INTEGER(I4B), PARAMETER :: Feket = 23 !! for triangle nodes +! !! +! INTEGER(I4B), PARAMETER :: BlythPozLegendre = 24 !! for triangle +! INTEGER(I4B), PARAMETER :: BlythPozChebyshev = 25 !! for triangle +! !! +! INTEGER(I4B), PARAMETER :: IsaacLegendre = 26 !! for triangle +! INTEGER(I4B), PARAMETER :: IsaacChebyshev = 27 !! for triangle +! !! +! !! Type of Lagrange Interpolation Poitns +! !! +! INTEGER(I4B), PARAMETER :: EquidistanceLIP = Equidistance +! INTEGER(I4B), PARAMETER :: GaussLobattoLIP = GaussLobatto +! INTEGER(I4B), PARAMETER :: GaussLegendreLIP = GaussLegendre +! INTEGER(I4B), PARAMETER :: ChebyshevLIP = Chebyshev +! !! +! !! Type of quadrature points +! !! +! INTEGER(I4B), PARAMETER :: GaussQP = Gauss +! INTEGER(I4B), PARAMETER :: GaussLegendreQP = GaussLegendre +! INTEGER(I4B), PARAMETER :: GaussRadauQP = GaussRadau +! INTEGER(I4B), PARAMETER :: GaussRadauLeftQP = GaussRadauLeft +! INTEGER(I4B), PARAMETER :: GaussRadauRightQP = GaussRadauRight +! INTEGER(I4B), PARAMETER :: GaussLobattoQP = GaussLobatto +! INTEGER(I4B), PARAMETER :: ChebyshevQP = Chebyshev \ No newline at end of file From 79ae6d1388774546df6d7ece97bb61f4e4ed2356 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:45:41 +0900 Subject: [PATCH 33/43] undefined --- src/modules/Lapack/src/GE_CompRoutine.inc | 116 +++++++++++++++++++++- src/modules/PENF/src/STR.inc | 29 ++---- src/modules/Polynomial/CMakeLists.txt | 3 +- 3 files changed, 124 insertions(+), 24 deletions(-) diff --git a/src/modules/Lapack/src/GE_CompRoutine.inc b/src/modules/Lapack/src/GE_CompRoutine.inc index 187f619b9..f72960fc4 100644 --- a/src/modules/Lapack/src/GE_CompRoutine.inc +++ b/src/modules/Lapack/src/GE_CompRoutine.inc @@ -15,6 +15,9 @@ ! along with this program. If not, see ! +PUBLIC :: ConditionNo +PUBLIC :: GetInvMat + !---------------------------------------------------------------------------- ! ConditionNo !---------------------------------------------------------------------------- @@ -34,4 +37,115 @@ INTERFACE ConditionNo MODULE PROCEDURE ge_ConditionNo_1 END INTERFACE ConditionNo -PUBLIC :: ConditionNo +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of matrix +! +!# Introduction +! +! This routine calls `DGETRI` routine from Lapack. +! A copy of matrix A is made into invA, then LU decomposition is performed and +! `DGETRI` is called from lapack + +INTERFACE + MODULE SUBROUTINE ge_GetInvMat1(A, invA) + REAL(DFP), INTENT(IN) :: A(:, :) + !! General matrix + REAL(DFP), INTENT(INOUT) :: invA(:, :) + !! + END SUBROUTINE ge_GetInvMat1 +END INTERFACE + +INTERFACE GetInvMat + MODULE PROCEDURE ge_GetInvMat1 +END INTERFACE GetInvMat + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of matrix +! +!# Introduction +! +!- This routine calls `DGETRI` routine from Lapack. +!- A and IPIV are obtained from LU decomposition +!- A contains the LU decomposition of matrix A +!- A copy of matrix A is made into invA, then +! `DGETRI` is called from lapack + +INTERFACE + MODULE SUBROUTINE ge_GetInvMat2(A, IPIV, invA) + REAL(DFP), INTENT(IN) :: A(:, :) + !! General matrix + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! General matrix + REAL(DFP), INTENT(INOUT) :: invA(:, :) + !! + END SUBROUTINE ge_GetInvMat2 +END INTERFACE + +INTERFACE GetInvMat + MODULE PROCEDURE ge_GetInvMat2 +END INTERFACE GetInvMat + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of matrix +! +!# Introduction +! +!- This routine calls `DGETRI` routine from Lapack. +!- A and IPIV are obtained from LU decomposition +!- A contains the LU decomposition of matrix A at input +!- At output invese of A is stored inside A +!- No copy is made. + +INTERFACE + MODULE SUBROUTINE ge_GetInvMat3(A, IPIV) + REAL(DFP), INTENT(INOUT) :: A(:, :) + !! LU Decompose at input + !! inverse at output + INTEGER(I4B), INTENT(IN) :: IPIV(:) + !! + END SUBROUTINE ge_GetInvMat3 +END INTERFACE + +INTERFACE GetInvMat + MODULE PROCEDURE ge_GetInvMat3 +END INTERFACE GetInvMat + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of matrix +! +!# Introduction +! +!- This routine calls `DGETRI` routine from Lapack. +!- First LU decomposition is performed +!- Then `DGETRI` is called from lapack +!- At output A contains the inverse. + +INTERFACE + MODULE SUBROUTINE ge_GetInvMat4(A) + REAL(DFP), INTENT(INOUT) :: A(:, :) + END SUBROUTINE ge_GetInvMat4 +END INTERFACE + +INTERFACE GetInvMat + MODULE PROCEDURE ge_GetInvMat4 +END INTERFACE GetInvMat diff --git a/src/modules/PENF/src/STR.inc b/src/modules/PENF/src/STR.inc index 577fe93b8..894fff6f3 100644 --- a/src/modules/PENF/src/STR.inc +++ b/src/modules/PENF/src/STR.inc @@ -235,9 +235,7 @@ elemental function str_R16P(n, no_sign, compact) result(str) write (str, FR16P) n ! Casting of n to string. !! if (present(no_sign)) then - if( no_sign ) then - str = str(2:) ! Leaving out the sign. - else + if (.not. no_sign) then if (n > 0._R16P) str(1:1) = '+' ! Prefixing plus if n>0. end if end if @@ -288,9 +286,7 @@ elemental function str_R8P(n, no_sign, compact) result(str) write (str, FR8P) n ! Casting of n to string. !! if (present(no_sign)) then - if( no_sign ) then - str = str(2:) ! Leaving out the sign. - else + if (.not. no_sign) then if (n > 0._R8P) str(1:1) = '+' ! Prefixing plus if n>0. end if end if @@ -340,9 +336,7 @@ elemental function str_R4P(n, no_sign, compact) result(str) write (str, FR4P) n ! Casting of n to string. !! if (present(no_sign)) then - if( no_sign ) then - str = str(2:) ! Leaving out the sign. - else + if (.not. no_sign) then if (n > 0._R4P) str(1:1) = '+' ! Prefixing plus if n>0. end if end if @@ -385,9 +379,7 @@ elemental function str_I8P(n, no_sign) result(str) str = adjustl(trim(str)) ! Removing white spaces. !! if (present(no_sign)) then - if( no_sign ) then - str = str(2:) ! Leaving out the sign. - else + if (.not. no_sign) then if (n >= 0_I8P) str = '+'//trim(str) ! Prefixing plus if n>0. end if end if @@ -429,9 +421,7 @@ elemental function str_I4P(n, no_sign) result(str) str = adjustl(trim(str)) ! Removing white spaces. !! if (present(no_sign)) then - if( no_sign ) then - str = str(2:) ! Leaving out the sign. - else + if (.not. no_sign) then if (n >= 0_I4P) str = '+'//trim(str) ! Prefixing plus if n>0. end if end if @@ -472,9 +462,7 @@ elemental function str_I2P(n, no_sign) result(str) str = adjustl(trim(str)) ! Removing white spaces. !! if (present(no_sign)) then - if( no_sign ) then - str = str(2:) ! Leaving out the sign. - else + if (.not. no_sign) then if (n >= 0_I2P) str = '+'//trim(str) ! Prefixing plus if n>0. end if end if @@ -516,9 +504,7 @@ elemental function str_I1P(n, no_sign) result(str) str = adjustl(trim(str)) ! Removing white spaces. !! if (present(no_sign)) then - if( no_sign ) then - str = str(2:) ! Leaving out the sign. - else + if (.not. no_sign) then if (n >= 0_I1P) str = '+'//trim(str) ! Prefixing plus if n>0. end if end if @@ -668,7 +654,6 @@ end function str_a_R16P !``` !=> +0.1E+1,-0.2E+1 <<< - pure function str_a_R8P(n, no_sign, separator, delimiters, compact) & & result(str) real(R8P), intent(in) :: n(:) diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index 5912b52e1..86560150e 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -19,9 +19,10 @@ SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") TARGET_SOURCES( ${PROJECT_NAME} PRIVATE ${src_path}/InterpolationUtility.F90 - ${src_path}/LagrangeUtility.F90 + ${src_path}/LagrangePolynomialUtility.F90 ${src_path}/OrthogonalPolynomialUtility.F90 ${src_path}/JacobiPolynomialUtility.F90 + ${src_path}/UltrasphericalPolynomialUtility.F90 ${src_path}/LegendrePolynomialUtility.F90 ${src_path}/LobattoPolynomialUtility.F90 ${src_path}/UnscaledLobattoPolynomialUtility.F90 From 9d10439d9e2fed26e1987246ed5e38df39231a2c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:46:03 +0900 Subject: [PATCH 34/43] undefined --- .../src/LagrangePolynomialUtility.F90 | 280 ++++ .../Polynomial/src/LagrangeUtility.F90 | 161 --- .../src/UltrasphericalPolynomialUtility.F90 | 1170 +++++++++++++++++ 3 files changed, 1450 insertions(+), 161 deletions(-) create mode 100644 src/modules/Polynomial/src/LagrangePolynomialUtility.F90 delete mode 100644 src/modules/Polynomial/src/LagrangeUtility.F90 create mode 100644 src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 new file mode 100644 index 000000000..cc6bde8ed --- /dev/null +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -0,0 +1,280 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Methods for Lagrange polynomials are defined +! +!{!pages/LagrangePolynomialUtility_.md!} + +MODULE LagrangePolynomialUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! LagrangeDOF@BasisMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the number of dof for lagrange polynomial + +INTERFACE + MODULE PURE FUNCTION LagrangeDOF(order, elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + !! number of degree of freedom + END FUNCTION LagrangeDOF +END INTERFACE + +PUBLIC :: LagrangeDOF + +!---------------------------------------------------------------------------- +! LagrangeInDOF@BasisMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the number of internal dof for lagrange polynomial + +INTERFACE + MODULE PURE FUNCTION LagrangeInDOF(order, elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + !! number of degree of freedom + END FUNCTION LagrangeInDOF +END INTERFACE + +PUBLIC :: LagrangeInDOF + +!---------------------------------------------------------------------------- +! LagrangeDegree +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the degrees of monomials for lagrange polynomial + +INTERFACE + MODULE PURE FUNCTION LagrangeDegree(order, elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: elemType + !! Element type: Line, Triangle, Quadrangle, Tetrahedron, ... + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree +END INTERFACE + +PUBLIC :: LagrangeDegree + +!---------------------------------------------------------------------------- +! LagrangeVandermonde +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the Vandermonde matrix + +INTERFACE + MODULE PURE FUNCTION LagrangeVandermonde(xij, order, elemType) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in $x_{iJ}$ format + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! vandermonde matrix nrows = number of points + !! ncols = number of dof + END FUNCTION LagrangeVandermonde +END INTERFACE + +PUBLIC :: LagrangeVandermonde + +!---------------------------------------------------------------------------- +! EquidistancePoint +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Equidistance points on 1D/2D/3D elements + +INTERFACE + MODULE PURE FUNCTION EquidistancePoint(order, elemType, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + INTEGER(I4B), INTENT(IN) :: elemType + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION EquidistancePoint +END INTERFACE + +PUBLIC :: EquidistancePoint + +!---------------------------------------------------------------------------- +! InterpolationPoint +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: Get the interpolation point + +INTERFACE + MODULE FUNCTION InterpolationPoint(order, elemType, ipType, & + & xij, layout) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! domain of interpolation, default values are given by + !! line = [-1,1] + !! triangle = (0,0), (0,1), (1,0) + !! quadrangle = [-1,1]x[-1,1] + CHARACTER(LEN=*), INTENT(IN) :: layout + !! "VEFC" Vertex, Edge, Face, Cell + !! "INCREASING" incresing order + !! "DECREASING" decreasing order + !! "XYZ" First X, then Y, then Z + !! "YXZ" First Y, then X, then Z + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION InterpolationPoint +END INTERFACE + +PUBLIC :: InterpolationPoint + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Returns the coefficient of ith lagrange poly + +INTERFACE + MODULE FUNCTION LagrangeCoeff1(order, elemType, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff1 +END INTERFACE + +INTERFACE LagrangeCoeff + MODULE PROCEDURE LagrangeCoeff1 +END INTERFACE LagrangeCoeff + +PUBLIC :: LagrangeCoeff + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Returns the coefficient of all lagrange poly + +INTERFACE + MODULE FUNCTION LagrangeCoeff2(order, elemType, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff2 +END INTERFACE + +INTERFACE LagrangeCoeff + MODULE PROCEDURE LagrangeCoeff2 +END INTERFACE LagrangeCoeff + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff3(order, elemType, i, v, & + & isVandermonde) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff3 +END INTERFACE + +INTERFACE LagrangeCoeff + MODULE PROCEDURE LagrangeCoeff3 +END INTERFACE LagrangeCoeff + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff4(order, elemType, i, v, ipiv) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff4 +END INTERFACE + +INTERFACE LagrangeCoeff + MODULE PROCEDURE LagrangeCoeff4 +END INTERFACE LagrangeCoeff + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE LagrangePolynomialUtility diff --git a/src/modules/Polynomial/src/LagrangeUtility.F90 b/src/modules/Polynomial/src/LagrangeUtility.F90 deleted file mode 100644 index e89778308..000000000 --- a/src/modules/Polynomial/src/LagrangeUtility.F90 +++ /dev/null @@ -1,161 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -MODULE LagrangeUtility -USE GlobalData -IMPLICIT NONE -PRIVATE - -!---------------------------------------------------------------------------- -! LagrangeDOF@BasisMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the number of dof for lagrange polynomial -! -!# Introduction -! -! this routine returns the number of dof for lagrange polynomial - -INTERFACE - MODULE PURE FUNCTION LagrangeDOF(order, elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - !! number of degree of freedom - END FUNCTION LagrangeDOF -END INTERFACE - -PUBLIC :: LagrangeDOF - -!---------------------------------------------------------------------------- -! LagrangeInDOF@BasisMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the number of dof for lagrange polynomial - -INTERFACE - MODULE PURE FUNCTION LagrangeInDOF(order, elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - !! number of degree of freedom - END FUNCTION LagrangeInDOF -END INTERFACE - -PUBLIC :: LagrangeInDOF - -!---------------------------------------------------------------------------- -! LagrangeDegree -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the degrees of monomials for lagrange polynomial -! -!# Introduction -! -! this routine returns the degrees of monomials for lagrange polynomial on -! triangles and quadrilaterals. - -INTERFACE - MODULE PURE FUNCTION LagrangeDegree(order, elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION LagrangeDegree -END INTERFACE - -PUBLIC :: LagrangeDegree - -!---------------------------------------------------------------------------- -! LagrangeVandermonde -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the degrees of monomials for lagrange polynomial -! -!# Introduction -! -! this routine returns the degrees of monomials for lagrange polynomial on -! triangles and quadrilaterals. - -INTERFACE - MODULE PURE FUNCTION LagrangeVandermonde(x, order, elemType) & - & RESULT(ans) - REAL(DFP), INTENT(IN) :: x(:, :) - !! points in $x_{iJ}$ format - INTEGER(I4B), INTENT(IN) :: order - !! order - INTEGER(I4B), INTENT(IN) :: elemType - !! element type - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! vandermonde matrix nrows = number of points - !! ncols = number of dof - END FUNCTION LagrangeVandermonde -END INTERFACE - -PUBLIC :: LagrangeVandermonde - -!---------------------------------------------------------------------------- -! EquidistancePoint -!---------------------------------------------------------------------------- - -INTERFACE - MODULE PURE FUNCTION EquidistancePoint(order, xij, elemType) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - INTEGER(I4B), INTENT(IN) :: elemType - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION EquidistancePoint -END INTERFACE - -PUBLIC :: EquidistancePoint - -!---------------------------------------------------------------------------- -! InterpolationPoint -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: Get the interpolation point - -INTERFACE - MODULE PURE FUNCTION InterpolationPoint(order, elemType, ipType, xij) & - & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: ipType - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION InterpolationPoint -END INTERFACE - -PUBLIC :: InterpolationPoint - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE LagrangeUtility diff --git a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 new file mode 100644 index 000000000..2771c46d8 --- /dev/null +++ b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 @@ -0,0 +1,1170 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Utility related to Ultraspherical Polynomials is defined. +! +!{!pages/UltrasphericalPolynomialUtility.md!} + +MODULE UltrasphericalPolynomialUtility +USE GlobalData +USE BaseType, ONLY: iface_1DFunction +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! UltrasphericalAlpha +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, alpha , of Ultraspherical polynomial + +INTERFACE + MODULE PURE FUNCTION UltrasphericalAlpha(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + !! answer + END FUNCTION UltrasphericalAlpha +END INTERFACE + +PUBLIC :: UltrasphericalAlpha + +!---------------------------------------------------------------------------- +! UltrasphericalBeta +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, beta, of Ultraspherical polynomial + +INTERFACE + MODULE PURE FUNCTION UltrasphericalBeta(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + !! answer + END FUNCTION UltrasphericalBeta +END INTERFACE + +PUBLIC :: UltrasphericalBeta + +!---------------------------------------------------------------------------- +! GetUltrasphericalRecurrenceCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the recurrence coefficient for nth order polynomial (monic) + +INTERFACE + MODULE PURE SUBROUTINE GetUltrasphericalRecurrenceCoeff(n, & + & lambda, alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial, it should be greater than 1 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + !! lambda should not be zero + REAL(DFP), INTENT(OUT) :: alphaCoeff(0:n - 1) + REAL(DFP), INTENT(OUT) :: betaCoeff(0:n - 1) + END SUBROUTINE GetUltrasphericalRecurrenceCoeff +END INTERFACE + +PUBLIC :: GetUltrasphericalRecurrenceCoeff + +!---------------------------------------------------------------------------- +! GetUltrasphericalRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the recurrence coefficient for nth order polynomial (monic) + +INTERFACE + MODULE PURE SUBROUTINE GetUltrasphericalRecurrenceCoeff2(n, lambda, & + & A, B, C) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial, it should be greater than 1 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + !! lambda should not be 0.0 + REAL(DFP), INTENT(OUT) :: A(0:n - 1) + !! size is n + REAL(DFP), INTENT(OUT) :: B(0:n - 1) + !! this coefficient is zero + REAL(DFP), INTENT(OUT) :: C(0:n - 1) + !! size is n + END SUBROUTINE GetUltrasphericalRecurrenceCoeff2 +END INTERFACE + +PUBLIC :: GetUltrasphericalRecurrenceCoeff2 + +!---------------------------------------------------------------------------- +! UltrasphericalLeadingCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Leading coefficient of Ultraspherical polynomial + +INTERFACE + MODULE PURE FUNCTION UltrasphericalLeadingCoeff(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + !! answer + END FUNCTION UltrasphericalLeadingCoeff +END INTERFACE + +PUBLIC :: UltrasphericalLeadingCoeff + +!---------------------------------------------------------------------------- +! UltrasphericalLeadingCoeffRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Ratio of leading coefficients, kn+1/kn + +INTERFACE + MODULE PURE FUNCTION UltrasphericalLeadingCoeffRatio(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + !! answer + END FUNCTION UltrasphericalLeadingCoeffRatio +END INTERFACE + +PUBLIC :: UltrasphericalLeadingCoeffRatio + +!---------------------------------------------------------------------------- +! UltrasphericalNormSQR +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of Ultraspherical polynomial + +INTERFACE + MODULE PURE FUNCTION UltrasphericalNormSQR(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + END FUNCTION UltrasphericalNormSQR +END INTERFACE + +PUBLIC :: UltrasphericalNormSQR + +!---------------------------------------------------------------------------- +! UltrasphericalNormSQR2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of Ultraspherical polynomial + +INTERFACE + MODULE PURE FUNCTION UltrasphericalNormSQR2(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans(0:n) + END FUNCTION UltrasphericalNormSQR2 +END INTERFACE + +PUBLIC :: UltrasphericalNormSQR2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm ration of Ultraspherical polynomial, n+1/n + +INTERFACE + MODULE PURE FUNCTION UltrasphericalNormSQRRatio(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans + END FUNCTION UltrasphericalNormSQRRatio +END INTERFACE + +PUBLIC :: UltrasphericalNormSQRRatio + +!---------------------------------------------------------------------------- +! UltrasphericalJacobiMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the Jacobi matrix for Ultraspherical polynomial + +INTERFACE + MODULE PURE SUBROUTINE UltrasphericalJacobiMatrix(n, lambda, D, E, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + !! recurrence coefficient of monic Ultraspherical polynomial, from 0 to n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + !! recurrence coefficient of monic Ultraspherical polynomial, from 0 to n-1 + END SUBROUTINE UltrasphericalJacobiMatrix +END INTERFACE + +PUBLIC :: UltrasphericalJacobiMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalGaussQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss quadrature points for Ultraspherical Polynomial + +INTERFACE + MODULE SUBROUTINE UltrasphericalGaussQuadrature(n, lambda, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! It represents the order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: pt(:) + !! the size is 1 to n + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! the size is 1 to n + END SUBROUTINE UltrasphericalGaussQuadrature +END INTERFACE + +PUBLIC :: UltrasphericalGaussQuadrature + +!---------------------------------------------------------------------------- +! UltrasphericalJacobiRadauMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE UltrasphericalJacobiRadauMatrix(a, n, lambda, D, E, & + & alphaCoeff, betaCoeff) + REAL(DFP), INTENT(IN) :: a + !! one of the end of the domain + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+1 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE UltrasphericalJacobiRadauMatrix +END INTERFACE + +PUBLIC :: UltrasphericalJacobiRadauMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalGaussRadauQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss-Radau quadrature points for Ultraspherical +! Polynomial + +INTERFACE + MODULE SUBROUTINE UltrasphericalGaussRadauQuadrature(a, n, lambda, pt, wt) + REAL(DFP), INTENT(IN) :: a + !! the value of one of the end points + !! it should be either -1 or +1 + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: pt(:) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! n+1 weights from 1 to n+1 + END SUBROUTINE UltrasphericalGaussRadauQuadrature +END INTERFACE + +PUBLIC :: UltrasphericalGaussRadauQuadrature + +!---------------------------------------------------------------------------- +! UltrasphericalUltrasphericalLobattoMatrix +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE UltrasphericalJacobiLobattoMatrix(n, lambda, D, E, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+2 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE UltrasphericalJacobiLobattoMatrix +END INTERFACE + +PUBLIC :: UltrasphericalJacobiLobattoMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalGaussLobattoQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 Aug 2022 +! summary: Returns the Gauss-Lobatto quadrature points for Ultraspherical +! Polynomial + +INTERFACE + MODULE SUBROUTINE UltrasphericalGaussLobattoQuadrature(n, lambda, pt, wt) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomials + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: pt(:) + !! n+2 quad points indexed from 1 to n+2 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) + !! n+2 weights, index from 1 to n+2 + END SUBROUTINE UltrasphericalGaussLobattoQuadrature +END INTERFACE + +PUBLIC :: UltrasphericalGaussLobattoQuadrature + +!---------------------------------------------------------------------------- +! UltrasphericalZeros +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Returns zeros of Ultraspherical polynomials + +INTERFACE + MODULE FUNCTION UltrasphericalZeros(n, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP) :: ans(n) + END FUNCTION UltrasphericalZeros +END INTERFACE + +PUBLIC :: UltrasphericalZeros + +!---------------------------------------------------------------------------- +! UltrasphericalQuadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: This routine can return Ultraspherical-Gauss, Ultraspherical-Radau, +! Ultraspherical-Lobatto +! +!# Introduction +! +! This routine returns the Quadrature point of Ultraspherical polynomial +! +!@note +! Here n is the number of quadrature points. Please note it is not +! the order of Ultraspherical polynomial. The order is decided internally +! depending upon the quadType +!@endnote +! +!@note +! pt and wt should be allocated outside, and length should be n. +!@endnote +! + +INTERFACE + MODULE SUBROUTINE UltrasphericalQuadrature(n, lambda, pt, wt, & + & quadType, onlyInside) + INTEGER(I4B), INTENT(IN) :: n + !! number of quadrature points, the order will be computed as follows + !! for quadType = Gauss, n is same as order of Ultraspherical polynomial + !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 + !! for quadType = GaussLobatto, n = order+2 + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(OUT) :: pt(n) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) + !! n+1 weights from 1 to n+1 + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss + !! GaussRadauLeft + !! GaussRadauRight + !! GaussLobatto + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: onlyInside + !! only inside + END SUBROUTINE UltrasphericalQuadrature +END INTERFACE + +PUBLIC :: UltrasphericalQuadrature + +!---------------------------------------------------------------------------- +! UltrasphericalEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Ultraspherical polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at +! the point +! X. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalEval1(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalEval1 +END INTERFACE + +INTERFACE UltrasphericalEval + MODULE PROCEDURE UltrasphericalEval1 +END INTERFACE UltrasphericalEval + +PUBLIC :: UltrasphericalEval + +!---------------------------------------------------------------------------- +! UltrasphericalEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Ultraspherical polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at +! the point +! X. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalEval2(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalEval2 +END INTERFACE + +INTERFACE UltrasphericalEval + MODULE PROCEDURE UltrasphericalEval2 +END INTERFACE UltrasphericalEval + +!---------------------------------------------------------------------------- +! UltrasphericalEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Ultraspherical polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at +! the point +! X. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalEvalAll1(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(n + 1) + !! Evaluate Ultraspherical polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION UltrasphericalEvalAll1 +END INTERFACE + +INTERFACE UltrasphericalEvalAll + MODULE PROCEDURE UltrasphericalEvalAll1 +END INTERFACE UltrasphericalEvalAll + +PUBLIC :: UltrasphericalEvalAll + +!---------------------------------------------------------------------------- +! UltrasphericalEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Ultraspherical polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Ultraspherical polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- alpha, beta are parameters +!- x: the point at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Ultraspherical polynomials at +! the point +! X. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalEvalAll2(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Ultraspherical polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION UltrasphericalEvalAll2 +END INTERFACE + +INTERFACE UltrasphericalEvalAll + MODULE PROCEDURE UltrasphericalEvalAll2 +END INTERFACE UltrasphericalEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Ultraspherical polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Ultraspherical polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEvalAll1(n, lambda, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(1:n + 1) + END FUNCTION UltrasphericalGradientEvalAll1 +END INTERFACE + +INTERFACE UltrasphericalGradientEvalAll + MODULE PROCEDURE UltrasphericalGradientEvalAll1 +END INTERFACE UltrasphericalGradientEvalAll + +PUBLIC :: UltrasphericalGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Ultraspherical polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Ultraspherical polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEvalAll2(n, lambda, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) + END FUNCTION UltrasphericalGradientEvalAll2 +END INTERFACE + +INTERFACE UltrasphericalGradientEvalAll + MODULE PROCEDURE UltrasphericalGradientEvalAll2 +END INTERFACE UltrasphericalGradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Ultraspherical polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Ultraspherical polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEval1(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION UltrasphericalGradientEval1 +END INTERFACE +!! + +INTERFACE UltrasphericalGradientEval + MODULE PROCEDURE UltrasphericalGradientEval1 +END INTERFACE UltrasphericalGradientEval + +PUBLIC :: UltrasphericalGradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Ultraspherical polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Ultraspherical polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEval2(n, lambda, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda should be greater than -0.5 + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x)) + END FUNCTION UltrasphericalGradientEval2 +END INTERFACE + +INTERFACE UltrasphericalGradientEval + MODULE PROCEDURE UltrasphericalGradientEval2 +END INTERFACE UltrasphericalGradientEval + +!---------------------------------------------------------------------------- +! UltrasphericalEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Ultraspherical polynomials at point x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalEvalSum1(n, lambda, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! alpha of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalEvalSum1 +END INTERFACE + +INTERFACE UltrasphericalEvalSum + MODULE PROCEDURE UltrasphericalEvalSum1 +END INTERFACE UltrasphericalEvalSum + +PUBLIC :: UltrasphericalEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Ultraspherical polynomials at several x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalEvalSum2(n, lambda, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! alpha of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalEvalSum2 +END INTERFACE + +INTERFACE UltrasphericalEvalSum + MODULE PROCEDURE UltrasphericalEvalSum2 +END INTERFACE UltrasphericalEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Ultraspherical polynomials +! at point x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEvalSum1(n, lambda, x, & + & coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalGradientEvalSum1 +END INTERFACE + +INTERFACE UltrasphericalGradientEvalSum + MODULE PROCEDURE UltrasphericalGradientEvalSum1 +END INTERFACE UltrasphericalGradientEvalSum + +PUBLIC :: UltrasphericalGradientEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Ultraspherical polynomials +! at several x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEvalSum2(n, lambda, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalGradientEvalSum2 +END INTERFACE + +INTERFACE UltrasphericalGradientEvalSum + MODULE PROCEDURE UltrasphericalGradientEvalSum2 +END INTERFACE UltrasphericalGradientEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth derivative of finite sum of Ultraspherical +! polynomials at point x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEvalSum3(n, lambda, x, & + & coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! order of derivative + REAL(DFP) :: ans + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalGradientEvalSum3 +END INTERFACE + +INTERFACE UltrasphericalGradientEvalSum + MODULE PROCEDURE UltrasphericalGradientEvalSum3 +END INTERFACE UltrasphericalGradientEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth gradient of finite sum of Ultraspherical +! polynomials at several x + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientEvalSum4(n, lambda, x, & + & coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! lambda of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! kth order derivative + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Ultraspherical polynomial of order n at point x + END FUNCTION UltrasphericalGradientEvalSum4 +END INTERFACE + +INTERFACE UltrasphericalGradientEvalSum + MODULE PROCEDURE UltrasphericalGradientEvalSum4 +END INTERFACE UltrasphericalGradientEvalSum + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Ultraspherical Transform + +INTERFACE + MODULE PURE FUNCTION UltrasphericalTransform1(n, lambda, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION UltrasphericalTransform1 +END INTERFACE + +INTERFACE UltrasphericalTransform + MODULE PROCEDURE UltrasphericalTransform1 +END INTERFACE UltrasphericalTransform + +PUBLIC :: UltrasphericalTransform + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Ultraspherical Transform + +INTERFACE + MODULE PURE FUNCTION UltrasphericalTransform2(n, lambda, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION UltrasphericalTransform2 +END INTERFACE + +INTERFACE UltrasphericalTransform + MODULE PROCEDURE UltrasphericalTransform2 +END INTERFACE UltrasphericalTransform + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Ultraspherical Transform of a function on [-1,1] +! +!# Introduction +! +! This function performs the Ultraspherical transformation of f defined +! on -1 to 1. The interface of the function is give below: +! +!```fortran +! ABSTRACT INTERFACE +! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) +! IMPORT :: DFP +! REAL(DFP), INTENT(IN) :: x +! REAL(DFP) :: ans +! END FUNCTION iface_1DFunction +! END INTERFACE +!``` +! +!@note +! This routine is not pure, because this subroutine calls +! `UltrasphericalQuadrature` which is not pure due to Lapack call. +!@endnote + +INTERFACE + MODULE FUNCTION UltrasphericalTransform3(n, lambda, f, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION UltrasphericalTransform3 +END INTERFACE + +INTERFACE UltrasphericalTransform + MODULE PROCEDURE UltrasphericalTransform3 +END INTERFACE UltrasphericalTransform + +!---------------------------------------------------------------------------- +! UltrasphericalInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Ultraspherical Transform + +INTERFACE + MODULE PURE FUNCTION UltrasphericalInvTransform1(n, lambda, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x + !! x point in physical space + REAL(DFP) :: ans + !! value in physical space + END FUNCTION UltrasphericalInvTransform1 +END INTERFACE + +INTERFACE UltrasphericalInvTransform + MODULE PROCEDURE UltrasphericalInvTransform1 +END INTERFACE UltrasphericalInvTransform + +PUBLIC :: UltrasphericalInvTransform + +!---------------------------------------------------------------------------- +! UltrasphericalInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Ultraspherical Transform + +INTERFACE + MODULE PURE FUNCTION UltrasphericalInvTransform2(n, lambda, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x(:) + !! x point in physical space + REAL(DFP) :: ans(SIZE(x)) + !! value in physical space + END FUNCTION UltrasphericalInvTransform2 +END INTERFACE + +INTERFACE UltrasphericalInvTransform + MODULE PROCEDURE UltrasphericalInvTransform2 +END INTERFACE UltrasphericalInvTransform + +!---------------------------------------------------------------------------- +! UltrasphericalGradientCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficient for gradient of Ultraspherical expansion +! +!# Introduction +! +! This routine returns the coefficients of gradient of Jacobi expansion. +! Input is cofficients of Jacobipolynomials (modal values). +! + +INTERFACE + MODULE PURE FUNCTION UltrasphericalGradientCoeff1(n, lambda, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! coefficients $\tilde{u}_{n}$ obtained from UltrasphericalTransform + REAL(DFP) :: ans(0:n) + !! coefficient of gradient + END FUNCTION UltrasphericalGradientCoeff1 +END INTERFACE + +INTERFACE UltrasphericalGradientCoeff + MODULE PROCEDURE UltrasphericalGradientCoeff1 +END INTERFACE UltrasphericalGradientCoeff + +PUBLIC :: UltrasphericalGradientCoeff + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficient for gradient of Ultraspherical expansion +! +!# Introduction +! +! This routine returns the coefficients of gradient of Ultraspherical +! expansion. +! Input is cofficients of Ultrasphericalpolynomials (modal values). +! + +INTERFACE + MODULE PURE FUNCTION UltrasphericalDMatrix1(n, lambda, x, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP) :: ans(0:n, 0:n) + !! D matrix + END FUNCTION UltrasphericalDMatrix1 +END INTERFACE + +INTERFACE UltrasphericalDMatrix + MODULE PROCEDURE UltrasphericalDMatrix1 +END INTERFACE UltrasphericalDMatrix + +PUBLIC :: UltrasphericalDMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalDMatEvenOdd +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficient for gradient of Ultraspherical expansion +! +!# Introduction +! +! This routine returns the coefficients of gradient of Ultraspherical +! expansion. +! Input is cofficients of Ultrasphericalpolynomials (modal values). +! + +INTERFACE + MODULE PURE SUBROUTINE UltrasphericalDMatEvenOdd1(n, D, e, o) + INTEGER(I4B), INTENT(IN) :: n + !! order of Ultraspherical polynomial + REAL(DFP), INTENT(IN) :: D(0:n, 0:n) + !! n+1 by n+1 + REAL(DFP), INTENT(OUT) :: e(0:, 0:) + !! even Decomposition + REAL(DFP), INTENT(OUT) :: o(0:, 0:) + !! odd decomposition + END SUBROUTINE UltrasphericalDMatEvenOdd1 +END INTERFACE + +INTERFACE UltrasphericalDMatEvenOdd + MODULE PROCEDURE UltrasphericalDMatEvenOdd1 +END INTERFACE UltrasphericalDMatEvenOdd + +PUBLIC :: UltrasphericalDMatEvenOdd + +END MODULE UltrasphericalPolynomialUtility From 48248e4af6a0de1b2a093a86ab9ecebce18606d1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:46:18 +0900 Subject: [PATCH 35/43] undefined --- .../src/Chebyshev1PolynomialUtility.F90 | 995 +++++++++++++++++- .../src/HexahedronInterpolationUtility.F90 | 91 +- .../src/JacobiPolynomialUtility.F90 | 714 ++++++++++++- .../src/LegendrePolynomialUtility.F90 | 571 +++++++++- .../src/LineInterpolationUtility.F90 | 157 ++- .../src/OrthogonalPolynomialUtility.F90 | 96 +- .../Polynomial/src/PolynomialUtility.F90 | 3 +- .../src/PrismInterpolationUtility.F90 | 93 +- .../src/PyramidInterpolationUtility.F90 | 95 +- .../src/QuadrangleInterpolationUtility.F90 | 502 ++++++++- .../Polynomial/src/RecursiveNodesUtility.F90 | 11 +- .../src/TetrahedronInterpolationUtility.F90 | 94 +- .../src/TriangleInterpolationUtility.F90 | 338 +++++- 13 files changed, 3647 insertions(+), 113 deletions(-) diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 index 710be588c..514d3c626 100644 --- a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 @@ -17,8 +17,47 @@ MODULE Chebyshev1PolynomialUtility USE GlobalData +USE BaseType, ONLY: iface_1DFunction IMPLICIT NONE +!---------------------------------------------------------------------------- +! Chebyshev1Alpha +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, beta, of Chebyshev1 polynomial + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Alpha(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION Chebyshev1Alpha +END INTERFACE + +PUBLIC :: Chebyshev1Alpha + +!---------------------------------------------------------------------------- +! Chebyshev1Beta +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, beta, of Chebyshev1 polynomial + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Beta(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION Chebyshev1Beta +END INTERFACE + +PUBLIC :: Chebyshev1Beta + !---------------------------------------------------------------------------- ! GetChebyshev1RecurrenceCoeff !---------------------------------------------------------------------------- @@ -44,6 +83,34 @@ END SUBROUTINE GetChebyshev1RecurrenceCoeff PUBLIC :: GetChebyshev1RecurrenceCoeff +!---------------------------------------------------------------------------- +! GetChebyshev1RecurrenceCoeff2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Return the recurrence coefficient for nth order Chebyshev1 +! polynomial +! +! +!# Introduction +! +! These recurrence coefficients are for monic jacobi polynomials. + +INTERFACE + MODULE PURE SUBROUTINE GetChebyshev1RecurrenceCoeff2(n, A, B, C) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(OUT) :: A(0:n - 1) + !! size is n + REAL(DFP), INTENT(OUT) :: B(0:n - 1) + !! this coefficient is zero + REAL(DFP), INTENT(OUT) :: C(0:n - 1) + !! size is n + END SUBROUTINE GetChebyshev1RecurrenceCoeff2 +END INTERFACE + +PUBLIC :: GetChebyshev1RecurrenceCoeff2 + !---------------------------------------------------------------------------- ! Chebyshev1LeadingCoeff !---------------------------------------------------------------------------- @@ -64,7 +131,26 @@ END FUNCTION Chebyshev1LeadingCoeff PUBLIC :: Chebyshev1LeadingCoeff !---------------------------------------------------------------------------- -! +! Chebyshev1LeadingCoeffRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Ratio of leading coefficients, kn+1/kn + +INTERFACE + MODULE PURE FUNCTION Chebyshev1LeadingCoeffRatio(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION Chebyshev1LeadingCoeffRatio +END INTERFACE + +PUBLIC :: Chebyshev1LeadingCoeffRatio + +!---------------------------------------------------------------------------- +! Chebyshev1NormSQR !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -72,34 +158,122 @@ END FUNCTION Chebyshev1LeadingCoeff ! summary: Square norm of Chebyshev1 polynomial INTERFACE - MODULE PURE FUNCTION Chebyshev1NormSQR(n, alpha, beta) RESULT(ans) + MODULE PURE FUNCTION Chebyshev1NormSQR(n) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n - REAL(DFP), INTENT(IN) :: alpha - REAL(DFP), INTENT(IN) :: beta REAL(DFP) :: ans END FUNCTION Chebyshev1NormSQR END INTERFACE +PUBLIC :: Chebyshev1NormSQR + +!---------------------------------------------------------------------------- +! Chebyshev1NormSQR2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Square norm of Chebyshev1 polynomial + +INTERFACE + MODULE PURE FUNCTION Chebyshev1NormSQR2(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(0:n) + END FUNCTION Chebyshev1NormSQR2 +END INTERFACE + +PUBLIC :: Chebyshev1NormSQR2 + +!---------------------------------------------------------------------------- +! Chebyshev1NormSQRRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Ratio of Square norm of Chebyshev1 polynomial, n+1/n + +INTERFACE + MODULE PURE FUNCTION Chebyshev1NormSQRRatio(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans + END FUNCTION Chebyshev1NormSQRRatio +END INTERFACE + +PUBLIC :: Chebyshev1NormSQRRatio + +!---------------------------------------------------------------------------- +! Chebyshev1JacobiMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Return the Jacobi matrix for Chebyshev polynomial + +INTERFACE + MODULE PURE SUBROUTINE Chebyshev1JacobiMatrix(n, D, E, & + & alphaCoeff, betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + !! recurrence coefficient of monic Chebyshev polynomial, from 0 to n-1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + !! recurrence coefficient of monic Chebyshev polynomial, from 0 to n-1 + END SUBROUTINE Chebyshev1JacobiMatrix +END INTERFACE + +PUBLIC :: Chebyshev1JacobiMatrix + !---------------------------------------------------------------------------- ! Chebyshev1GaussQuadrature !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 3 Aug 2022 -! summary: Returns the Gauss quadrature points for Chebyshev1 Polynomial +! date: 10 Oct 2022 +! summary: Return the Jacobi matrix for Chebyshev polynomial INTERFACE MODULE SUBROUTINE Chebyshev1GaussQuadrature(n, pt, wt) INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev polynomial. REAL(DFP), INTENT(OUT) :: pt(:) !! the size is 1 to n - REAL(DFP), INTENT(OUT) :: wt(:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) !! the size is 1 to n END SUBROUTINE Chebyshev1GaussQuadrature END INTERFACE PUBLIC :: Chebyshev1GaussQuadrature +!---------------------------------------------------------------------------- +! Chebyshev1JacobiRadauMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Return the Jacobi-Radau matrix for Chebyshev polynomial + +INTERFACE + MODULE PURE SUBROUTINE Chebyshev1JacobiRadauMatrix(a, n, D, E, alphaCoeff, & + & betaCoeff) + REAL(DFP), INTENT(IN) :: a + !! one of the end of the domain + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial. + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+1 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE Chebyshev1JacobiRadauMatrix +END INTERFACE + +PUBLIC :: Chebyshev1JacobiRadauMatrix + !---------------------------------------------------------------------------- ! Chebyshev1GaussRadauQuadrature !---------------------------------------------------------------------------- @@ -109,34 +283,59 @@ END SUBROUTINE Chebyshev1GaussQuadrature ! summary: Returns the GaussRadau quadrature points for Chebyshev1 Polynomial INTERFACE - MODULE SUBROUTINE Chebyshev1GaussRadauQuadrature(n, a, pt, wt) - INTEGER(I4B), INTENT(IN) :: n + MODULE SUBROUTINE Chebyshev1GaussRadauQuadrature(a, n, pt, wt) REAL(DFP), INTENT(IN) :: a !! +1.0 or -1.0 + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev polynomial REAL(DFP), INTENT(OUT) :: pt(:) !! the size is 1 to n+1 - REAL(DFP), INTENT(OUT) :: wt(:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) !! the size is 1 to n+1 END SUBROUTINE Chebyshev1GaussRadauQuadrature END INTERFACE PUBLIC :: Chebyshev1GaussRadauQuadrature +!---------------------------------------------------------------------------- +! Chebyshev1JacobiLobattoMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 10 Oct 2022 +! summary: Return the Jacobi-Lobatto matrix for Chebyshev polynomial + +INTERFACE + MODULE PURE SUBROUTINE Chebyshev1JacobiLobattoMatrix(n, D, E, alphaCoeff, & + & betaCoeff) + INTEGER(I4B), INTENT(IN) :: n + !! n should be greater than or equal to 1 + REAL(DFP), INTENT(OUT) :: D(:) + !! the size should be 1:n+2 + REAL(DFP), INTENT(OUT) :: E(:) + !! the size should be 1:n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: alphaCoeff(0:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: betaCoeff(0:) + END SUBROUTINE Chebyshev1JacobiLobattoMatrix +END INTERFACE + +PUBLIC :: Chebyshev1JacobiLobattoMatrix + !---------------------------------------------------------------------------- ! Chebyshev1GaussLobattoQuadrature !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 3 Aug 2022 -! summary: Returns the GaussLobatto quadrature points for Chebyshev1 -! Polynomial +! summary:Returns the GaussLobatto quadrature points for Chebyshev1 Polynomial INTERFACE MODULE SUBROUTINE Chebyshev1GaussLobattoQuadrature(n, pt, wt) INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial REAL(DFP), INTENT(OUT) :: pt(:) !! the size is 1 to n+2 - REAL(DFP), INTENT(OUT) :: wt(:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) !! the size is 1 to n+2 END SUBROUTINE Chebyshev1GaussLobattoQuadrature END INTERFACE @@ -150,10 +349,780 @@ END SUBROUTINE Chebyshev1GaussLobattoQuadrature INTERFACE MODULE FUNCTION Chebyshev1Zeros(n) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev polynomial REAL(DFP) :: ans(n) END FUNCTION Chebyshev1Zeros END INTERFACE PUBLIC :: Chebyshev1Zeros +!---------------------------------------------------------------------------- +! Chebyshev1Quadrature +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: This routine can return Chebyshev-Gauss, Chebyshev-Radau, +! Chebyshev-Lobatto +! +!# Introduction +! +! This routine returns the Quadrature point of Chebyshev polynomial +! +!@note +! Here n is the number of quadrature points. Please note it is not +! the order of Chebyshev polynomial. The order is decided internally +! depending upon the quadType +!@endnote +! +!@note +! pt and wt should be allocated outside, and length should be n. +!@endnote +! + +INTERFACE + MODULE SUBROUTINE Chebyshev1Quadrature(n, pt, wt, quadType, onlyInside) + INTEGER(I4B), INTENT(IN) :: n + !! number of quadrature points, the order will be computed as follows + !! for quadType = Gauss, n is same as order of Chebyshev polynomial + !! for quadType = GaussRadauLeft or GaussRadauRight n is order+1 + !! for quadType = GaussLobatto, n = order+2 + REAL(DFP), INTENT(OUT) :: pt(n) + !! n+1 quadrature points from 1 to n+1 + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) + !! n+1 weights from 1 to n+1 + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss + !! GaussRadauLeft + !! GaussRadauRight + !! GaussLobatto + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: onlyInside + !! only inside + END SUBROUTINE Chebyshev1Quadrature +END INTERFACE + +PUBLIC :: Chebyshev1Quadrature + +!---------------------------------------------------------------------------- +! Chebyshev1Eval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Chebyshev1 polynomials of order = n at single x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Eval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + REAL(DFP) :: ans + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1Eval1 +END INTERFACE + +INTERFACE Chebyshev1Eval + MODULE PROCEDURE Chebyshev1Eval1 +END INTERFACE Chebyshev1Eval + +PUBLIC :: Chebyshev1Eval + +!---------------------------------------------------------------------------- +! Chebyshev1Eval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Chebyshev1 polynomials of order n at several points + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Eval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! several points of evaluation + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1Eval2 +END INTERFACE + +INTERFACE Chebyshev1Eval + MODULE PROCEDURE Chebyshev1Eval2 +END INTERFACE Chebyshev1Eval + +!---------------------------------------------------------------------------- +! Chebyshev1EvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Chebyshev1 polynomials from order = 0 to n at single point +! +!# Introduction +! +! Evaluate Chebyshev1 polynomials from order = 0 to n at single point +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- x: the point at which the polynomials are to be evaluated. +!- ans(1:N+1), the values of the first N+1 Chebyshev1 polynomials at the +! point + +INTERFACE + MODULE PURE FUNCTION Chebyshev1EvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point of evaluation + REAL(DFP) :: ans(n + 1) + !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION Chebyshev1EvalAll1 +END INTERFACE + +INTERFACE Chebyshev1EvalAll + MODULE PROCEDURE Chebyshev1EvalAll1 +END INTERFACE Chebyshev1EvalAll + +PUBLIC :: Chebyshev1EvalAll + +!---------------------------------------------------------------------------- +! Chebyshev1EvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Chebyshev1 polynomials from order = 0 to n at several +! points +! +!# Introduction +! +! Evaluate Chebyshev1 polynomials from order = 0 to n at several points +! +!- N, the highest order polynomial to compute. Note that polynomials 0 +! through N will be computed. +!- x: the points at which the polynomials are to be evaluated. +!- ans(M,1:N+1), the values of the first N+1 Chebyshev1 polynomials at the +! points x(1:m) + +INTERFACE + MODULE PURE FUNCTION Chebyshev1EvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! several points of evaluation + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1) + !! at points x + END FUNCTION Chebyshev1EvalAll2 +END INTERFACE + +INTERFACE Chebyshev1EvalAll + MODULE PROCEDURE Chebyshev1EvalAll2 +END INTERFACE Chebyshev1EvalAll + +!---------------------------------------------------------------------------- +! Chebyshev1MonomialExpansionAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of all Chebyshev1 polynomials +! +!# Introduction +! +! Returns all the monomial expansion of all Chebyshev1 polynomials +! +!- n : is the order of the polynomial +!- ans(:,i) contains the coefficient of monomials for polynomial order=i-1 +! +! for example, n=5, we have following structure of ans +! +! | P0 | P1 | P2 | P3 | P4 | P5 | +! |----|----|----|----|----|-----| +! | 1 | 0 | -1 | -0 | 1 | 0 | +! | 0 | 1 | 0 | -3 | -0 | 5 | +! | 0 | 0 | 2 | 0 | -8 | -0 | +! | 0 | 0 | 0 | 4 | 0 | -20 | +! | 0 | 0 | 0 | 0 | 8 | 0 | +! | 0 | 0 | 0 | 0 | 0 | 16 | + +INTERFACE + MODULE PURE FUNCTION Chebyshev1MonomialExpansionAll(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1, 1:n + 1) + END FUNCTION Chebyshev1MonomialExpansionAll +END INTERFACE + +PUBLIC :: Chebyshev1MonomialExpansionAll + +!---------------------------------------------------------------------------- +! Chebyshev1MonomialExpansion +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Returns the monomial expansion of a Chebyshev1 polynomials +! +!# Introduction +! +! Returns all the monomial expansion of a Chebyshev1 polynomials +! +!- n : is the order of the polynomial +!- ans(:) contains the coefficient of monomials for polynomial order=n +! + +INTERFACE + MODULE PURE FUNCTION Chebyshev1MonomialExpansion(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(1:n + 1) + END FUNCTION Chebyshev1MonomialExpansion +END INTERFACE + +PUBLIC :: Chebyshev1MonomialExpansion + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Chebyshev1 polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans(1:n + 1) + END FUNCTION Chebyshev1GradientEvalAll1 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalAll + MODULE PROCEDURE Chebyshev1GradientEvalAll1 +END INTERFACE Chebyshev1GradientEvalAll + +PUBLIC :: Chebyshev1GradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Chebyshev1 polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalAll2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 1:n + 1) + END FUNCTION Chebyshev1GradientEvalAll2 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalAll + MODULE PROCEDURE Chebyshev1GradientEvalAll2 +END INTERFACE Chebyshev1GradientEvalAll + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Chebyshev1 polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEval1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x + REAL(DFP) :: ans + END FUNCTION Chebyshev1GradientEval1 +END INTERFACE +!! + +INTERFACE Chebyshev1GradientEval + MODULE PROCEDURE Chebyshev1GradientEval1 +END INTERFACE Chebyshev1GradientEval + +PUBLIC :: Chebyshev1GradientEval + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n +! +!# Introduction +! +! Evaluate gradient of Chebyshev1 polynomial of order upto n. + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEval2(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x)) + END FUNCTION Chebyshev1GradientEval2 +END INTERFACE + +INTERFACE Chebyshev1GradientEval + MODULE PROCEDURE Chebyshev1GradientEval2 +END INTERFACE Chebyshev1GradientEval + +!---------------------------------------------------------------------------- +! Chebyshev1EvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Chebyshev1 polynomials at point x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1EvalSum1(n, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1EvalSum1 +END INTERFACE + +INTERFACE Chebyshev1EvalSum + MODULE PROCEDURE Chebyshev1EvalSum1 +END INTERFACE Chebyshev1EvalSum + +PUBLIC :: Chebyshev1EvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1EvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Chebyshev1 polynomials at several x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1EvalSum2(n, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1EvalSum2 +END INTERFACE + +INTERFACE Chebyshev1EvalSum + MODULE PROCEDURE Chebyshev1EvalSum2 +END INTERFACE Chebyshev1EvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Chebyshev1 polynomials +! at point x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalSum1(n, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1GradientEvalSum1 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalSum + MODULE PROCEDURE Chebyshev1GradientEvalSum1 +END INTERFACE Chebyshev1GradientEvalSum + +PUBLIC :: Chebyshev1GradientEvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Chebyshev1 polynomials +! at several x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalSum2(n, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1GradientEvalSum2 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalSum + MODULE PROCEDURE Chebyshev1GradientEvalSum2 +END INTERFACE Chebyshev1GradientEvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth derivative of finite sum of Chebyshev1 +! polynomials at point x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalSum3(n, x, coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! order of derivative + REAL(DFP) :: ans + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1GradientEvalSum3 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalSum + MODULE PROCEDURE Chebyshev1GradientEvalSum3 +END INTERFACE Chebyshev1GradientEvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth gradient of finite sum of Chebyshev1 +! polynomials at several x + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientEvalSum4(n, x, coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! kth order derivative + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Chebyshev1 polynomial of order n at point x + END FUNCTION Chebyshev1GradientEvalSum4 +END INTERFACE + +INTERFACE Chebyshev1GradientEvalSum + MODULE PROCEDURE Chebyshev1GradientEvalSum4 +END INTERFACE Chebyshev1GradientEvalSum + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Chebyshev1 Transform + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Transform1(n, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION Chebyshev1Transform1 +END INTERFACE + +INTERFACE Chebyshev1Transform + MODULE PROCEDURE Chebyshev1Transform1 +END INTERFACE Chebyshev1Transform + +PUBLIC :: Chebyshev1Transform + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Chebyshev1 Transform + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION Chebyshev1Transform2 +END INTERFACE + +INTERFACE Chebyshev1Transform + MODULE PROCEDURE Chebyshev1Transform2 +END INTERFACE Chebyshev1Transform + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Chebyshev1 Transform of a function on [-1,1] +! +!# Introduction +! +! This function performs the Chebyshev1 transformation of f defined +! on -1 to 1. The interface of the function is give below: +! +!```fortran +! ABSTRACT INTERFACE +! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) +! IMPORT :: DFP +! REAL(DFP), INTENT(IN) :: x +! REAL(DFP) :: ans +! END FUNCTION iface_1DFunction +! END INTERFACE +!``` +! +!@note +! This routine is not pure, because this subroutine calls +! `Chebyshev1Quadrature` which is not pure due to Lapack call. +!@endnote + +INTERFACE + MODULE FUNCTION Chebyshev1Transform3(n, f, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION Chebyshev1Transform3 +END INTERFACE + +INTERFACE Chebyshev1Transform + MODULE PROCEDURE Chebyshev1Transform3 +END INTERFACE Chebyshev1Transform + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Chebyshev1 Transform +! +!# Introduction +! Discrete Chebyshev transform. We calculate weights and quadrature points +! internally. + +INTERFACE + MODULE PURE FUNCTION Chebyshev1Transform4(n, coeff, quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION Chebyshev1Transform4 +END INTERFACE + +!---------------------------------------------------------------------------- +! Chebyshev1InvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Inverse Chebyshev1 Transform + +INTERFACE + MODULE PURE FUNCTION Chebyshev1InvTransform1(n, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x + !! x point in physical space + REAL(DFP) :: ans + !! value in physical space + END FUNCTION Chebyshev1InvTransform1 +END INTERFACE + +INTERFACE Chebyshev1InvTransform + MODULE PROCEDURE Chebyshev1InvTransform1 +END INTERFACE Chebyshev1InvTransform + +PUBLIC :: Chebyshev1InvTransform + +!---------------------------------------------------------------------------- +! Chebyshev1InvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Inverse Chebyshev1 Transform + +INTERFACE + MODULE PURE FUNCTION Chebyshev1InvTransform2(n, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x(:) + !! x point in physical space + REAL(DFP) :: ans(SIZE(x)) + !! value in physical space + END FUNCTION Chebyshev1InvTransform2 +END INTERFACE + +INTERFACE Chebyshev1InvTransform + MODULE PROCEDURE Chebyshev1InvTransform2 +END INTERFACE Chebyshev1InvTransform + +!---------------------------------------------------------------------------- +! Chebyshev1GradientCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficients for gradient of Chebyshev1 expansion +! +!# Introduction +! +!- This routine returns the coefficients of gradient of Jacobi expansion. +!- Input is coefficient of Chebyshev1 expansion (modal values) +!- Output is coefficient of derivative of Chebyshev1 expansion (modal values) + +INTERFACE + MODULE PURE FUNCTION Chebyshev1GradientCoeff1(n, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! coefficients $\tilde{u}_{n}$ obtained from Chebyshev1Transform + REAL(DFP) :: ans(0:n) + !! coefficient of gradient + END FUNCTION Chebyshev1GradientCoeff1 +END INTERFACE + +INTERFACE Chebyshev1GradientCoeff + MODULE PROCEDURE Chebyshev1GradientCoeff1 +END INTERFACE Chebyshev1GradientCoeff + +PUBLIC :: Chebyshev1GradientCoeff + +!---------------------------------------------------------------------------- +! Chebyshev1DMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 Oct 2022 +! summary: Returns differentiation matrix for Chebyshev1 expansion + +INTERFACE + MODULE PURE FUNCTION Chebyshev1DMatrix1(n, x, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP) :: ans(0:n, 0:n) + !! D matrix + END FUNCTION Chebyshev1DMatrix1 +END INTERFACE + +INTERFACE Chebyshev1DMatrix + MODULE PROCEDURE Chebyshev1DMatrix1 +END INTERFACE Chebyshev1DMatrix + +PUBLIC :: Chebyshev1DMatrix + +!---------------------------------------------------------------------------- +! Chebyshev1DMatEvenOdd +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 Oct 2022 +! summary: Performs even and odd decomposition of Differential matrix + +INTERFACE + MODULE PURE SUBROUTINE Chebyshev1DMatEvenOdd1(n, D, e, o) + INTEGER(I4B), INTENT(IN) :: n + !! order of Chebyshev1 polynomial + REAL(DFP), INTENT(IN) :: D(0:n, 0:n) + !! n+1 by n+1 + REAL(DFP), INTENT(OUT) :: e(0:, 0:) + !! even Decomposition, 0:n/2, 0:n/2 + REAL(DFP), INTENT(OUT) :: o(0:, 0:) + !! odd decomposition, 0:n/2, 0:n/2 + END SUBROUTINE Chebyshev1DMatEvenOdd1 +END INTERFACE + +INTERFACE Chebyshev1DMatEvenOdd + MODULE PROCEDURE Chebyshev1DMatEvenOdd1 +END INTERFACE Chebyshev1DMatEvenOdd + +PUBLIC :: Chebyshev1DMatEvenOdd + END MODULE Chebyshev1PolynomialUtility diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 index 2ae33bace..0bc69796a 100644 --- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 @@ -149,10 +149,12 @@ END FUNCTION EquidistancePoint_Hexahedron ! summary: Interpolation point INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Hexahedron(order, ipType, xij) & + MODULE PURE FUNCTION InterpolationPoint_Hexahedron(order, ipType, & + & layout, xij) & & RESULT(nodecoord) INTEGER(I4B), INTENT(IN) :: order INTEGER(I4B), INTENT(IN) :: ipType + CHARACTER(LEN=*), INTENT(IN) :: layout REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) REAL(DFP), ALLOCATABLE :: nodecoord(:, :) END FUNCTION InterpolationPoint_Hexahedron @@ -161,7 +163,92 @@ END FUNCTION InterpolationPoint_Hexahedron PUBLIC :: InterpolationPoint_Hexahedron !---------------------------------------------------------------------------- -! +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Hexahedron1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Hexahedron1 +END INTERFACE + +INTERFACE LagrangeCoeff_Hexahedron + MODULE PROCEDURE LagrangeCoeff_Hexahedron1 +END INTERFACE LagrangeCoeff_Hexahedron + +PUBLIC :: LagrangeCoeff_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Hexahedron2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Hexahedron2 +END INTERFACE + +INTERFACE LagrangeCoeff_Hexahedron + MODULE PROCEDURE LagrangeCoeff_Hexahedron2 +END INTERFACE LagrangeCoeff_Hexahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Hexahedron3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Hexahedron3 +END INTERFACE + +INTERFACE LagrangeCoeff_Hexahedron + MODULE PROCEDURE LagrangeCoeff_Hexahedron3 +END INTERFACE LagrangeCoeff_Hexahedron + !---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Hexahedron4(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Hexahedron4 +END INTERFACE + +INTERFACE LagrangeCoeff_Hexahedron + MODULE PROCEDURE LagrangeCoeff_Hexahedron4 +END INTERFACE LagrangeCoeff_Hexahedron END MODULE HexahedronInterpolationUtility diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 index cd9551c1f..301d891ec 100644 --- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 @@ -23,6 +23,7 @@ MODULE JacobiPolynomialUtility USE GlobalData +USE BaseType, ONLY: iface_1DFunction IMPLICIT NONE PRIVATE @@ -32,7 +33,7 @@ MODULE JacobiPolynomialUtility !> author: Vikas Sharma, Ph. D. ! date: 2 Aug 2022 -! summary: Return the recurrence coefficient for nth order polynomial +! summary: Return the recurrence coefficient for nth order monic polynomial ! !# Introduction ! @@ -52,6 +53,84 @@ END SUBROUTINE GetJacobiRecurrenceCoeff PUBLIC :: GetJacobiRecurrenceCoeff +!---------------------------------------------------------------------------- +! GetJacobiRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Return the recurrence coefficient for nth order polynomial +! +!# Introduction +! +! These recurrence coefficients are for non-monic jacobi polynomials. +! +!$$ +! P_{n+1}^{(\alpha,\beta)}=\left(a_{n}x+b_{n}\right)P_{n}^{(\alpha,\beta)} +! -c_{n}P_{n-1}^{(\alpha,\beta)},\quad n=1,2,\cdots +!$$ + +INTERFACE + MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff2(n, alpha, beta, & + & A, B, C) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial, it should be greater than 1 + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(OUT) :: A(0:n - 1) + REAL(DFP), INTENT(OUT) :: B(0:n - 1) + REAL(DFP), INTENT(OUT) :: C(0:n - 1) + END SUBROUTINE GetJacobiRecurrenceCoeff2 +END INTERFACE + +PUBLIC :: GetJacobiRecurrenceCoeff2 + +!---------------------------------------------------------------------------- +! JacobiAlpha +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Returns reccurence coeff alpha + +INTERFACE + MODULE ELEMENTAL PURE FUNCTION JacobiAlpha(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha in Jacobi poly + REAL(DFP), INTENT(IN) :: beta + !! beta in Jacobi poly + REAL(DFP) :: ans + !! answer + END FUNCTION JacobiAlpha +END INTERFACE + +PUBLIC :: JacobiAlpha + +!---------------------------------------------------------------------------- +! JacobiBeta +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Returns reccurence coeff beta + +INTERFACE + MODULE ELEMENTAL PURE FUNCTION JacobiBeta(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha in Jacobi poly + REAL(DFP), INTENT(IN) :: beta + !! beta in Jacobi poly + REAL(DFP) :: ans + !! answer + END FUNCTION JacobiBeta +END INTERFACE + +PUBLIC :: JacobiBeta + !---------------------------------------------------------------------------- ! JacobiLeadingCoeff !---------------------------------------------------------------------------- @@ -76,7 +155,30 @@ END FUNCTION JacobiLeadingCoeff PUBLIC :: JacobiLeadingCoeff !---------------------------------------------------------------------------- -! +! JacobiLeadingCoeffRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Leading coefficient ratio of Jacobi polynomial, n+1/n + +INTERFACE + MODULE PURE FUNCTION JacobiLeadingCoeffRatio(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha in Jacobi poly + REAL(DFP), INTENT(IN) :: beta + !! beta in Jacobi poly + REAL(DFP) :: ans + !! answer + END FUNCTION JacobiLeadingCoeffRatio +END INTERFACE + +PUBLIC :: JacobiLeadingCoeffRatio + +!---------------------------------------------------------------------------- +! JacobiNormSQR !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -101,6 +203,55 @@ MODULE PURE FUNCTION JacobiNormSQR(n, alpha, beta) RESULT(ans) END FUNCTION JacobiNormSQR END INTERFACE +PUBLIC :: JacobiNormSQR + +!---------------------------------------------------------------------------- +! JacobiNormSQR2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Square norm of Jacobi polynomial +! +!# Introduction +! +! This function returns the following +! +!$$ +!\Vert P_{n}^{\alpha,\beta}\Vert_{d\lambda}^{2}=\int_{-1}^{+1}P_{n}^ +!{\alpha,\beta}P_{n}^{\alpha,\beta}(1-x)^{\alpha}(1+x)^{\beta}dx +!$$ + +INTERFACE + MODULE PURE FUNCTION JacobiNormSQR2(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans(0:n) + END FUNCTION JacobiNormSQR2 +END INTERFACE + +PUBLIC :: JacobiNormSQR2 + +!---------------------------------------------------------------------------- +! JacobiNormSQRRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Aug 2022 +! summary: Ratio of Square norm of Jacobi polynomial n+1/n + +INTERFACE + MODULE PURE FUNCTION JacobiNormSQRRatio(n, alpha, beta) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP) :: ans + END FUNCTION JacobiNormSQRRatio +END INTERFACE + +PUBLIC :: JacobiNormSQRRatio + !---------------------------------------------------------------------------- ! JacobiJacobiMatrix !---------------------------------------------------------------------------- @@ -149,7 +300,7 @@ MODULE SUBROUTINE JacobiGaussQuadrature(n, alpha, beta, pt, wt) REAL(DFP), INTENT(IN) :: beta REAL(DFP), INTENT(OUT) :: pt(:) !! the size is 1 to n - REAL(DFP), INTENT(OUT) :: wt(:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) !! the size is 1 to n END SUBROUTINE JacobiGaussQuadrature END INTERFACE @@ -220,7 +371,7 @@ MODULE SUBROUTINE JacobiGaussRadauQuadrature(a, n, alpha, beta, pt, wt) !! beta of Jacobi polynomial REAL(DFP), INTENT(OUT) :: pt(:) !! n+1 quadrature points from 1 to n+1 - REAL(DFP), INTENT(OUT) :: wt(:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) !! n+1 weights from 1 to n+1 END SUBROUTINE JacobiGaussRadauQuadrature END INTERFACE @@ -285,7 +436,7 @@ MODULE SUBROUTINE JacobiGaussLobattoQuadrature(n, alpha, beta, pt, wt) REAL(DFP), INTENT(IN) :: beta REAL(DFP), INTENT(OUT) :: pt(:) !! n+2 quad points indexed from 1 to n+2 - REAL(DFP), INTENT(OUT) :: wt(:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) !! n+2 weights, index from 1 to n+2 END SUBROUTINE JacobiGaussLobattoQuadrature END INTERFACE @@ -348,7 +499,7 @@ MODULE SUBROUTINE JacobiQuadrature(n, alpha, beta, pt, wt, quadType) !! beta of Jacobi polynomial REAL(DFP), INTENT(OUT) :: pt(n) !! n+1 quadrature points from 1 to n+1 - REAL(DFP), INTENT(OUT) :: wt(n) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) !! n+1 weights from 1 to n+1 INTEGER(I4B), INTENT(IN) :: quadType !! Gauss @@ -502,4 +653,555 @@ END FUNCTION JacobiEval2 MODULE PROCEDURE JacobiEval2 END INTERFACE JacobiEval +!---------------------------------------------------------------------------- +! JacobiEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Jacobi polynomials at point x + +INTERFACE + MODULE PURE FUNCTION JacobiEvalSum1(n, alpha, beta, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiEvalSum1 +END INTERFACE + +INTERFACE JacobiEvalSum + MODULE PROCEDURE JacobiEvalSum1 +END INTERFACE JacobiEvalSum + +PUBLIC :: JacobiEvalSum + +!---------------------------------------------------------------------------- +! JacobiEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Jacobi polynomials at several x + +INTERFACE + MODULE PURE FUNCTION JacobiEvalSum2(n, alpha, beta, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiEvalSum2 +END INTERFACE + +INTERFACE JacobiEvalSum + MODULE PROCEDURE JacobiEvalSum2 +END INTERFACE JacobiEvalSum + +!---------------------------------------------------------------------------- +! JacobiGradientEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Oct 2022 +! summary: Evaluate Gradient of Jacobi polynomial + +INTERFACE + MODULE PURE FUNCTION JacobiGradientEval1(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP) :: ans + !! Derivative of Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEval1 +END INTERFACE + +INTERFACE JacobiGradientEval + MODULE PROCEDURE JacobiGradientEval1 +END INTERFACE JacobiGradientEval + +PUBLIC :: JacobiGradientEval + +!---------------------------------------------------------------------------- +! JacobiGradientEval +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Oct 2022 +! summary: Evaluate Gradient of Jacobi polynomial + +INTERFACE + MODULE PURE FUNCTION JacobiGradientEval2(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x)) + !! Derivative of Jacobi polynomial of order n at x + END FUNCTION JacobiGradientEval2 +END INTERFACE + +INTERFACE JacobiGradientEval + MODULE PROCEDURE JacobiGradientEval2 +END INTERFACE JacobiGradientEval + +!---------------------------------------------------------------------------- +! JacobiGradientEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Oct 2022 +! summary: Evaluate Gradient of Jacobi polynomial + +INTERFACE + MODULE PURE FUNCTION JacobiGradientEvalAll1(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP) :: ans(n + 1) + !! Derivative of Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEvalAll1 +END INTERFACE + +INTERFACE JacobiGradientEvalAll + MODULE PROCEDURE JacobiGradientEvalAll1 +END INTERFACE JacobiGradientEvalAll + +PUBLIC :: JacobiGradientEvalAll + +!---------------------------------------------------------------------------- +! JacobiGradientEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 14 Oct 2022 +! summary: Evaluate Gradient of Jacobi polynomial + +INTERFACE + MODULE PURE FUNCTION JacobiGradientEvalAll2(n, alpha, beta, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP), INTENT(IN) :: alpha + REAL(DFP), INTENT(IN) :: beta + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(SIZE(x), n + 1) + !! Derivative of Jacobi polynomial of order n at x + END FUNCTION JacobiGradientEvalAll2 +END INTERFACE + +INTERFACE JacobiGradientEvalAll + MODULE PROCEDURE JacobiGradientEvalAll2 +END INTERFACE JacobiGradientEvalAll + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Jacobi polynomials at +! point x + +INTERFACE + MODULE PURE FUNCTION JacobiGradientEvalSum1(n, alpha, beta, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEvalSum1 +END INTERFACE + +INTERFACE JacobiGradientEvalSum + MODULE PROCEDURE JacobiGradientEvalSum1 +END INTERFACE JacobiGradientEvalSum + +PUBLIC :: JacobiGradientEvalSum + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Jacobi polynomials at +! several x + +INTERFACE + MODULE PURE FUNCTION JacobiGradientEvalSum2(n, alpha, beta, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEvalSum2 +END INTERFACE + +INTERFACE JacobiGradientEvalSum + MODULE PROCEDURE JacobiGradientEvalSum2 +END INTERFACE JacobiGradientEvalSum + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth derivative of finite sum of Jacobi polynomials at +! point x + +INTERFACE + MODULE PURE FUNCTION JacobiGradientEvalSum3(n, alpha, beta, x, coeff, k) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! order of derivative + REAL(DFP) :: ans + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEvalSum3 +END INTERFACE + +INTERFACE JacobiGradientEvalSum + MODULE PROCEDURE JacobiGradientEvalSum3 +END INTERFACE JacobiGradientEvalSum + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth gradient of finite sum of Jacobi polynomials at +! several x + +INTERFACE + MODULE PURE FUNCTION JacobiGradientEvalSum4(n, alpha, beta, x, coeff, k) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi Polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! kth order derivative + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Jacobi polynomial of order n at point x + END FUNCTION JacobiGradientEvalSum4 +END INTERFACE + +INTERFACE JacobiGradientEvalSum + MODULE PROCEDURE JacobiGradientEvalSum4 +END INTERFACE JacobiGradientEvalSum + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Jacobi Transform + +INTERFACE + MODULE PURE FUNCTION JacobiTransform1(n, alpha, beta, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION JacobiTransform1 +END INTERFACE + +INTERFACE JacobiTransform + MODULE PROCEDURE JacobiTransform1 +END INTERFACE JacobiTransform + +PUBLIC :: JacobiTransform + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Jacobi Transform + +INTERFACE + MODULE PURE FUNCTION JacobiTransform2(n, alpha, beta, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION JacobiTransform2 +END INTERFACE + +INTERFACE JacobiTransform + MODULE PROCEDURE JacobiTransform2 +END INTERFACE JacobiTransform + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Jacobi Transform of a function on [-1,1] +! +!# Introduction +! +! This function performs the jacobi transformation of a function defined +! on -1 to 1. The interface of the function is give below: +! +!```fortran +! ABSTRACT INTERFACE +! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) +! IMPORT :: DFP +! REAL(DFP), INTENT(IN) :: x +! REAL(DFP) :: ans +! END FUNCTION iface_1DFunction +! END INTERFACE +!``` +! +!@note +! This routine is not pure, because this subroutine calls `JacobiQuadrature` +! which is not pure due to Lapack call. +!@endnote + +INTERFACE + MODULE FUNCTION JacobiTransform3(n, alpha, beta, f, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION JacobiTransform3 +END INTERFACE + +INTERFACE JacobiTransform + MODULE PROCEDURE JacobiTransform3 +END INTERFACE JacobiTransform + +!---------------------------------------------------------------------------- +! JacobiInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Jacobi Transform + +INTERFACE + MODULE PURE FUNCTION JacobiInvTransform1(n, alpha, beta, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x + !! x point in physical space + REAL(DFP) :: ans + !! value in physical space + END FUNCTION JacobiInvTransform1 +END INTERFACE + +INTERFACE JacobiInvTransform + MODULE PROCEDURE JacobiInvTransform1 +END INTERFACE JacobiInvTransform + +PUBLIC :: JacobiInvTransform + +!---------------------------------------------------------------------------- +! JacobiInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Jacobi Transform + +INTERFACE + MODULE PURE FUNCTION JacobiInvTransform2(n, alpha, beta, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: beta + !! beta of Jacobi polynomial > -1.0_DFP + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x(:) + !! x point in physical space + REAL(DFP) :: ans(SIZE(x)) + !! value in physical space + END FUNCTION JacobiInvTransform2 +END INTERFACE + +INTERFACE JacobiInvTransform + MODULE PROCEDURE JacobiInvTransform2 +END INTERFACE JacobiInvTransform + +!---------------------------------------------------------------------------- +! JacobiGradientCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficient for gradient of Jacobi expansion +! +!# Introduction +! +! This routine returns the coefficients of gradient of Jacobi expansion. +! Input is cofficients of Jacobipolynomials (modal values). +! + +INTERFACE + MODULE PURE FUNCTION JacobiGradientCoeff1(n, alpha, beta, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! coefficients $\tilde{u}_{n}$ obtained from JacobiTransform + REAL(DFP) :: ans(0:n) + !! coefficient of gradient + END FUNCTION JacobiGradientCoeff1 +END INTERFACE + +INTERFACE JacobiGradientCoeff + MODULE PROCEDURE JacobiGradientCoeff1 +END INTERFACE JacobiGradientCoeff + +PUBLIC :: JacobiGradientCoeff + +!---------------------------------------------------------------------------- +! JacobiDMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficient for gradient of Jacobi expansion +! +!# Introduction +! +! This routine returns the coefficients of gradient of Jacobi expansion. +! Input is cofficients of Jacobipolynomials (modal values). +! + +INTERFACE + MODULE PURE FUNCTION JacobiDMatrix1(n, alpha, beta, x, quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP) :: ans(0:n, 0:n) + !! D matrix + END FUNCTION JacobiDMatrix1 +END INTERFACE + +INTERFACE JacobiDMatrix + MODULE PROCEDURE JacobiDMatrix1 +END INTERFACE JacobiDMatrix + +PUBLIC :: JacobiDMatrix + END MODULE JacobiPolynomialUtility diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 index ea8dca7d9..15d21f2d8 100644 --- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 @@ -23,16 +23,55 @@ MODULE LegendrePolynomialUtility USE GlobalData +USE BaseType, ONLY: iface_1DFunction IMPLICIT NONE PRIVATE +!---------------------------------------------------------------------------- +! LegendreAlpha +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, alpha, of Legendre polynomial + +INTERFACE + MODULE PURE FUNCTION LegendreAlpha(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION LegendreAlpha +END INTERFACE + +PUBLIC :: LegendreAlpha + +!---------------------------------------------------------------------------- +! LegendreBeta +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Recurrence coefficient, beta, of Legendre polynomial + +INTERFACE + MODULE PURE FUNCTION LegendreBeta(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION LegendreBeta +END INTERFACE + +PUBLIC :: LegendreBeta + !---------------------------------------------------------------------------- ! GetLegendreRecurrenceCoeff !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 8 Sept 2022 -! summary: Return the recurrence coefficient for nth order polynomial +! summary: Return the recurrence coefficient for monic Legendre polynomial ! !# Introduction ! @@ -65,6 +104,29 @@ END SUBROUTINE GetLegendreRecurrenceCoeff PUBLIC :: GetLegendreRecurrenceCoeff +!---------------------------------------------------------------------------- +! GetLegendreRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Return the recurrence coefficient for Legendre polynomial + +INTERFACE + MODULE PURE SUBROUTINE GetLegendreRecurrenceCoeff2(n, A, B, C) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial, it should be greater than 1 + REAL(DFP), INTENT(OUT) :: A(0:n - 1) + !! size is n + REAL(DFP), INTENT(OUT) :: B(0:n - 1) + !! this coefficient is zero + REAL(DFP), INTENT(OUT) :: C(0:n - 1) + !! size is n + END SUBROUTINE GetLegendreRecurrenceCoeff2 +END INTERFACE + +PUBLIC :: GetLegendreRecurrenceCoeff2 + !---------------------------------------------------------------------------- ! LegendreLeadingCoeff !---------------------------------------------------------------------------- @@ -94,7 +156,26 @@ END FUNCTION LegendreLeadingCoeff PUBLIC :: LegendreLeadingCoeff !---------------------------------------------------------------------------- -! +! LegendreLeadingCoeffRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Ration of Leading coefficient of Legendre polynomial n+1/n + +INTERFACE + MODULE PURE FUNCTION LegendreLeadingCoeffRatio(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP) :: ans + !! answer + END FUNCTION LegendreLeadingCoeffRatio +END INTERFACE + +PUBLIC :: LegendreLeadingCoeffRatio + +!---------------------------------------------------------------------------- +! LegendreNormSQR !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -116,8 +197,52 @@ MODULE PURE FUNCTION LegendreNormSQR(n) RESULT(ans) END FUNCTION LegendreNormSQR END INTERFACE +PUBLIC :: LegendreNormSQR + +!---------------------------------------------------------------------------- +! LegendreNormSQR2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Square norm of Legendre polynomial +! +!# Introduction +! +! This function returns the square norm of legendre polynomial +! +!$$ +! \Vert P_{n}\Vert^{2}=:h_{n}=\frac{2}{2n+1} +!$$ + +INTERFACE + MODULE PURE FUNCTION LegendreNormSQR2(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans(0:n) + END FUNCTION LegendreNormSQR2 +END INTERFACE + +PUBLIC :: LegendreNormSQR2 + +!---------------------------------------------------------------------------- +! LegendreNormSQRRatio +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 8 Sept 2022 +! summary: Ratio of Square norm of Legendre polynomial n+1/n + +INTERFACE + MODULE PURE FUNCTION LegendreNormSQRRatio(n) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + REAL(DFP) :: ans + END FUNCTION LegendreNormSQRRatio +END INTERFACE + +PUBLIC :: LegendreNormSqrRatio + !---------------------------------------------------------------------------- -! LegendreJacobiMatrix +! LegendreJacobiMatrix !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -163,7 +288,7 @@ MODULE SUBROUTINE LegendreGaussQuadrature(n, pt, wt) !! It represents the order of Legendre polynomial REAL(DFP), INTENT(OUT) :: pt(:) !! the size is 1 to n - REAL(DFP), INTENT(OUT) :: wt(:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) !! the size is 1 to n END SUBROUTINE LegendreGaussQuadrature END INTERFACE @@ -226,7 +351,7 @@ MODULE SUBROUTINE LegendreGaussRadauQuadrature(a, n, pt, wt) !! order of Legendre polynomial REAL(DFP), INTENT(OUT) :: pt(:) !! n+1 quadrature points from 1 to n+1 - REAL(DFP), INTENT(OUT) :: wt(:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) !! n+1 weights from 1 to n+1 END SUBROUTINE LegendreGaussRadauQuadrature END INTERFACE @@ -285,7 +410,7 @@ MODULE SUBROUTINE LegendreGaussLobattoQuadrature(n, pt, wt) !! order of Legendre polynomials REAL(DFP), INTENT(OUT) :: pt(:) !! n+2 quad points indexed from 1 to n+2 - REAL(DFP), INTENT(OUT) :: wt(:) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(:) !! n+2 weights, index from 1 to n+2 END SUBROUTINE LegendreGaussLobattoQuadrature END INTERFACE @@ -343,7 +468,7 @@ MODULE SUBROUTINE LegendreQuadrature(n, pt, wt, quadType, onlyInside) !! for quadType = GaussLobatto, n = order+2 REAL(DFP), INTENT(OUT) :: pt(n) !! n+1 quadrature points from 1 to n+1 - REAL(DFP), INTENT(OUT) :: wt(n) + REAL(DFP), OPTIONAL, INTENT(OUT) :: wt(n) !! n+1 weights from 1 to n+1 INTEGER(I4B), INTENT(IN) :: quadType !! Gauss @@ -429,18 +554,15 @@ END FUNCTION LegendreEval2 !> author: Vikas Sharma, Ph. D. ! date: 6 Sept 2022 -! summary: Evaluate Legendre polynomials from order = 0 to n at several points +! summary: Evaluate Legendre polynomials from order = 0 to n at single point ! !# Introduction ! -! Evaluate Legendre polynomials from order = 0 to n at several points +! Evaluate Legendre polynomials from order = 0 to n at single points ! !- N, the highest order polynomial to compute. Note that polynomials 0 ! through N will be computed. -!- alpha, beta are parameters !- x: the point at which the polynomials are to be evaluated. -!- ans(M,1:N+1), the values of the first N+1 Legendre polynomials at the point -! X. INTERFACE MODULE PURE FUNCTION LegendreEvalAll1(n, x) RESULT(ans) @@ -476,14 +598,19 @@ END FUNCTION LegendreEvalAll1 !- x: the point at which the polynomials are to be evaluated. !- ans(M,1:N+1), the values of the first N+1 Legendre polynomials at the point ! X. +! +!- the ith row of ans denotes the values of all polynomials at +! ith point. In this case shape of ans is (M,1:N+1), where M is number of +! points, N+1 number of polynomials. So ans(j, :) denotes value of all +! polynomials at jth point, and ans(:, n) denotes value of Pn at all nodes INTERFACE MODULE PURE FUNCTION LegendreEvalAll2(n, x) RESULT(ans) INTEGER(I4B), INTENT(IN) :: n REAL(DFP), INTENT(IN) :: x(:) + !! number of points, SIZE(x)=M REAL(DFP) :: ans(SIZE(x), n + 1) - !! Evaluate Legendre polynomial of order = 0 to n (total n+1) - !! at point x + !! shape (M,N+1) END FUNCTION LegendreEvalAll2 END INTERFACE @@ -655,6 +782,422 @@ END FUNCTION LegendreGradientEval2 MODULE PROCEDURE LegendreGradientEval2 END INTERFACE LegendreGradientEval +!---------------------------------------------------------------------------- +! LegendreEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Legendre polynomials at point x + +INTERFACE + MODULE PURE FUNCTION LegendreEvalSum1(n, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreEvalSum1 +END INTERFACE + +INTERFACE LegendreEvalSum + MODULE PROCEDURE LegendreEvalSum1 +END INTERFACE LegendreEvalSum + +PUBLIC :: LegendreEvalSum + +!---------------------------------------------------------------------------- +! LegendreEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate finite sum of Legendre polynomials at several x + +INTERFACE + MODULE PURE FUNCTION LegendreEvalSum2(n, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreEvalSum2 +END INTERFACE + +INTERFACE LegendreEvalSum + MODULE PROCEDURE LegendreEvalSum2 +END INTERFACE LegendreEvalSum + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Legendre polynomials +! at point x + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEvalSum1(n, x, coeff) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreGradientEvalSum1 +END INTERFACE + +INTERFACE LegendreGradientEvalSum + MODULE PROCEDURE LegendreGradientEvalSum1 +END INTERFACE LegendreGradientEvalSum + +PUBLIC :: LegendreGradientEvalSum + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the gradient of finite sum of Legendre polynomials +! at several x + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEvalSum2(n, x, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreGradientEvalSum2 +END INTERFACE + +INTERFACE LegendreGradientEvalSum + MODULE PROCEDURE LegendreGradientEvalSum2 +END INTERFACE LegendreGradientEvalSum + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth derivative of finite sum of Legendre +! polynomials at point x + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEvalSum3(n, x, coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! order of derivative + REAL(DFP) :: ans + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreGradientEvalSum3 +END INTERFACE + +INTERFACE LegendreGradientEvalSum + MODULE PROCEDURE LegendreGradientEvalSum3 +END INTERFACE LegendreGradientEvalSum + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate the kth gradient of finite sum of Legendre +! polynomials at several x + +INTERFACE + MODULE PURE FUNCTION LegendreGradientEvalSum4(n, x, coeff, k) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! point + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! Coefficient of finite sum, size = n+1 + INTEGER(I4B), INTENT(IN) :: k + !! kth order derivative + REAL(DFP) :: ans(SIZE(x)) + !! Evaluate Legendre polynomial of order n at point x + END FUNCTION LegendreGradientEvalSum4 +END INTERFACE + +INTERFACE LegendreGradientEvalSum + MODULE PROCEDURE LegendreGradientEvalSum4 +END INTERFACE LegendreGradientEvalSum + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Discrete Legendre Transform + +INTERFACE + MODULE PURE FUNCTION LegendreTransform1(n, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION LegendreTransform1 +END INTERFACE + +INTERFACE LegendreTransform + MODULE PROCEDURE LegendreTransform1 +END INTERFACE LegendreTransform + +PUBLIC :: LegendreTransform + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Columnwise Discrete Legendre Transform + +INTERFACE + MODULE PURE FUNCTION LegendreTransform2(n, coeff, x, w, & + & quadType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: coeff(0:, 1:) + !! nodal value (at quad points) + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(IN) :: w(0:n) + !! weights + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n, 1:SIZE(coeff, 2)) + !! modal values or coefficients for each column of val + END FUNCTION LegendreTransform2 +END INTERFACE + +INTERFACE LegendreTransform + MODULE PROCEDURE LegendreTransform2 +END INTERFACE LegendreTransform + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Legendre Transform of a function on [-1,1] +! +!# Introduction +! +! This function performs the Legendre transformation of f defined +! on -1 to 1. The interface of the function is give below: +! +!```fortran +! ABSTRACT INTERFACE +! ELEMENTAL FUNCTION iface_1DFunction(x) RESULT(ans) +! IMPORT :: DFP +! REAL(DFP), INTENT(IN) :: x +! REAL(DFP) :: ans +! END FUNCTION iface_1DFunction +! END INTERFACE +!``` +! +!@note +! This routine is not pure, because this subroutine calls +! `LegendreQuadrature` which is not pure due to Lapack call. +!@endnote + +INTERFACE + MODULE FUNCTION LegendreTransform3(n, f, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of jacobi polynomial + PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f + !! 1D space function + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft + !! GaussRadauRight + REAL(DFP) :: ans(0:n) + !! modal values or coefficients + END FUNCTION LegendreTransform3 +END INTERFACE + +INTERFACE LegendreTransform + MODULE PROCEDURE LegendreTransform3 +END INTERFACE LegendreTransform + +!---------------------------------------------------------------------------- +! LegendreInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Inverse Legendre Transform + +INTERFACE + MODULE PURE FUNCTION LegendreInvTransform1(n, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x + !! x point in physical space + REAL(DFP) :: ans + !! value in physical space + END FUNCTION LegendreInvTransform1 +END INTERFACE + +INTERFACE LegendreInvTransform + MODULE PROCEDURE LegendreInvTransform1 +END INTERFACE LegendreInvTransform + +PUBLIC :: LegendreInvTransform + +!---------------------------------------------------------------------------- +! LegendreInvTransform +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Inverse Legendre Transform + +INTERFACE + MODULE PURE FUNCTION LegendreInvTransform2(n, coeff, x) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! n+1 coefficient (modal values) + REAL(DFP), INTENT(IN) :: x(:) + !! x point in physical space + REAL(DFP) :: ans(SIZE(x)) + !! value in physical space + END FUNCTION LegendreInvTransform2 +END INTERFACE + +INTERFACE LegendreInvTransform + MODULE PROCEDURE LegendreInvTransform2 +END INTERFACE LegendreInvTransform + +!---------------------------------------------------------------------------- +! LegendreGradientCoeff +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 13 Oct 2022 +! summary: Returns coefficients for gradient of Legendre expansion +! +!# Introduction +! +!- This routine returns the coefficients of gradient of Jacobi expansion. +!- Input is coefficient of Legendre expansion (modal values) +!- Output is coefficient of derivative of legendre expansion (modal values) + +INTERFACE + MODULE PURE FUNCTION LegendreGradientCoeff1(n, coeff) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: coeff(0:n) + !! coefficients $\tilde{u}_{n}$ obtained from LegendreTransform + REAL(DFP) :: ans(0:n) + !! coefficient of gradient + END FUNCTION LegendreGradientCoeff1 +END INTERFACE + +INTERFACE LegendreGradientCoeff + MODULE PROCEDURE LegendreGradientCoeff1 +END INTERFACE LegendreGradientCoeff + +PUBLIC :: LegendreGradientCoeff + +!---------------------------------------------------------------------------- +! LegendreDMatrix +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 Oct 2022 +! summary: Returns differentiation matrix for Legendre expansion + +INTERFACE + MODULE PURE FUNCTION LegendreDMatrix1(n, x, quadType) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP) :: ans(0:n, 0:n) + !! D matrix + END FUNCTION LegendreDMatrix1 +END INTERFACE + +INTERFACE LegendreDMatrix + MODULE PROCEDURE LegendreDMatrix1 +END INTERFACE LegendreDMatrix + +PUBLIC :: LegendreDMatrix + +!---------------------------------------------------------------------------- +! LegendreDMatEvenOdd +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 15 Oct 2022 +! summary: Performs even and odd decomposition of Differential matrix + +INTERFACE + MODULE PURE SUBROUTINE LegendreDMatEvenOdd1(n, D, e, o) + INTEGER(I4B), INTENT(IN) :: n + !! order of Legendre polynomial + REAL(DFP), INTENT(IN) :: D(0:n, 0:n) + !! n+1 by n+1 + REAL(DFP), INTENT(OUT) :: e(0:, 0:) + !! even Decomposition, 0:n/2, 0:n/2 + REAL(DFP), INTENT(OUT) :: o(0:, 0:) + !! odd decomposition, 0:n/2, 0:n/2 + END SUBROUTINE LegendreDMatEvenOdd1 +END INTERFACE + +INTERFACE LegendreDMatEvenOdd + MODULE PROCEDURE LegendreDMatEvenOdd1 +END INTERFACE LegendreDMatEvenOdd + +PUBLIC :: LegendreDMatEvenOdd + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index d2ae795e6..689d792ee 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -103,12 +103,13 @@ END FUNCTION LagrangeInDOF_Line !> author: Vikas Sharma, Ph. D. ! date: 14 Aug 2022 -! summary: Returns equidistance points on edge +! summary: Returns equidistance internal points on edge ! !# Introduction ! !- This function returns the equidistance points on edge !- All points are inside the interval +!- Points are in increasing order INTERFACE MODULE PURE FUNCTION EquidistanceInPoint_Line1(order, xij) RESULT(ans) @@ -167,7 +168,7 @@ END FUNCTION EquidistanceInPoint_Line2 !# Introduction ! !- This function returns the equidistance points on edge -!- All points are inside the interval +!- Points are in "VEFC" format, which means `xij(1,1:2)` are end points INTERFACE MODULE PURE FUNCTION EquidistancePoint_Line1(order, xij) & @@ -225,16 +226,52 @@ END FUNCTION EquidistancePoint_Line2 !> author: Vikas Sharma, Ph. D. ! date: 27 Aug 2022 ! summary: Returns the interpolation point +! +!# Introduction +! +!- This routine returns the interplation points on line +!- `xij` contains nodal coordinates of line in xij format. +!- SIZE(xij,1) = nsd, and SIZE(xij,2)=2 +!- If xij is absent then [-1,1] is used +!- `ipType` is interpolation point type, it can take following values +!- `Equidistance`, uniformly/evenly distributed points +!- `GaussLegendre`, Zeros of Legendre polynomials, all nodes are strictly +! inside the domain. +!- `GaussLegendreLobatto` or `GaussLobatto` are zeros of Lobatto polynomials +! they always contains boundary points +!- `GaussChebyshev` Zeros of Chebyshev polynomials of first kind, all +! nodes are internal +!- `GaussChebyshevLobatto` they contains boundary points +!- `GaussJacobi` and `GaussJacobiLobatto` +! +!- `layout` specifies the arrangement of points. Following options are +! possible: +! +!- `layout=VEFC` vertex, edge, face, cell, in this case first two points are +! boundary points, remaining (from 3 to n) are internal points in +! increasing order. +! +!- `layout=INCREASING` points are arranged in increasing order INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Line1(order, ipType, xij) & - & RESULT(ans) + MODULE FUNCTION InterpolationPoint_Line1(order, ipType, & + & layout, xij) RESULT(ans) !! INTEGER(I4B), INTENT(IN) :: order + !! Order of interpolation INTEGER(I4B), INTENT(IN) :: ipType + !! Interpolation point type + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! domain of interpolation + CHARACTER(LEN=*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" REAL(DFP), ALLOCATABLE :: ans(:, :) - !! + !! interpolation points in xij format + !! size(ans,1) = 1 + !! size(ans,2) = order+1 END FUNCTION InterpolationPoint_Line1 END INTERFACE @@ -253,25 +290,23 @@ END FUNCTION InterpolationPoint_Line1 ! summary: Returns the interpolation point INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Line2(order, ipType, xij) & - & RESULT(ans) + MODULE FUNCTION InterpolationPoint_Line2(order, ipType, xij, & + & layout) RESULT(ans) !! INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation nodes type: - !! Equidistance - !! LobattoGaussLegendre - !! LobattoGaussChebyshev - !! LobattoGaussJacobi - !! LobattoGaussGegenbauer - !! GaussLegendre - !! GaussChebyshev - !! GaussJacobi - !! GaussGegenbauer + !! Interpolation point type + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto REAL(DFP), INTENT(IN) :: xij(2) !! end points + CHARACTER(LEN=*), INTENT(IN) :: layout + !! "VEFC" + !! "INCREASING" + !! "DECREASING" REAL(DFP), ALLOCATABLE :: ans(:) - !! + !! one dimensional interpolation point END FUNCTION InterpolationPoint_Line2 END INTERFACE @@ -280,7 +315,91 @@ END FUNCTION InterpolationPoint_Line2 END INTERFACE InterpolationPoint_Line !---------------------------------------------------------------------------- -! +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Line1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(xij,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) = order+1 + REAL(DFP) :: ans(order + 1) + !! coefficients + END FUNCTION LagrangeCoeff_Line1 +END INTERFACE + +INTERFACE LagrangeCoeff_Line + MODULE PROCEDURE LagrangeCoeff_Line1 +END INTERFACE LagrangeCoeff_Line + +PUBLIC :: LagrangeCoeff_Line + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line !---------------------------------------------------------------------------- +INTERFACE + MODULE FUNCTION LagrangeCoeff_Line2(order, i, v, isVandermonde) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(order + 1) + !! coefficients + END FUNCTION LagrangeCoeff_Line2 +END INTERFACE + +INTERFACE LagrangeCoeff_Line + MODULE PROCEDURE LagrangeCoeff_Line2 +END INTERFACE LagrangeCoeff_Line + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Line3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(order + 1) + !! coefficients + END FUNCTION LagrangeCoeff_Line3 +END INTERFACE + +INTERFACE LagrangeCoeff_Line + MODULE PROCEDURE LagrangeCoeff_Line3 +END INTERFACE LagrangeCoeff_Line + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Line4(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(xij,2)-1 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) = order+1 + REAL(DFP) :: ans(order + 1, order + 1) + !! coefficients + END FUNCTION LagrangeCoeff_Line4 +END INTERFACE + +INTERFACE LagrangeCoeff_Line + MODULE PROCEDURE LagrangeCoeff_Line4 +END INTERFACE LagrangeCoeff_Line + END MODULE LineInterpolationUtility diff --git a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 index d23141896..0af1fb120 100644 --- a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 @@ -25,20 +25,19 @@ MODULE OrthogonalPolynomialUtility !---------------------------------------------------------------------------- INTERFACE -MODULE PURE FUNCTION Clenshaw_1( x, alpha, beta, y0, ym1, c ) RESULT( ans ) - REAL( DFP ), INTENT( IN ) :: x - REAL( DFP ), INTENT( IN ) :: alpha(0:) - REAL( DFP ), INTENT( IN ) :: beta(0:) - REAL( DFP ), OPTIONAL, INTENT( IN ) :: y0 + MODULE PURE FUNCTION Clenshaw_1(x, alpha, beta, y0, ym1, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(IN) :: alpha(0:) + REAL(DFP), INTENT(IN) :: beta(0:) + REAL(DFP), OPTIONAL, INTENT(IN) :: y0 !! if y0 is absent then y0 = 1.0 - REAL( DFP ), OPTIONAL, INTENT( IN ) :: ym1 + REAL(DFP), OPTIONAL, INTENT(IN) :: ym1 !! if ym1 is absent then ym1 = 0.0 - REAL( DFP ), INTENT( IN ) :: c(0:) - REAL( DFP ) :: ans -END FUNCTION Clenshaw_1 + REAL(DFP), INTENT(IN) :: c(0:) + REAL(DFP) :: ans + END FUNCTION Clenshaw_1 END INTERFACE - INTERFACE Clenshaw MODULE PROCEDURE Clenshaw_1 END INTERFACE Clenshaw @@ -50,20 +49,19 @@ END FUNCTION Clenshaw_1 !---------------------------------------------------------------------------- INTERFACE -MODULE PURE FUNCTION Clenshaw_2( x, alpha, beta, y0, ym1, c ) RESULT( ans ) - REAL( DFP ), INTENT( IN ) :: x( : ) - REAL( DFP ), INTENT( IN ) :: alpha(0:) - REAL( DFP ), INTENT( IN ) :: beta(0:) - REAL( DFP ), OPTIONAL, INTENT( IN ) :: y0 + MODULE PURE FUNCTION Clenshaw_2(x, alpha, beta, y0, ym1, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(IN) :: alpha(0:) + REAL(DFP), INTENT(IN) :: beta(0:) + REAL(DFP), OPTIONAL, INTENT(IN) :: y0 !! if y0 is absent then y0 = 1.0 - REAL( DFP ), OPTIONAL, INTENT( IN ) :: ym1 + REAL(DFP), OPTIONAL, INTENT(IN) :: ym1 !! if ym1 is absent then ym1 = 0.0 - REAL( DFP ), INTENT( IN ) :: c(0:) - REAL( DFP ) :: ans( SIZE( x ) ) -END FUNCTION Clenshaw_2 + REAL(DFP), INTENT(IN) :: c(0:) + REAL(DFP) :: ans(SIZE(x)) + END FUNCTION Clenshaw_2 END INTERFACE - INTERFACE Clenshaw MODULE PROCEDURE Clenshaw_2 END INTERFACE Clenshaw @@ -85,11 +83,11 @@ END FUNCTION Clenshaw_2 !$$ INTERFACE -MODULE PURE FUNCTION ChebClenshaw_1( x, c ) RESULT( ans ) - REAL( DFP ), INTENT( IN ) :: x - REAL( DFP ), INTENT( IN ) :: c(0:) - REAL( DFP ) :: ans -END FUNCTION ChebClenshaw_1 + MODULE PURE FUNCTION ChebClenshaw_1(x, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: x + REAL(DFP), INTENT(IN) :: c(0:) + REAL(DFP) :: ans + END FUNCTION ChebClenshaw_1 END INTERFACE INTERFACE Clenshaw @@ -119,11 +117,11 @@ END FUNCTION ChebClenshaw_1 !$$ INTERFACE -MODULE PURE FUNCTION ChebClenshaw_2( x, c ) RESULT( ans ) - REAL( DFP ), INTENT( IN ) :: x( : ) - REAL( DFP ), INTENT( IN ) :: c(0:) - REAL( DFP ) :: ans( SIZE( x ) ) -END FUNCTION ChebClenshaw_2 + MODULE PURE FUNCTION ChebClenshaw_2(x, c) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP), INTENT(IN) :: c(0:) + REAL(DFP) :: ans(SIZE(x)) + END FUNCTION ChebClenshaw_2 END INTERFACE INTERFACE Clenshaw @@ -139,16 +137,16 @@ END FUNCTION ChebClenshaw_2 !---------------------------------------------------------------------------- INTERFACE -MODULE PURE SUBROUTINE JacobiMatrix_1( alphaCoeff, betaCoeff, D, E ) - REAL( DFP ), INTENT( IN ) :: alphaCoeff( 0: ) + MODULE PURE SUBROUTINE JacobiMatrix_1(alphaCoeff, betaCoeff, D, E) + REAL(DFP), INTENT(IN) :: alphaCoeff(0:) !! size n, from 0 to n-1 - REAL( DFP ), INTENT( IN ) :: betaCoeff( 0: ) + REAL(DFP), INTENT(IN) :: betaCoeff(0:) !! size n, from 0 to n-1 - REAL( DFP ), INTENT( OUT ) :: D(:) + REAL(DFP), INTENT(OUT) :: D(:) !! entry from 1 to n are filled - REAL( DFP ), INTENT( OUT ) :: E(:) + REAL(DFP), INTENT(OUT) :: E(:) !! entry from 1 to n-1 are filled -END SUBROUTINE JacobiMatrix_1 + END SUBROUTINE JacobiMatrix_1 END INTERFACE INTERFACE JacobiMatrix @@ -157,5 +155,29 @@ END SUBROUTINE JacobiMatrix_1 PUBLIC :: JacobiMatrix +!---------------------------------------------------------------------------- +! EvalAllOrthopol +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION EvalAllOrthopol(n, x, orthopol, alpha, beta, & + & lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! order of polynomial + REAL(DFP), INTENT(IN) :: x(:) + !! points of evaluation + INTEGER(I4B), INTENT(IN) :: orthopol + !! orthogonal polynomial family + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! alpha1 needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! beta1 is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! lambda1 is needed when orthopol1 is "Ultraspherical" + REAL(DFP) :: ans(SIZE(x), n + 1) + END FUNCTION EvalAllOrthopol +END INTERFACE + +PUBLIC :: EvalAllOrthopol -END MODULE OrthogonalPolynomialUtility \ No newline at end of file +END MODULE OrthogonalPolynomialUtility diff --git a/src/modules/Polynomial/src/PolynomialUtility.F90 b/src/modules/Polynomial/src/PolynomialUtility.F90 index 041110030..362d8fcc0 100644 --- a/src/modules/Polynomial/src/PolynomialUtility.F90 +++ b/src/modules/Polynomial/src/PolynomialUtility.F90 @@ -17,9 +17,10 @@ MODULE PolynomialUtility USE InterpolationUtility -USE LagrangeUtility +USE LagrangePolynomialUtility USE OrthogonalPolynomialUtility USE JacobiPolynomialUtility +USE UltrasphericalPolynomialUtility USE LegendrePolynomialUtility USE LobattoPolynomialUtility USE UnscaledLobattoPolynomialUtility diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 index 791f05d34..9aeaa342b 100644 --- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PrismInterpolationUtility.F90 @@ -149,12 +149,14 @@ END FUNCTION EquidistancePoint_Prism ! summary: Interpolation point on Prism INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Prism(order, ipType, xij) & + MODULE PURE FUNCTION InterpolationPoint_Prism(order, ipType, layout, xij) & & RESULT(nodecoord) INTEGER(I4B), INTENT(IN) :: order !! order INTEGER(I4B), INTENT(IN) :: ipType !! interpolation point type + CHARACTER(LEN=*), INTENT(IN) :: layout + !! REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! coords of vertices in $x_{iJ}$ format REAL(DFP), ALLOCATABLE :: nodecoord(:, :) @@ -164,6 +166,95 @@ END FUNCTION InterpolationPoint_Prism PUBLIC :: InterpolationPoint_Prism +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Prism1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Prism1 +END INTERFACE + +INTERFACE LagrangeCoeff_Prism + MODULE PROCEDURE LagrangeCoeff_Prism1 +END INTERFACE LagrangeCoeff_Prism + +PUBLIC :: LagrangeCoeff_Prism + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Prism2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Prism2 +END INTERFACE + +INTERFACE LagrangeCoeff_Prism + MODULE PROCEDURE LagrangeCoeff_Prism2 +END INTERFACE LagrangeCoeff_Prism + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Prism3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Prism3 +END INTERFACE + +INTERFACE LagrangeCoeff_Prism + MODULE PROCEDURE LagrangeCoeff_Prism3 +END INTERFACE LagrangeCoeff_Prism + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Prism4(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Prism4 +END INTERFACE + +INTERFACE LagrangeCoeff_Prism + MODULE PROCEDURE LagrangeCoeff_Prism4 +END INTERFACE LagrangeCoeff_Prism + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 index ca8ef1df6..55bf3b526 100644 --- a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 @@ -149,12 +149,14 @@ END FUNCTION EquidistancePoint_Pyramid ! summary: Interpolation point on Pyramid INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Pyramid(order, ipType, xij) & - & RESULT(nodecoord) + MODULE PURE FUNCTION InterpolationPoint_Pyramid(order, ipType, & + & layout, xij) RESULT(nodecoord) INTEGER(I4B), INTENT(IN) :: order !! order of element INTEGER(I4B), INTENT(IN) :: ipType !! interpolation points + CHARACTER(LEN=*), INTENT(IN) :: layout + !! layout REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! coords of vertices in $x_{iJ}$ format REAL(DFP), ALLOCATABLE :: nodecoord(:, :) @@ -164,6 +166,95 @@ END FUNCTION InterpolationPoint_Pyramid PUBLIC :: InterpolationPoint_Pyramid +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Pyramid1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Pyramid1 +END INTERFACE + +INTERFACE LagrangeCoeff_Pyramid + MODULE PROCEDURE LagrangeCoeff_Pyramid1 +END INTERFACE LagrangeCoeff_Pyramid + +PUBLIC :: LagrangeCoeff_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Pyramid2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Pyramid2 +END INTERFACE + +INTERFACE LagrangeCoeff_Pyramid + MODULE PROCEDURE LagrangeCoeff_Pyramid2 +END INTERFACE LagrangeCoeff_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Pyramid3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Pyramid3 +END INTERFACE + +INTERFACE LagrangeCoeff_Pyramid + MODULE PROCEDURE LagrangeCoeff_Pyramid3 +END INTERFACE LagrangeCoeff_Pyramid + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Pyramid4(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Pyramid4 +END INTERFACE + +INTERFACE LagrangeCoeff_Pyramid + MODULE PROCEDURE LagrangeCoeff_Pyramid4 +END INTERFACE LagrangeCoeff_Pyramid + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 80e05c9f4..5ed3f1082 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -141,7 +141,7 @@ END FUNCTION EquidistancePoint_Quadrangle PUBLIC :: EquidistancePoint_Quadrangle !---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle +! InterpolationPoint_Quadrangle !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -149,14 +149,16 @@ END FUNCTION EquidistancePoint_Quadrangle ! summary: Interpolation point INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Quadrangle(order, ipType, xij) & - & RESULT(nodecoord) + MODULE PURE FUNCTION InterpolationPoint_Quadrangle(order, ipType, xij, & + & layout) RESULT(nodecoord) INTEGER(I4B), INTENT(IN) :: order !! order of element INTEGER(I4B), INTENT(IN) :: ipType !! interpolation point type REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! xij format + CHARACTER(LEN=*), INTENT(IN) :: layout + !! REAL(DFP), ALLOCATABLE :: nodecoord(:, :) !! interpolation points in xij format END FUNCTION InterpolationPoint_Quadrangle @@ -165,7 +167,501 @@ END FUNCTION InterpolationPoint_Quadrangle PUBLIC :: InterpolationPoint_Quadrangle !---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Quadrangle1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle1 +END INTERFACE + +INTERFACE LagrangeCoeff_Quadrangle + MODULE PROCEDURE LagrangeCoeff_Quadrangle1 +END INTERFACE LagrangeCoeff_Quadrangle + +PUBLIC :: LagrangeCoeff_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle2 +END INTERFACE + +INTERFACE LagrangeCoeff_Quadrangle + MODULE PROCEDURE LagrangeCoeff_Quadrangle2 +END INTERFACE LagrangeCoeff_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Quadrangle3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle3 +END INTERFACE + +INTERFACE LagrangeCoeff_Quadrangle + MODULE PROCEDURE LagrangeCoeff_Quadrangle3 +END INTERFACE LagrangeCoeff_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Quadrangle4(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle4 +END INTERFACE + +INTERFACE LagrangeCoeff_Quadrangle + MODULE PROCEDURE LagrangeCoeff_Quadrangle4 +END INTERFACE LagrangeCoeff_Quadrangle + +!---------------------------------------------------------------------------- +! DubinerPolynomial +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on biunit domain +! +!# Introduction +! +! Forms Dubiner basis on biunit quadrangle domain. +! This routine is called while forming dubiner basis on triangle domain +! +! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) +! N = 0.5*(order+1)*(order+2). +! +! In this way, ans(j,:) denotes the values of all polynomial at jth point ! +! Polynomials are returned in following way: +! +!$$ +! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ +! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ +! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ +! \cdots +! P_{order,0} +!$$ +! +! For example for order=3, the polynomials are arranged as: +! +!$$ +! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ +! P_{1,0}, P_{1,1}, P_{1,2} \\ +! P_{2,0}, P_{2,1} \\ +! P_{3,0} +!$$ + +INTERFACE + MODULE PURE FUNCTION Dubiner_Quadrangle1(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in biunit quadrangle, shape functions will be evaluated + !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points + REAL(DFP) :: ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION Dubiner_Quadrangle1 +END INTERFACE + +INTERFACE Dubiner_Quadrangle + MODULE PROCEDURE Dubiner_Quadrangle1 +END INTERFACE Dubiner_Quadrangle + +PUBLIC :: Dubiner_Quadrangle + +!---------------------------------------------------------------------------- +! DubinerPolynomial +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on biunit domain +! +!# Introduction +! +! Forms Dubiner basis on biunit quadrangle domain. +! This routine is same as Dubiner_Quadrangle1 +! The only difference is that xij are given by outerproduct of x and y. +! This function calls `Dubiner_Quadrangle1`. + +INTERFACE + MODULE PURE FUNCTION Dubiner_Quadrangle2(order, x, y) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: x(:) + !! x coordinate on line + REAL(DFP), INTENT(IN) :: y(:) + !! y coordinate on line + REAL(DFP) :: ans(SIZE(x) * SIZE(y), (order + 1) * (order + 2) / 2) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION Dubiner_Quadrangle2 +END INTERFACE + +INTERFACE Dubiner_Quadrangle + MODULE PROCEDURE Dubiner_Quadrangle2 +END INTERFACE Dubiner_Quadrangle + +!---------------------------------------------------------------------------- +! TensorProdOrthopol_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle +! +!# Introduction +! +! This function returns the tensor product expansion of orthogonal +! polynomial on biunit quadrangle. + +INTERFACE + MODULE PURE FUNCTION TensorProdOrthopol_Quadrangle1(p, q, xij, & + & orthopol1, orthopol2, alpha1, beta1, alpha2, beta2, lambda1, lambda2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: orthopol1 + !! orthogonal polynomial family in x1 direction + INTEGER(I4B), INTENT(IN) :: orthopol2 + !! orthogonal poly family in x2 direction + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when orthopol2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when orthopol2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when orthopol1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when orthopol2 is "Ultraspherical" + REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1)) + !! + END FUNCTION TensorProdOrthopol_Quadrangle1 +END INTERFACE + +INTERFACE TensorProdOrthopol_Quadrangle + MODULE PROCEDURE TensorProdOrthopol_Quadrangle1 +END INTERFACE TensorProdOrthopol_Quadrangle + +PUBLIC :: TensorProdOrthopol_Quadrangle + +!---------------------------------------------------------------------------- +! TensorProdOrthopol_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle +! +!# Introduction +! +! This function returns the tensor product expansion of orthogonal +! polynomial on biunit quadrangle. Here xij is obtained by +! outer product of x and y + +INTERFACE + MODULE PURE FUNCTION TensorProdOrthopol_Quadrangle2(p, q, x, y, & + & orthopol1, orthopol2, alpha1, beta1, alpha2, beta2, lambda1, lambda2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: orthopol1 + !! orthogonal polynomial family in x1 direction + INTEGER(I4B), INTENT(IN) :: orthopol2 + !! orthogonal poly family in x2 direction + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when orthopol1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when orthopol2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when orthopol2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when orthopol1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when orthopol2 is "Ultraspherical" + REAL(DFP) :: ans(SIZE(x) * SIZE(y), (p + 1) * (q + 1)) + !! + END FUNCTION TensorProdOrthopol_Quadrangle2 +END INTERFACE + +INTERFACE TensorProdOrthopol_Quadrangle + MODULE PROCEDURE TensorProdOrthopol_Quadrangle2 +END INTERFACE TensorProdOrthopol_Quadrangle + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +INTERFACE + MODULE PURE FUNCTION VertexBasis_Quadrangle(x, y) RESULT(ans) + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(x), 4) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Quadrangle +END INTERFACE + +PUBLIC :: VertexBasis_Quadrangle + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +INTERFACE + MODULE PURE FUNCTION VertexBasis_Quadrangle2(L1, L2) RESULT(ans) + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(L1, 1), 4) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! VerticalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on left, right edge of biunit quadrangle +! +!# Introduction +! +! Evaluate basis functions on left and right edge of biunit quadrangle +! +! qe1 and qe2 should be greater than or equal to 2 + +INTERFACE + MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle(qe1, qe2, x, y) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: qe1 + !! order on left vertical edge (e1) + INTEGER(I4B), INTENT(IN) :: qe2 + !! order on right vertical edge(e2) + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(x), qe1 + qe2 - 2) + END FUNCTION VerticalEdgeBasis_Quadrangle +END INTERFACE + +PUBLIC :: VerticalEdgeBasis_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle2(qe1, qe2, L1, L2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: qe1 + !! order on left vertical edge (e1) + INTEGER(I4B), INTENT(IN) :: qe2 + !! order on right vertical edge(e2) + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(L1, 1), qe1 + qe2 - 2) + END FUNCTION VerticalEdgeBasis_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on bottom and top edge of biunit quadrangle +! +!# Introduction +! +! Evaluate basis functions on bottom and top edge of biunit quadrangle +! +! pe3 and pe4 should be greater than or equal to 2 + +INTERFACE + MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle(pe3, pe4, x, y) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on bottom vertical edge (e3) + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on top vertical edge(e4) + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(x), pe3 + pe4 - 2) + END FUNCTION HorizontalEdgeBasis_Quadrangle +END INTERFACE + +PUBLIC :: HorizontalEdgeBasis_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle2(pe3, pe4, L1, L2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on bottom vertical edge (e3) + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on top vertical edge(e4) + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(L1, 1), pe3 + pe4 - 2) + END FUNCTION HorizontalEdgeBasis_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! CellBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis in the cell of biunit quadrangle +! +!# Introduction +! +! Evaluate basis functions in the cell of biunit quadrangle + +INTERFACE + MODULE PURE FUNCTION CellBasis_Quadrangle(pb, qb, x, y) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3) + INTEGER(I4B), INTENT(IN) :: qb + !! order on top vertical edge(e4) + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(x), (pb - 1) * (qb - 1)) + END FUNCTION CellBasis_Quadrangle +END INTERFACE + +PUBLIC :: CellBasis_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION CellBasis_Quadrangle2(pb, qb, L1, L2) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3) + INTEGER(I4B), INTENT(IN) :: qb + !! order on top vertical edge(e4) + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1)) + END FUNCTION CellBasis_Quadrangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle +! +!# Introduction +! +! This function returns the modal basis on orthogonal polynomial +! The modal function in 1D is given by scaled Lobatto polynomial. +! These modal functions are orthogonal with respect to H1 seminorm. +! However, these modal function are not orthogonal withrespect to L2 norm. +! +! Bubble function in 1D is proportional to Jacobi polynomial with +! alpha=beta=1. Equivalently, these bubble functions are proportional to +! Ultraspherical polynomials with lambda = 3/2. +! + +INTERFACE + MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle1(pb, qb, pe3, pe4, & + & qe1, qe2, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP) :: ans(SIZE(xij, 2), & + & pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1) + !! + END FUNCTION HeirarchicalBasis_Quadrangle1 +END INTERFACE + +INTERFACE HeirarchicalBasis_Quadrangle + MODULE PROCEDURE HeirarchicalBasis_Quadrangle1 +END INTERFACE HeirarchicalBasis_Quadrangle + +PUBLIC :: HeirarchicalBasis_Quadrangle + END MODULE QuadrangleInterpolationUtility diff --git a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 index fa9da6f75..f39b584d5 100644 --- a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 +++ b/src/modules/Polynomial/src/RecursiveNodesUtility.F90 @@ -26,10 +26,11 @@ MODULE RecursiveNodesUtility !> author: Vikas Sharma, Ph. D. ! date: 4 Sept 2022 -! summary: Convert nodal coordinates to barycentric coordinates +! summary: Convert nodal coordinates to barycentric coordinates INTERFACE - MODULE PURE FUNCTION RecursiveNode1D(order, ipType, domain) RESULT(ans) + MODULE FUNCTION RecursiveNode1D(order, ipType, & + & domain) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order >= 0 INTEGER(I4B), INTENT(IN) :: ipType @@ -60,10 +61,10 @@ END FUNCTION RecursiveNode1D !> author: Vikas Sharma, Ph. D. ! date: 4 Sept 2022 -! summary: Convert nodal coordinates to barycentric coordinates +! summary: Convert nodal coordinates to barycentric coordinates INTERFACE - MODULE PURE FUNCTION RecursiveNode2D(order, ipType, domain) & + MODULE FUNCTION RecursiveNode2D(order, ipType, domain) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order >= 0 @@ -98,7 +99,7 @@ END FUNCTION RecursiveNode2D ! summary: Convert nodal coordinates to barycentric coordinates INTERFACE - MODULE PURE FUNCTION RecursiveNode3D(order, ipType, & + MODULE FUNCTION RecursiveNode3D(order, ipType, & & domain) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order >= 0 diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 index cd4564f86..3e99467df 100644 --- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 @@ -149,12 +149,13 @@ END FUNCTION EquidistancePoint_Tetrahedron ! summary: Interpolation point INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Tetrahedron(order, ipType, xij) & - & RESULT(nodecoord) + MODULE PURE FUNCTION InterpolationPoint_Tetrahedron(order, ipType, & + & layout, xij) RESULT(nodecoord) INTEGER(I4B), INTENT(IN) :: order !! order of element INTEGER(I4B), INTENT(IN) :: ipType !! interpolation type + CHARACTER(LEN=*), INTENT(IN) :: layout REAL(DFP), OPTIONAL, INTENT(IN) :: xij(3, 4) !! coordinates of vertices in $x_{iJ}$ format REAL(DFP), ALLOCATABLE :: nodecoord(:, :) @@ -164,4 +165,93 @@ END FUNCTION InterpolationPoint_Tetrahedron PUBLIC :: InterpolationPoint_Tetrahedron +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Tetrahedron1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Tetrahedron1 +END INTERFACE + +INTERFACE LagrangeCoeff_Tetrahedron + MODULE PROCEDURE LagrangeCoeff_Tetrahedron1 +END INTERFACE LagrangeCoeff_Tetrahedron + +PUBLIC :: LagrangeCoeff_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Tetrahedron2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Tetrahedron2 +END INTERFACE + +INTERFACE LagrangeCoeff_Tetrahedron + MODULE PROCEDURE LagrangeCoeff_Tetrahedron2 +END INTERFACE LagrangeCoeff_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Tetrahedron3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Tetrahedron3 +END INTERFACE + +INTERFACE LagrangeCoeff_Tetrahedron + MODULE PROCEDURE LagrangeCoeff_Tetrahedron3 +END INTERFACE LagrangeCoeff_Tetrahedron + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Tetrahedron4(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Tetrahedron4 +END INTERFACE + +INTERFACE LagrangeCoeff_Tetrahedron + MODULE PROCEDURE LagrangeCoeff_Tetrahedron4 +END INTERFACE LagrangeCoeff_Tetrahedron + END MODULE TetrahedronInterpolationUtility diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index 9617121a3..2f6df8821 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -118,11 +118,11 @@ END FUNCTION EquidistanceInPoint_Triangle !# Introduction ! !- This function returns the nodal coordinates of higher order -! triangle element +! triangle element, the layout is always "VEFC" !- The coordinates are distributed uniformly !- These coordinates can be used to construct lagrange polynomials !- The returned coordinates are in $x_{iJ}$ format. -!- The node numbering is according to Gmsh convention. +!- The node numbering is according to Gmsh convention, VEFC. INTERFACE MODULE PURE FUNCTION EquidistancePoint_Triangle(order, xij) RESULT(ans) @@ -139,24 +139,103 @@ END FUNCTION EquidistancePoint_Triangle PUBLIC :: EquidistancePoint_Triangle +!---------------------------------------------------------------------------- +! BlythPozrikidis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Blyth Pozrikidis nodes on triangle + +INTERFACE + MODULE FUNCTION BlythPozrikidis_Triangle(order, ipType, layout, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! xij coordinates + CHARACTER(LEN=*), INTENT(IN) :: layout + !! local node numbering layout + !! only layout = "VEFC" is allowed + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! xij coordinates + END FUNCTION BlythPozrikidis_Triangle +END INTERFACE + +!---------------------------------------------------------------------------- +! Isaac_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Isaac points on triangle + +INTERFACE + MODULE FUNCTION Isaac_Triangle(order, ipType, layout, xij) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order + INTEGER(I4B), INTENT(IN) :: ipType + !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, + !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! xij coordinates + CHARACTER(LEN=*), INTENT(IN) :: layout + !! local node numbering layout + !! only layout = "VEFC" is allowed + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! xij coordinates + END FUNCTION Isaac_Triangle +END INTERFACE + !---------------------------------------------------------------------------- ! InterpolationPoint_Triangle !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 18 Aug 2022 -! summary: Interpolation point on triangle +! summary: Interpolation points on triangle +! +!# Introduction +! +!- This routine returns the interplation points on line +!- `xij` contains nodal coordinates of line in xij format. +!- SIZE(xij,1) = nsd, and SIZE(xij,2)=2 +!- If xij is absent then [-1,1] is used +!- `ipType` is interpolation point type, it can take following values +!- `Equidistance`, uniformly/evenly distributed points +!- `GaussLegendreLobatto ---> IsaacLegendre +!- `GaussChebyshevLobatto ---> IsaacChebyshev +!- `GaussJacobi` and `GaussJacobiLobatto` +!- `ChenBabuska` +!- `Hesthaven` +!- `Feket` +!- `BlythPozChebyshev` +!- `BlythPozLegendre` +!- `IsaacChebyshev` +!- `IsaacLegendre` +! +!- `layout` specifies the arrangement of points. The nodes are always +! returned in VEFC format (vertex, edge, face, cell). 1:3 are are +! vertex points, then edge, and then internal nodes. The internal nodes +! also follow the same convention. Please read Gmsh manual on this topic. +! In case of BlythPoz and Recursive INTERFACE - MODULE PURE FUNCTION InterpolationPoint_Triangle(order, ipType, xij) & - & RESULT(nodecoord) + MODULE FUNCTION InterpolationPoint_Triangle(order, ipType, & + & layout, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation type + !! interpolation point type REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! xij coordinates - REAL(DFP), ALLOCATABLE :: nodecoord(:, :) + !! Coord of domain in xij format + CHARACTER(LEN=*), INTENT(IN) :: layout + !! local node numbering layout, always VEFC + REAL(DFP), ALLOCATABLE :: ans(:, :) !! xij coordinates END FUNCTION InterpolationPoint_Triangle END INTERFACE @@ -164,7 +243,250 @@ END FUNCTION InterpolationPoint_Triangle PUBLIC :: InterpolationPoint_Triangle !---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Returns the coefficients for ith lagrange polynomial for monomial +! basis +! +!# Introduction +! +! ith Lagrange polynomial for interpolation points xij is given by +! +!$$ +! l_{i}(x) = \sum_{n=0}^{N} a_{n} x^{n} +!$$ +! +! This function returns the coefficients $a_{n}$. + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Triangle1(order, i, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Triangle1 +END INTERFACE + +INTERFACE LagrangeCoeff_Triangle + MODULE PROCEDURE LagrangeCoeff_Triangle1 +END INTERFACE LagrangeCoeff_Triangle + +PUBLIC :: LagrangeCoeff_Triangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Returns the coefficients for ith lagrange polynomial for monomial +! basis +! +!# Introduction ! +! ith Lagrange polynomial for interpolation points xij is given by +! +!$$ +! l_{i}(x) = \sum_{n=0}^{N} a_{n} x^{n} +!$$ +! +! This function returns the coefficients $a_{n}$ + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Triangle2(order, i, v, isVandermonde) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Triangle2 +END INTERFACE + +INTERFACE LagrangeCoeff_Triangle + MODULE PROCEDURE LagrangeCoeff_Triangle2 +END INTERFACE LagrangeCoeff_Triangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Returns the coefficients for ith lagrange polynomial for monomial +! basis +! +!# Introduction +! +! ith Lagrange polynomial for interpolation points xij is given by +! +!$$ +! l_{i}(x) = \sum_{n=0}^{N} a_{n} x^{n} +!$$ +! +! This function returns the coefficients $a_{n}$ + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Triangle3(order, i, v, ipiv) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Triangle3 +END INTERFACE + +INTERFACE LagrangeCoeff_Triangle + MODULE PROCEDURE LagrangeCoeff_Triangle3 +END INTERFACE LagrangeCoeff_Triangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Returns the coefficients for ith lagrange polynomial for monomial +! basis +! +!# Introduction +! +! ith Lagrange polynomial for interpolation points xij is given by +! +!$$ +! l_{i}(x) = \sum_{n=0}^{N} a_{n} x^{n} +!$$ +! +! This function returns the coefficients $a_{n}$ for ALL i. + +INTERFACE + MODULE FUNCTION LagrangeCoeff_Triangle4(order, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Triangle4 +END INTERFACE + +INTERFACE LagrangeCoeff_Triangle + MODULE PROCEDURE LagrangeCoeff_Triangle4 +END INTERFACE LagrangeCoeff_Triangle + +!---------------------------------------------------------------------------- +! DubinerPolynomial +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on triangle +! +!# Introduction +! +! Forms Dubiner basis on reference triangle domain. Reference triangle +! can be biunit or unit. +! +! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) +! N = 0.5*(order+1)*(order+2). +! +! In this way, ans(j,:) denotes the values of all polynomial at jth point +! +! Polynomials are returned in following way: +! +!$$ +! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ +! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ +! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ +! \cdots +! P_{order,0} +!$$ +! +! For example for order=3, the polynomials are arranged as: +! +!$$ +! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ +! P_{1,0}, P_{1,1}, P_{1,2} \\ +! P_{2,0}, P_{2,1} \\ +! P_{3,0} +!$$ + +INTERFACE + MODULE PURE FUNCTION Dubiner_Triangle1(order, xij, refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in reference triangle, shape functions will be evaluated + !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points + CHARACTER(LEN=*), INTENT(IN) :: refTriangle + !! "unit" + !! "biunit" + REAL(DFP) :: ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION Dubiner_Triangle1 +END INTERFACE + +INTERFACE Dubiner_Triangle + MODULE PROCEDURE Dubiner_Triangle1 +END INTERFACE Dubiner_Triangle + +PUBLIC :: Dubiner_Triangle + +!---------------------------------------------------------------------------- +! DubinerPolynomial +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on triangle +! +!# Introduction +! +! Forms Dubiner basis on reference triangle domain. Reference triangle +! can be biunit or unit. Here x and y are coordinate on line. +! xij is given by outerproduct of x and y. + +INTERFACE + MODULE PURE FUNCTION Dubiner_Triangle2(order, x, y, refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! x and y coordinates, total points = SIZE(x)*SIZE(y) + CHARACTER(LEN=*), INTENT(IN) :: refTriangle + !! "unit" + !! "biunit" + REAL(DFP) :: ans(SIZE(x) * SIZE(y), (order + 1) * (order + 2) / 2) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION Dubiner_Triangle2 +END INTERFACE + +INTERFACE Dubiner_Triangle + MODULE PROCEDURE Dubiner_Triangle2 +END INTERFACE Dubiner_Triangle + +!---------------------------------------------------------------------------- +! Triangle !---------------------------------------------------------------------------- END MODULE TriangleInterpolationUtility From a54e58496dbea63aed17e3a37878da450d75a1e8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:46:39 +0900 Subject: [PATCH 36/43] undefined --- .../src/assets/OrthoPoly_C_v1.0/readme.txt | 259 + .../OrthoPoly_C_v1.0/src/chebyshev_series.c | 1725 +++++++ .../OrthoPoly_C_v1.0/src/gegenbauer_series.c | 961 ++++ .../OrthoPoly_C_v1.0/src/hermite_series.c | 1484 ++++++ .../OrthoPoly_C_v1.0/src/inline_function.c | 180 + .../OrthoPoly_C_v1.0/src/jacobi_series.c | 1302 +++++ .../OrthoPoly_C_v1.0/src/laguerre_series.c | 973 ++++ .../OrthoPoly_C_v1.0/src/legendre_series.c | 882 ++++ .../src/assets/chebyshev_polynomial.f90 | 4320 +++++++++++++++++ 9 files changed, 12086 insertions(+) create mode 100644 src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/readme.txt create mode 100644 src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/chebyshev_series.c create mode 100644 src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/gegenbauer_series.c create mode 100644 src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/hermite_series.c create mode 100644 src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/inline_function.c create mode 100644 src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/jacobi_series.c create mode 100644 src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/laguerre_series.c create mode 100644 src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/legendre_series.c create mode 100644 src/modules/Polynomial/src/assets/chebyshev_polynomial.f90 diff --git a/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/readme.txt b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/readme.txt new file mode 100644 index 000000000..b1b372582 --- /dev/null +++ b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/readme.txt @@ -0,0 +1,259 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Licensing: +% +% This code is distributed under the GNU General Public License 3 (GPLv3). +% +% Modified: +% +% 05 October 2017 +% +% Authors: +% +% Roberto Barrio, Peibing Du, Hao Jiang and Sergio Serrano +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +Outline: + +I. Introduction +II. Directories and Files +III. Functions +IV. Example + +%---------------------------------------------------------------------------------------- + +I. Introduction + +ORTHOPOLY software permits to evaluate, efficiently and accurately, finite series of any +classical family of orthogonal polynomials (Chebyshev polynomials of the first and second kind, +Legendre, ultraspherical or Gegenbauer, Jacobi, Hermite and Laguerre orthogonal polynomials) +and their derivatives. The basic algorithm is the BCS-algorithm (Barrio-Clenshaw-Smith derivative algorithm), +that permits to evaluate the k-th derivative of a finite series of orthogonal +polynomials at any point without obtaining before the previous derivatives. The compensated +BCS-algorithm, based on Error-Free techniques, permits to relegate the influence of the +conditioning of the problem up to second order in the round-off unit of the computer. +The running error bounds are also given. + +%------------------------------------------------------------------------------------------- + +II. Directories and Files + +There are three directories and this file in the main directory of this distribution, +described below + +src This directory contains the source code of package OrthoPoly. This source code also includes + inline functions (double-double arithmetic, and error free transformation function). + +include This directory contains the header files for each orthogonal polynomial and inline fuctions. + +example This directory contains an example using the functions provided for Chebyshev polynomials + and the output for that example. + +%---------------------------------------------------------------------------------------- + +III. Functions + +OrthoPoly_C: the functions as follows are provided and can be found in directory src. + +1. Jacobi: + 1.1 JacobVal: + 1.2 CompJacobVal: + 1.3 AccJacobVal: + 1.4 JacobValwErr: + 1.5 CompJacobValwErr: + 1.6 AccJacobValwErr: + + 1.7 JacobDer: + 1.8 CompJacobDer: + 1.9 AccJacobDer: + 1.10 JacobDerwErr: + 1.11 CompJacobDerwErr: + 1.12 AccJacobDerwErr: + + 1.13 JacobDerK: + 1.14 CompJacobDerK: + 1.15 AccJacobDerK: + 1.16 JacobDerwErrK: + 1.17 CompJacobDerKwErr: + 1.18 AccJacobDerKwErr: + +2. Gegenbauber: + + 2.1 GegenVal: + 2.2 CompGegenVal: + 2.3 AccGegenVal: + 2.4 GegenValwErr: + 2.5 CompGegenValwErr: + 2.6 AccGegenValwErr: + + 2.7 GegenDer: + 2.8 CompGegenDer: + 2.9 AccGegenDer: + 2.10 GegenDerwErr: + 2.11 CompGegenDerwErr: + 2.12 AccGegenDerwErr: + + 2.13 GegenDerK: + 2.14 CompGegenDerK: + 2.15 AccGegenDerK: + 2.16 GegenDerwErrK: + 2.17 CompGegenDerKwErr: + 2.18 AccGegenDerKwErr: + +3. Chebyshev: + + 3.1 Cheb1Val: + 3.2 CompCheb1Val: + 3.3 AccCheb1Val: + 3.4 Cheb1ValwErr: + 3.5 CompCheb1ValwErr: + 3.6 AccCheb1ValwErr: + + 3.7 Cheb2Val: + 3.8 CompCheb2Val: + 3.9 AccCheb2Val: + 3.10 Cheb2ValwErr: + 3.11 CompCheb2ValwErr: + 3.12 AccCheb2ValwErr: + + + 3.13 Cheb1Der: + 3.14 CompCheb1Der: + 3.15 AccCheb1Der: + 3.16 Cheb1DerwErr: + 3.17 CompCheb1DerwErr: + 3.18 AccCheb1DerwErr: + + 3.19 Cheb2Der: + 3.20 CompCheb2Der: + 3.21 AccCheb2Der: + 3.22 Cheb2DerwErr: + 3.23 CompCheb2DerwErr: + 3.24 AccCheb2DerwErr: + + + 3.25 Cheb1DerK: + 3.26 CompCheb1DerK: + 3.27 AccCheb1DerK: + 3.28 Cheb1DerKwErr: + 3.29 CompCheb1DerKwErr: + 3.30 AccCheb1DerKwErr: + + 3.31 Cheb2DerK: + 3.32 CompCheb2DerK: + 3.33 AccCheb2DerK: + 3.34 Cheb2DerKwErr: + 3.35 CompCheb2DerKwErr: + 3.36 AccCheb2DerKwErr: + +4. Legendre: + + 4.1 LegenVal: + 4.2 CompLegenVal: + 4.3 AccLegenVal: + 4.4 LegenValwErr: + 4.5 CompLegenValwErr: + 4.6 AccLegenValwErr: + + 4.7 LegenDer: + 4.8 CompLegenDer: + 4.9 AccLegenDer: + 4.10 LegenDerwErr: + 4.11 CompLegenDerwErr: + 4.12 AccLegenDerwErr: + + 4.13 LegenDerK: + 4.14 CompLegenDerK: + 4.15 AccLegenDerK: + 4.16 LegenDerwErrK: + 4.17 CompLegenDerKwErr: + 4.18 AccLegenDerKwErr: + +5. Laguerre: + + 5.1 LagueVal: + 5.2 CompLagueVal: + 5.3 AccLagueVal: + 5.4 LagueValwErr: + 5.5 CompLagueValwErr: + 5.6 AccLagueValwErr: + + 5.7 LagueDer: + 5.8 CompLagueDer: + 5.9 AccLagueDer: + 5.10 LagueDerwErr: + 5.11 CompLagueDerwErr: + 5.12 AccLagueDerwErr: + + 5.13 LagueDerK: + 5.14 CompLagueDerK: + 5.15 AccLagueDerK: + 5.16 LagueDerwErrK: + 5.17 CompLagueDerKwErr: + 5.18 AccLagueDerKwErr: + +6. Hermite: + + 6.1 Herm1Val: + 6.2 CompHerm1Val: + 6.3 AccHerm1Val: + 6.4 Herm1ValwErr: + 6.5 CompHerm1ValwErr: + 6.6 AccHerm1ValwErr: + + 6.7 Herm2Val: + 6.8 CompHerm2Val: + 6.9 AccHerm2Val: + 6.10 Herm2ValwErr: + 6.11 CompHerm2ValwErr: + 6.12 AccHerm2ValwErr: + + 6.13 Herm1Der: + 6.14 CompHerm1Der: + 6.15 AccHerm1Der: + 6.16 Herm1DerwErr: + 6.17 CompHerm1DerwErr: + 6.18 AccHerm1DerwErr: + + 6.19 Herm2Der: + 6.20 CompHerm2Der: + 6.21 AccHerm2Der: + 6.22 Herm2DerwErr: + 6.23 CompHerm2DerwErr: + 6.24 AccHerm2DerwErr: + + 6.25 Herm1DerK: + 6.26 CompHerm1DerK: + 6.27 AccHerm1DerK: + 6.28 Herm1DerKwErr: + 6.29 CompHerm1DerKwErr: + 6.30 AccHerm1DerKwErr: + + + 6.31 Herm2DerK: + 6.32 CompHerm2DerK: + 6.33 AccHerm2DerK: + 6.34 Herm2DerKwErr: + 6.35 CompHerm2DerKwErr: + 6.36 AccHerm2DerKwErr: + +%---------------------------------------------------------------------------------------- + +IV. Example + +How to generate the programs for test_example_chebyshev.c (with chebyshev series) is presented: + +gcc -O2 -I ./include -Wall -c example/test_example_chebyshev.c -o example/test_example_chebyshev.o +gcc -O2 -I ./include -Wall -c src/chebyshev_series.c -o example/chebyshev_series.o +gcc -O2 -I ./include -Wall -c src/inline_function.c -o example/inline_function.o +gcc -Wall example/test_example_chebyshev.o example/chebyshev_series.o example/inline_function.o -o example/test_example_chebyshev + +If other orthogonal polynomials can be used, the only difference in compiling is the need to call the code file for that family. +The call to functions of other families of polynomials is analogous, +changing only 'Cheb1' in the name of the function by the five characters corresponding to the family of interest. +Those families dependent on one parameter (two for Jacobi) have a fourth (and fifth) argument(s) for said parameter(s). + +%---------------------------------------------------------------------------------------- + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + diff --git a/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/chebyshev_series.c b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/chebyshev_series.c new file mode 100644 index 000000000..ae704bde0 --- /dev/null +++ b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/chebyshev_series.c @@ -0,0 +1,1725 @@ +/****************************************************************************** +% Set of subroutines and functions to evaluate series of CHEBYSHEV polynomials at the point x, which is in [-1, 1]. +% It allows to evaluate the series and derivatives of it at any point using standard double precision with and without +% error bounds to provide information of the quality of the evaluation. It also allows ACCURATE evaluations using +% a new compensated algorithm. +% +% Licensing: +% +% This code is distributed under the GNU General Public License 3 (GPLv3). +% +% Modified: +% +% 4 November 2016 +% +% Authors: +% +% Roberto Barrio, Peibing Du, Hao Jiang and Sergio Serrano +% +% Algorithm: +% BCS-algorithm with running error bound +% References: +% R. Barrio, J.M. Pe~na, +% Numerical evaluation of the pth derivative of Jacobi series, +% Applied Numerical Mathmetics 43 335-357, (2002). +% +% H. Jiang, R. Barrio, H. Li, X. Liao, L. Cheng, F. Su, +% Accurate evaluation of a polynomial in Chebyshev form +% Applied Mathematics and Computation 217 (23), 9702-9716, (2011). +%*****************************************************************************/ + +#include +#include +#include +#include + +#include "inline.h" +#include "chebyshev_series.h" + +/* Cheb1Val evaluates a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1].*/ +double Cheb1Val(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, t, b1 = 0, b2 = 0; + int i; + xx = 2 * x; + + for (i = n; i >= 1; i--) + { + t = xx * b1 - b2 + P[i]; + b2 = b1; + b1 = t; + } + return x * b1 - b2 + P[0]; +} + +/*CompCheb1Val evaluates a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method.*/ +double CompCheb1Val(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0, res; + dd_real temp1, temp2, temp3; + int i; + xx = 2 * x; + + for (i = n; i >= 1; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[i]); + + b2 = b1; + b1 = temp3.H; + //--------------the compensated part---------------// + err_temp = xx * errb1 - errb2 + (temp1.L + temp2.L + temp3.L); + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(x, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[0]); + //--------------the compensated part---------------// + err_temp = x * errb1 - errb2 + (temp1.L + temp2.L + temp3.L); + res = temp3.H + err_temp; + + return res; +} + +/*AccCheb1Val evaluates a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method.*/ +dd_real AccCheb1Val(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3; + int i; + xx = 2 * x; + + for (i = n; i >= 1; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[i]); + + b2 = b1; + b1 = temp3.H; + //--------------the compensated part---------------// + err_temp = xx * errb1 - errb2 + (temp1.L + temp2.L + temp3.L); + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(x, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[0]); + //--------------the compensated part---------------// + err_temp = x * errb1 - errb2 + (temp1.L + temp2.L + temp3.L); + res = quick_two_sum(temp3.H, err_temp); + + return res; +} + +/*Cheb2Val evaluates a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1]. */ +double Cheb2Val(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, t, b1 = 0, b2 = 0; + int i; + xx = 2 * x; + + for (i = n; i >= 1; i--) + { + t = xx * b1 - b2 + P[i]; + b2 = b1; + b1 = t; + } + return 2 * x * b1 - b2 + P[0]; +} + +/*CompCheb2Val evaluates a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method.*/ +double CompCheb2Val(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0, res; + dd_real temp1, temp2, temp3; + int i; + xx = 2 * x; + + for (i = n; i >= 1; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[i]); + + b2 = b1; + b1 = temp3.H; + //--------------the compensated part---------------// + err_temp = xx * errb1 - errb2 + (temp1.L + temp2.L + temp3.L); + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[0]); + //--------------the compensated part---------------// + err_temp = xx * errb1 - errb2 + (temp1.L + temp2.L + temp3.L); + res = temp3.H + err_temp; + + return res; +} + +/*AccCheb2Val evaluates a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method.*/ +dd_real AccCheb2Val(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3; + int i; + xx = 2 * x; + + for (i = n; i >= 1; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[i]); + + b2 = b1; + b1 = temp3.H; + //--------------the compensated part---------------// + err_temp = xx * errb1 - errb2 + (temp1.L + temp2.L + temp3.L); + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[0]); + //--------------the compensated part---------------// + err_temp = xx * errb1 - errb2 + (temp1.L + temp2.L + temp3.L); + res = quick_two_sum(temp3.H, err_temp); + + return res; +} + +/*Cheb1Der evaluates the first derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1]. */ +double Cheb1Der(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, t, b1 = 0, b2 = 0; + int i; + xx = 2 * x; + + for (i = n - 1; i >= 0; i--) + { + t = xx * b1 - b2 + (i + 1) * P[i + 1]; + b2 = b1; + b1 = t; + } + return b1; +} + +/*CompCheb1Der evaluates the first derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method.*/ +double CompCheb1Der(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0, res; + dd_real temp1, temp2, temp3, temp4; + int i; + xx = 2 * x; + + for (i = n - 1; i >= 0; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_prod(i + 1, P[i + 1]); + temp4 = two_sum(temp2.H, temp3.H); + + b2 = b1; + b1 = temp4.H; + //--------------the compensated part---------------// + err_temp = xx * errb1 - errb2 + (temp1.L + temp2.L + temp3.L + temp4.L); + errb2 = errb1; + errb1 = err_temp; + } + res = b1 + errb1; + + return res; +} + +/*AccCheb1Der evaluates the first derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method.*/ +dd_real AccCheb1Der(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + int i; + xx = 2 * x; + + for (i = n - 1; i >= 0; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_prod(i + 1, P[i + 1]); + temp4 = two_sum(temp2.H, temp3.H); + + b2 = b1; + b1 = temp4.H; + //--------------the compensated part---------------// + err_temp = xx * errb1 - errb2 + (temp1.L + temp2.L + temp3.L + temp4.L); + errb2 = errb1; + errb1 = err_temp; + } + res = quick_two_sum(b1, errb1); + + return res; +} + +/*Cheb2Der evaluates the first derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1]. */ +double Cheb2Der(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double t, b1 = 0, b2 = 0; + double A1, A2; + int i; + double C; + C = 2; + + for (i = n - 1; i >= 0; i--) + { + A1 = (2 * i + 4) * x / (i + 1); + A2 = -1.0 * (i + 4) / (i + 2); + t = A1 * b1 + A2 * b2 + P[i + 1]; + b2 = b1; + b1 = t; + } + return C * b1; +} + +/*CompCheb2Der evaluates the first derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method.*/ +double CompCheb2Der(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0, res; + dd_real temp1, temp2, temp3, temp4; + dd_real Temp, AA1, AA2; + int i; + double C; + C = 2; + + for (i = n - 1; i >= 0; i--) + { + Temp = div_d_d(2 * i + 4, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(-(i + 4), i + 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + 1]); + //--------------the compensated part---------------// + err_temp = AA1.H * errb1 + AA2.H * errb2 + AA1.L * b1 + AA2.L * b2 + (temp1.L + temp2.L + temp3.L + temp4.L); + //------------- the next step---------------------// + b2 = b1; + b1 = temp4.H; + errb2 = errb1; + errb1 = err_temp; + } + res = C * (b1 + errb1); + + return res; +} + +/*AccCheb2Der evaluates the first derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method.*/ +dd_real AccCheb2Der(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + dd_real Temp, AA1, AA2; + int i; + double C; + C = 2; + + for (i = n - 1; i >= 0; i--) + { + Temp = div_d_d(2 * i + 4, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(-(i + 4), i + 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + 1]); + //--------------the compensated part---------------// + err_temp = AA1.H * errb1 + AA2.H * errb2 + AA1.L * b1 + AA2.L * b2 + (temp1.L + temp2.L + temp3.L + temp4.L); + //------------- the next step---------------------// + b2 = b1; + b1 = temp4.H; + errb2 = errb1; + errb1 = err_temp; + } + res = quick_two_sum(C * b1, C * errb1); + + return res; +} + +/*Cheb1DerK evaluates the k-th derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1]. */ +double Cheb1DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double s = 1.0, t, b1 = 0, b2 = 0; + int i; + double j; + if (k == 0) + { + j = Cheb1Val(P, n, x); + return j; + } + + for (i = k - 1; i > 0; i--) + { + s = 2 * s * i; + } + + for (i = n - k; i >= 0; i--) + { + j = 1.0 * i; + t = 2 * (j + k) / (j + 1) * x * b1 - (j + 2 * k) / (j + 2) * b2 + (j + k) * P[i + k]; + b2 = b1; + b1 = t; + } + return s * b1; +} + +/*CompCheb1DerK evaluates the k-th derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method.*/ +double CompCheb1DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double s = 1.0, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0, res; + dd_real temp1, temp2, temp3, temp4, temp5; + dd_real Temp, AA1, AA2; + int i; + if (k == 0) + { + res = CompCheb1Val(P, n, x); + return res; + } + + for (i = k - 1; i > 0; i--) + { + s = 2 * s * i; + } + + for (i = n - k; i >= 0; i--) + { + Temp = div_d_d(2 * i + 2 * k, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(i + 2 * k, -i - 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_prod(i + k, P[i + k]); + temp5 = two_sum(temp3.H, temp4.H); + + Temp.H = AA1.L * b1 + AA2.L * b2; + + b2 = b1; + b1 = temp5.H; + //--------------the compensated part---------------// + err_temp = AA1.H * errb1 + AA2.H * errb2 + (temp1.L + temp2.L + temp3.L + temp4.L + temp5.L + Temp.H); + errb2 = errb1; + errb1 = err_temp; + } + Temp = two_prod(b1, s); + Temp.L = s * errb1 + Temp.L; + res = Temp.H + Temp.L; + + return res; +} + +/*AccCheb1DerK evaluates the k-th derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method.*/ +dd_real AccCheb1DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double s = 1.0, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4, temp5; + dd_real Temp, AA1, AA2; + int i; + if (k == 0) + { + res = AccCheb1Val(P, n, x); + return res; + } + + for (i = k - 1; i > 0; i--) + { + s = 2 * s * i; + } + + for (i = n - k; i >= 0; i--) + { + Temp = div_d_d(2 * i + 2 * k, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(i + 2 * k, -i - 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_prod(i + k, P[i + k]); + temp5 = two_sum(temp3.H, temp4.H); + + Temp.H = AA1.L * b1 + AA2.L * b2; + + b2 = b1; + b1 = temp5.H; + //--------------the compensated part---------------// + err_temp = AA1.H * errb1 + AA2.H * errb2 + (temp1.L + temp2.L + temp3.L + temp4.L + temp5.L + Temp.H); + errb2 = errb1; + errb1 = err_temp; + } + Temp = two_prod(b1, s); + Temp.L = s * errb1 + Temp.L; + res = quick_two_sum(Temp.H, Temp.L); + + return res; +} + +/*Cheb2DerK evaluates the k-th derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1]. */ +double Cheb2DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double t, b1 = 0, b2 = 0; + int i; + double s = 1.0, j; + for (i = k; i > 0; i--) + { + s = 2 * s * i; + } + + for (i = n - k; i >= 0; i--) + { + j = 1.0 * i; + t = 2 * (j + k + 1) / (j + 1) * x * b1 - (j + 2 * k + 2) / (j + 2) * b2 + P[i + k]; + b2 = b1; + b1 = t; + } + return s * b1; +} + +/*CompCheb2DerK evaluates the k-th derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method.*/ +double CompCheb2DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0, res; + dd_real temp1, temp2, temp3, temp4; + dd_real Temp, AA1, AA2; + int i; + double s = 1.0; + for (i = k; i > 0; i--) + { + s = 2 * s * i; + } + + for (i = n - k; i >= 0; i--) + { + Temp = div_d_d(2 * i + 2 * k + 2, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(i + 2 * k + 2, -i - 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + k]); + + Temp.H = AA1.L * b1 + AA2.L * b2; + + b2 = b1; + b1 = temp4.H; + //--------------the compensated part---------------// + err_temp = AA1.H * errb1 + AA2.H * errb2 + (temp1.L + temp2.L + temp3.L + temp4.L + Temp.H); + //------------- the next step---------------------// + errb2 = errb1; + errb1 = err_temp; + } + Temp = two_prod(b1, s); + Temp.L = s * errb1 + Temp.L; + res = Temp.H + Temp.L; + + return res; +} + +/*AccCheb2DerK evaluates the k-th derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method.*/ +dd_real AccCheb2DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + dd_real Temp, AA1, AA2; + int i; + double s = 1.0; + for (i = k; i > 0; i--) + { + s = 2 * s * i; + } + + for (i = n - k; i >= 0; i--) + { + Temp = div_d_d(2 * i + 2 * k + 2, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(i + 2 * k + 2, -i - 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + k]); + + Temp.H = AA1.L * b1 + AA2.L * b2; + + b2 = b1; + b1 = temp4.H; + //--------------the compensated part---------------// + err_temp = AA1.H * errb1 + AA2.H * errb2 + (temp1.L + temp2.L + temp3.L + temp4.L + Temp.H); + //------------- the next step---------------------// + errb2 = errb1; + errb1 = err_temp; + } + Temp = two_prod(b1, s); + Temp.L = s * errb1 + Temp.L; + res = quick_two_sum(Temp.H, Temp.L); + + return res; +} + +/*Cheb1ValwErr evaluates a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], together with running error bound. */ +double Cheb1ValwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, t, b1 = 0, b2 = 0; + double abst, absb1 = 0; + int i; + xx = 2 * x; + double absxx; + absxx = fabs(xx); + int na, nb; + na = 0; + nb = 0; + + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n; i >= 1; i--) + { + t = xx * b1 - b2 + P[i]; + abst = fabs(t); + + errz = errz1 * absxx + errz2 + fabs(P[i]); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + t = x * b1 - b2 + P[0]; + abst = fabs(t); + + errz = errz1 * fabs(x) + errz2 + fabs(P[0]); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + *(runerrbound) = (errz1 - (2 + na) * abst) * unit; + + return b1; +} + +/*Cheb2ValwErr evaluates a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], together with running error bound. */ +double Cheb2ValwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, t, b1 = 0, b2 = 0; + double abst = 0, absb1 = 0; + int i; + xx = 2 * x; + double absxx; + absxx = fabs(xx); + int na, nb; + na = 0; + nb = 0; + + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n; i >= 0; i--) + { + t = xx * b1 - b2 + P[i]; + abst = fabs(t); + + errz = errz1 * absxx + errz2 + fabs(P[i]); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + *(runerrbound) = (errz1 - (2 + na) * abst) * unit; + + return b1; +} + +/*Cheb1DerwErr evaluates the first derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], together with running error bound. */ +double Cheb1DerwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + + double xx, t, b1 = 0, b2 = 0; + double abst = 0, absb1 = 0; + int i; + xx = 2 * x; + double absxx; + absxx = fabs(xx); + int na, nb, nc; + na = 0; + nb = 0; + nc = 0; + + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - 1; i >= 0; i--) + { + t = xx * b1 - b2 + (i + 1) * P[i + 1]; + abst = fabs(t); + + errz = errz1 * absxx + errz2 + (nc + 2) * (i + 1) * fabs(P[i + 1]); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + *(runerrbound) = (errz1 - (1 + na) * abst) * unit; + + return b1; +} + +/*Cheb2DerwErr evaluates the first derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], together with running error bound. */ +double Cheb2DerwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double t, b1 = 0, b2 = 0; + double A1, A2, Atemp; + double C; + C = 2; + + double abst = 0, absb1 = 0; + int i; + int na, nb, nc; + na = 2; + nb = 1; + nc = 0; + + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - 1; i >= 0; i--) + { + A1 = (2 * i + 4) * x / (i + 1); + Atemp = 1.0 * (i + 4) / (i + 2); + A2 = -Atemp; + t = A1 * b1 + A2 * b2 + P[i + 1]; + + abst = fabs(t); + + errz = errz1 * fabs(A1) + errz2 * Atemp + (nc + 2) * fabs(P[i + 1]); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + *(runerrbound) = (errz1 - (1 + na) * abst) * unit * C; + + return C * b1; +} + +/*Cheb1DerKwErr evaluates the k-th derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], together with running error bound. */ +double Cheb1DerKwErr(double *P, unsigned int n, double x, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double s = 1.0, t, b1 = 0, b2 = 0, A1, A2; + int i; + double j, Atemp; + if (k == 0) + { + j = Cheb1ValwErr(P, n, x, runerrbound); + return j; + } + + for (i = k - 1; i > 0; i--) + { + s = 2 * s * i; + } + double abst = 0, absb1 = 0; + int na, nb, nc; + na = 2; + nb = 1; + nc = 0; + if (k == 1) + { + na = 0; + nb = 0; + } + + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + j = 1.0 * i; + A1 = 2 * (j + k) / (j + 1) * x; + Atemp = fabs(A1); + A2 = (j + 2 * k) / (j + 2); + + t = A1 * b1 - A2 * b2 + (j + k) * P[i + k]; + abst = fabs(t); + + errz = errz1 * Atemp + errz2 * A2 + (nc + 2) * (j + k) * fabs(P[i + k]); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + *(runerrbound) = (errz1 - (1 + na) * abst) * unit * s; + + return s * b1; +} + +/*Cheb2DerKwErr evaluates the k-th derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], together with running error bound. */ +double Cheb2DerKwErr(double *P, unsigned int n, double x, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double t, b1 = 0, b2 = 0, A1, A2, Atemp; + int i; + double s = 1.0, j; + for (i = k; i > 0; i--) + { + s = 2 * s * i; + } + double abst = 0, absb1 = 0; + int na, nb, nc; + na = 2; + nb = 1; + nc = 0; + if (k == 0) + { + na = 0; + nb = 0; + } + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + j = 1.0 * i; + + A1 = 2 * (j + k + 1) / (j + 1) * x; + Atemp = (j + 2 * k + 2) / (j + 2); + A2 = -Atemp; + t = A1 * b1 + A2 * b2 + P[i + k]; + + abst = fabs(t); + + errz = errz1 * fabs(A1) + errz2 * Atemp + (nc + 2) * fabs(P[i + k]); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + *(runerrbound) = (errz1 - (1 + na) * abst) * unit * s; + + return s * b1; +} + +/*CompCheb1ValwErr evaluates a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method, together with the running error bound.*/ +double CompCheb1ValwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double res, err_temp, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3; + int i; + xx = 2 * x; + + double abst = 0, absb1 = 0; + double absxx; + absxx = fabs(xx); + int na, nb, ne; + na = 0; + nb = 0; + ne = 2; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n; i >= 1; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[i]); + + b2 = b1; + b1 = temp3.H; + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L; + err_temp = xx * errb1 - errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * absxx + errz2 + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + temp1 = two_prod(x, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[0]); + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L; + err_temp = x * errb1 - errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(x) + errz2 + (ne + 1) * fabs(err_P); + + errz1 = errz + (na + 3) * abst; + + res = temp3.H + err_temp; + *(runerrbound) = ((errz1 - (2 + na) * abst) * unit + fabs(err_temp - (res - temp3.H))) / (1 - unit * 2); + + return res; +} + +/*CompCheb2ValwErr evaluates a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method, together with the running error bound.*/ +double CompCheb2ValwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double res, err_temp, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3; + int i; + xx = 2 * x; + + double abst = 0, absb1 = 0; + double absxx; + absxx = fabs(xx); + int na, nb, ne; + na = 0; + nb = 0; + ne = 2; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n; i >= 1; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[i]); + + b2 = b1; + b1 = temp3.H; + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L; + err_temp = xx * errb1 - errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * absxx + errz2 + (ne + 3) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[0]); + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L; + err_temp = xx * errb1 - errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * absxx + errz2 + (ne + 3) * fabs(err_P); + + errz1 = errz + (na + 3) * abst; + + res = temp3.H + err_temp; + *(runerrbound) = ((errz1 - (2 + na) * abst) * unit + fabs(err_temp - (res - temp3.H))) / (1 - unit * 2); + + return res; +} + +/*CompCheb1DerwErr evaluates the first derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method, together with running error bound.*/ + +double CompCheb1DerwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double res, err_temp, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3, temp4; + int i; + xx = 2 * x; + + double abst = 0, absb1 = 0; + double absxx; + absxx = fabs(xx); + int na, nb, ne; + na = 0; + nb = 0; + ne = 3; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - 1; i >= 0; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_prod(i + 1, P[i + 1]); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, -b2); + + b2 = b1; + b1 = temp4.H; + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = xx * errb1 - errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * absxx + errz2 + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + res = b1 + errb1; + *(runerrbound) = ((errz1 - (1 + na) * abst) * unit + fabs(errb1 - (res - b1))) / (1 - unit * 2); + + return res; +} + +/*CompCheb2DerwErr evaluates the first derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method.,together with the running error bound*/ +double CompCheb2DerwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double res, err_temp, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3, temp4; + dd_real Temp, AA1, AA2; + int i; + double C; + C = 2; + + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 6; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - 1; i >= 0; i--) + { + Temp = div_d_d(2 * i + 4, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(-(i + 4), i + 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + 1]); + //--------------the compensated part---------------// + err_P = AA1.L * b1 + AA2.L * b2 + temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = AA1.H * errb1 + AA2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(AA1.H) + errz2 * fabs(AA2.H) + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //------------- the next step---------------------// + b2 = b1; + b1 = temp4.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + res = C * (b1 + errb1); + *(runerrbound) = ((errz1 - (1 + na) * abst) * unit * C + fabs(C * errb1 - (res - C * b1))) / (1 - unit * 2); + + return res; +} + +/*CompCheb1DerKwErr evaluates the k-th derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method, together with running error bound.*/ +double CompCheb1DerKwErr(double *P, unsigned int n, double x, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double s = 1.0, b1 = 0, b2 = 0; + double res, err_temp, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3, temp4, temp5; + dd_real Temp, AA1, AA2; + int i; + if (k == 0) + { + res = CompCheb1ValwErr(P, n, x, runerrbound); + return res; + } + for (i = k - 1; i > 0; i--) + { + s = 2 * s * i; + } + + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 7; + if (k == 1) + { + na = 0; + nb = 0; + ne = 3; + } + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + Temp = div_d_d(2 * i + 2 * k, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(i + 2 * k, -i - 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_prod(i + k, P[i + k]); + temp5 = two_sum(temp3.H, temp4.H); + + Temp.H = AA1.L * b1 + AA2.L * b2; + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L + temp4.L + temp5.L + Temp.H; + err_temp = AA1.H * errb1 + AA2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(AA1.H) + fabs(AA2.H) * errz2 + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //------------- the next step---------------------// + b2 = b1; + b1 = temp5.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + Temp = two_prod(b1, s); + Temp.L = s * errb1 + Temp.L; + res = Temp.H + Temp.L; + *(runerrbound) = ((errz1 - (2 + na) * abst) * unit * s + fabs(Temp.L - (res - Temp.H))) / (1 - 3 * unit); + + return res; +} + +/*CompCheb2DerKwErr evaluates the k-th derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method.,together with the running error bound*/ +double CompCheb2DerKwErr(double *P, unsigned int n, double x, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double res, err_temp, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3, temp4; + dd_real Temp, AA1, AA2; + int i; + double s = 1.0; + for (i = k; i > 0; i--) + { + s = 2 * s * i; + } + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 6; + if (k == 0) + { + na = 0; + nb = 0; + ne = 2; + } + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + Temp = div_d_d(2 * i + 2 * k + 2, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(i + 2 * k + 2, -i - 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + k]); + + Temp.H = AA1.L * b1 + AA2.L * b2; + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L + temp4.L + Temp.H; + err_temp = AA1.H * errb1 + AA2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(AA1.H) + errz2 * fabs(AA2.H) + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //------------- the next step---------------------// + b2 = b1; + b1 = temp4.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + Temp = two_prod(b1, s); + Temp.L = s * errb1 + Temp.L; + res = Temp.H + Temp.L; + *(runerrbound) = ((errz1 - (2 + na) * abst) * unit * s + fabs(Temp.L - (res - Temp.H))) / (1 - unit * 2); + + return res; +} + +/*AccCheb1ValwErr evaluates a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method, together with the running error bound.*/ +dd_real AccCheb1ValwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3; + int i; + xx = 2 * x; + double abst = 0, absb1 = 0; + double absxx; + absxx = fabs(xx); + int na, nb, ne; + na = 0; + nb = 0; + ne = 2; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n; i >= 1; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[i]); + + b2 = b1; + b1 = temp3.H; + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L; + err_temp = xx * errb1 - errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * absxx + errz2 + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + temp1 = two_prod(x, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[0]); + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L; + err_temp = x * errb1 - errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(x) + errz2 + (ne + 1) * fabs(err_P); + errz1 = errz + (na + 3) * abst; + + res = quick_two_sum(temp3.H, err_temp); + *(runerrbound) = (errz1 - (2 + na) * abst) * unit; + + return res; +} + +/*AccCheb2ValwErr evaluates a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method, together with the running error bound.*/ +dd_real AccCheb2ValwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3; + int i; + xx = 2 * x; + double abst = 0, absb1 = 0; + double absxx; + absxx = fabs(xx); + int na, nb, ne; + na = 0; + nb = 0; + ne = 2; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n; i >= 1; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[i]); + + b2 = b1; + b1 = temp3.H; + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L; + err_temp = xx * errb1 - errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * absxx + errz2 + (ne + 3) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + temp1 = two_prod(xx, b1); + temp2 = two_sum(temp1.H, -b2); + temp3 = two_sum(temp2.H, P[0]); + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L; + err_temp = xx * errb1 - errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * absxx + errz2 + (ne + 3) * fabs(err_P); + errz1 = errz + (na + 3) * abst; + + res = quick_two_sum(temp3.H, err_temp); + *(runerrbound) = (errz1 - (2 + na) * abst) * unit; + + return res; +} + +/*AccCheb1DerwErr evaluates the first derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method, together with running error bound.*/ +dd_real AccCheb1DerwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double xx, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + int i; + xx = 2 * x; + double abst = 0, absb1 = 0; + double absxx; + absxx = fabs(xx); + int na, nb, ne; + na = 0; + nb = 0; + ne = 3; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - 1; i >= 0; i--) + { + temp1 = two_prod(xx, b1); + temp2 = two_prod(i + 1, P[i + 1]); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, -b2); + + b2 = b1; + b1 = temp4.H; + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = xx * errb1 - errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * absxx + errz2 + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + res = quick_two_sum(b1, errb1); + *(runerrbound) = (errz1 - (1 + na) * abst) * unit; + + return res; +} + +/*AccCheb2DerwErr evaluates the first derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method.,together with the running error bound*/ +dd_real AccCheb2DerwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + dd_real Temp, AA1, AA2; + int i; + double C; + C = 2; + + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 6; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - 1; i >= 0; i--) + { + Temp = div_d_d(2 * i + 4, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(-(i + 4), i + 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + 1]); + //--------------the compensated part---------------// + err_P = AA1.L * b1 + AA2.L * b2 + temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = AA1.H * errb1 + AA2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(AA1.H) + errz2 * fabs(AA2.H) + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //------------- the next step---------------------// + b2 = b1; + b1 = temp4.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + res = quick_two_sum(C * b1, C * errb1); + *(runerrbound) = (errz1 - (1 + na) * abst) * unit * C; + + return res; +} + +/*AccCheb1DerKwErr evaluates the k-th derivative of a series of Chebyshev polynomial of the first kind at the point x, which is in [-1, 1], with compensated method, together with running error bound.*/ +dd_real AccCheb1DerKwErr(double *P, unsigned int n, double x, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double s = 1.0, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4, temp5; + dd_real Temp, AA1, AA2; + int i; + if (k == 0) + { + res = AccCheb1ValwErr(P, n, x, runerrbound); + return res; + } + for (i = k - 1; i > 0; i--) + { + s = 2 * s * i; + } + + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 7; + if (k == 1) + { + na = 0; + nb = 0; + ne = 3; + } + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + Temp = div_d_d(2 * i + 2 * k, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(i + 2 * k, -i - 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_prod(i + k, P[i + k]); + temp5 = two_sum(temp3.H, temp4.H); + + Temp.H = AA1.L * b1 + AA2.L * b2; + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L + temp4.L + temp5.L + Temp.H; + err_temp = AA1.H * errb1 + AA2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(AA1.H) + fabs(AA2.H) * errz2 + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //------------- the next step---------------------// + b2 = b1; + b1 = temp5.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + Temp = two_prod(b1, s); + Temp.L = s * errb1 + Temp.L; + res = quick_two_sum(Temp.H, Temp.L); + *(runerrbound) = (errz1 - (2 + na) * abst) * unit * s; + + return res; +} + +/*AccCheb2DerKwErr evaluates the k-th derivative of a series of Chebyshev polynomial of the second kind at the point x, which is in [-1, 1], with compensated method.,together with the running error bound*/ +dd_real AccCheb2DerKwErr(double *P, unsigned int n, double x, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + dd_real Temp, AA1, AA2; + int i; + double s = 1.0; + for (i = k; i > 0; i--) + { + s = 2 * s * i; + } + + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 6; + if (k == 0) + { + na = 0; + nb = 0; + ne = 2; + } + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + Temp = div_d_d(2 * i + 2 * k + 2, i + 1); + AA1 = two_prod(Temp.H, x); + AA1.L = x * Temp.L + AA1.L; + + AA2 = div_d_d(i + 2 * k + 2, -i - 2); + + temp1 = two_prod(AA1.H, b1); + temp2 = two_prod(AA2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + k]); + + Temp.H = AA1.L * b1 + AA2.L * b2; + //--------------the compensated part---------------// + err_P = temp1.L + temp2.L + temp3.L + temp4.L + Temp.H; + err_temp = AA1.H * errb1 + AA2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(AA1.H) + errz2 * fabs(AA2.H) + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //------------- the next step---------------------// + b2 = b1; + b1 = temp4.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + Temp = two_prod(b1, s); + Temp.L = s * errb1 + Temp.L; + res = quick_two_sum(Temp.H, Temp.L); + *(runerrbound) = (errz1 - (2 + na) * abst) * unit * s; + + return res; +} diff --git a/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/gegenbauer_series.c b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/gegenbauer_series.c new file mode 100644 index 000000000..d425fa302 --- /dev/null +++ b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/gegenbauer_series.c @@ -0,0 +1,961 @@ +/****************************************************************************** +% Set of subroutines and functions to evaluate series of GEGENBAUER polynomials at the point x, which is in [-1, 1]. +% It allows to evaluate the series and derivatives of it at any point using standard double precision with and without +% error bounds to provide information of the quality of the evaluation. It also allows ACCURATE evaluations using +% a new compensated algorithm. +% +% Licensing: +% +% This code is distributed under the GNU General Public License 3 (GPLv3). +% +% Modified: +% +% 6 November 2016 +% +% Authors: +% +% Roberto Barrio, Peibing Du, Hao Jiang and Sergio Serrano +% +% Algorithm: +% BCS-algorithm with running error bound +% References: +% R. Barrio, J.M. Pe~na, +% Numerical evaluation of the pth derivative of Jacobi series, +% Applied Numerical Mathmetics 43 335-357, (2002). +% +% H. Jiang, R. Barrio, H. Li, X. Liao, L. Cheng, F. Su, +% Accurate evaluation of a polynomial in Chebyshev form +% Applied Mathematics and Computation 217 (23), 9702-9716, (2011). +%*****************************************************************************/ + +#include +#include +#include +#include + +#include "inline.h" +#include "gegenbauer_series.h" + +/*The three-term recurrence coefficients of gegenbauer polynomial */ +void RecurCoefGegen(double n, double lambda, double *A, double *C) +{ + int i; + double j; + for (i = 1; i <= n + 2; i++) + { + j = 1.0 * i; + *(A + i - 1) = 2 * (j + lambda - 1) / j; + *(C + i - 1) = (j + 2 * lambda - 2) / j; + } +} + +void RecurCoefGegen_DD(double n, double lambda, dd_real *A, dd_real *C) +{ + int i; + double j; + dd_real s0, s1, s2, s3; + + for (i = 1; i <= n + 2; i++) + { + j = 1.0 * i; + s0 = two_sum(j - 1, lambda); + s1 = prod_dd_d(s0, 2); + *(A + i - 1) = div_dd_d(s1, j); + s2 = two_prod(2, lambda); + s3 = add_dd_d(s2, j - 2); + *(C + i - 1) = div_dd_d(s3, j); + } +} + +/*GegenVal evaluates a series of Gegenbauer polynomial at the point x, which is in [-1, 1] */ +double GegenVal(double *P, unsigned int n, double x, double lambda) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double t, b1 = 0, b2 = 0; + int j; + + double *A = (double *)malloc(sizeof(double) * (n + 2)); + double *C = (double *)malloc(sizeof(double) * (n + 2)); + + RecurCoefGegen(n, lambda, A, C); + + for (j = n; j >= 0; j--) + { + t = *(A + j) * x * b1 - *(C + j + 1) * b2 + P[j]; + b2 = b1; + b1 = t; + } + free(A); + free(C); + return b1; +} + +/*CompGegenVal evaluates a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method */ +double CompGegenVal(double *P, unsigned int n, double x, double lambda) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0, res; + double err_temp, err_temp1, err_temp2, err_temp3, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3, temp4, temp5; + int j; + + dd_real *A = (dd_real *)malloc(sizeof(dd_real) * (n + 2)); + dd_real *C = (dd_real *)malloc(sizeof(dd_real) * (n + 2)); + + RecurCoefGegen_DD(n, lambda, A, C); + + for (j = n; j >= 0; j--) + { + temp1 = two_prod((A + j)->H, x); + temp2 = two_prod(temp1.H, b1); + temp3 = two_prod((C + j + 1)->H, b2); + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[j]); + //--------------the compensated part---------------// + err_temp1 = temp1.L * b1 + temp2.L; + err_temp2 = ((A + j)->L) * x * b1 - ((C + j + 1)->L) * b2; + err_temp3 = err_temp1 - temp3.L + temp4.L + temp5.L + err_temp2; + err_temp = temp1.H * errb1 - ((C + j + 1)->H) * errb2 + err_temp3; + //--------------the next iteration-----------------// + b2 = b1; + b1 = temp5.H; + errb2 = errb1; + errb1 = err_temp; + } + res = b1 + errb1; + free(A); + free(C); + + return res; +} + +/*AccGegenVal evaluates a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method */ +dd_real AccGegenVal(double *P, unsigned int n, double x, double lambda) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0; + double err_temp, err_temp1, err_temp2, err_temp3, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4, temp5; + int j; + + dd_real *A = (dd_real *)malloc(sizeof(dd_real) * (n + 2)); + dd_real *C = (dd_real *)malloc(sizeof(dd_real) * (n + 2)); + + RecurCoefGegen_DD(n, lambda, A, C); + + for (j = n; j >= 0; j--) + { + temp1 = two_prod((A + j)->H, x); + temp2 = two_prod(temp1.H, b1); + temp3 = two_prod((C + j + 1)->H, b2); + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[j]); + //--------------the compensated part---------------// + err_temp1 = temp1.L * b1 + temp2.L; + err_temp2 = ((A + j)->L) * x * b1 - ((C + j + 1)->L) * b2; + err_temp3 = err_temp1 - temp3.L + temp4.L + temp5.L + err_temp2; + err_temp = temp1.H * errb1 - ((C + j + 1)->H) * errb2 + err_temp3; + //--------------the next iteration-----------------// + b2 = b1; + b1 = temp5.H; + errb2 = errb1; + errb1 = err_temp; + } + res = quick_two_sum(b1, errb1); + free(A); + free(C); + + return res; +} + +/*GegenDer evaluates the first derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1] */ +double GegenDer(double *P, unsigned int n, double x, double lambda) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double t, b1 = 0, b2 = 0; + double A1, A2; + int i; + double j; + double C = 2 * lambda; + + for (i = n - 1; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + A1 = 2 * (j + 1 + lambda) * x / (j + 1); + A2 = -(j + 2 * lambda + 2) / (j + 2); + //--------------iteration------------------------------------// + t = A1 * b1 + A2 * b2 + P[i + 1]; + b2 = b1; + b1 = t; + } + return C * b1; +} + +/*CompGegenDer evaluates the first derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method */ +double CompGegenDer(double *P, unsigned int n, double x, double lambda) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0, temp, err_temp, errb1 = 0, errb2 = 0, res; + dd_real temp1, temp2, temp3, temp4; + dd_real A1, A2; + dd_real s0, s1, s2; + int i; + double j; + double C; + C = 2 * lambda; + + for (i = n - 1; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + s0 = two_sum(2 * j + 2, 2 * lambda); + s1 = prod_dd_d(s0, x); + A1 = div_dd_d(s1, j + 1); + s2 = two_sum(C, j + 2); + A2 = div_dd_d(s2, -j - 2); + //--------------iteration------------------------------------// + temp1 = two_prod(A1.H, b1); + temp2 = two_prod(A2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + 1]); + temp = temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = A1.L * b1 + A2.L * b2 + A1.H * errb1 + A2.H * errb2 + temp; + + b2 = b1; + b1 = temp4.H; + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(C, b1); + err_temp = C * errb1 + temp1.L; + res = temp1.H + err_temp; + + return res; +} + +/*AccGegenDer evaluates the first derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method */ +dd_real AccGegenDer(double *P, unsigned int n, double x, double lambda) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0, temp, err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + dd_real A1, A2; + dd_real s0, s1, s2; + int i; + double j; + double C; + C = 2 * lambda; + + for (i = n - 1; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + s0 = two_sum(2 * j + 2, 2 * lambda); + s1 = prod_dd_d(s0, x); + A1 = div_dd_d(s1, j + 1); + s2 = two_sum(C, j + 2); + A2 = div_dd_d(s2, -j - 2); + //--------------iteration-----------------------------------// + temp1 = two_prod(A1.H, b1); + temp2 = two_prod(A2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + 1]); + temp = temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = A1.L * b1 + A2.L * b2 + A1.H * errb1 + A2.H * errb2 + temp; + + b2 = b1; + b1 = temp4.H; + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(C, b1); + err_temp = C * errb1 + temp1.L; + res = quick_two_sum(temp1.H, err_temp); + + return res; +} + +/*GegenDerK evaluates the k-th derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1] */ +double GegenDerK(double *P, unsigned int n, double x, double lambda, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double s = 1.0, t, b1 = 0, b2 = 0; + double A1, A2; + int i; + double j; + for (i = 1; i <= k; i++) + { + s = 2 * s * (lambda + i - 1); + } + + for (i = n - k; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + A1 = 2 * (j + k + lambda) * x / (j + 1); + A2 = -(j + 2 * lambda + 2 * k) / (j + 2); + //--------------iteration-----------------------------------// + t = A1 * b1 + A2 * b2 + P[i + k]; + + b2 = b1; + b1 = t; + } + return s * b1; +} + +/*CompGegenDerK evaluates the k-th derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method */ +double CompGegenDerK(double *P, unsigned int n, double x, double lambda, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0, err_temp, errb1 = 0, errb2 = 0, res; + dd_real temp1, temp2, temp3, temp4; + dd_real C, Ctemp, A1, A2; + C.H = 1.0; + C.L = 0; + dd_real s0, s1, s2; + int i; + double j; + for (i = 1; i <= k; i++) + { + Ctemp = two_sum(lambda, i - 1); + C = prod_dd_dd(C, Ctemp); + C.H = 2 * C.H; + C.L = 2 * C.L; + } + + for (i = n - k; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + s0 = two_sum(2 * j + 2 * k, 2 * lambda); + s1 = prod_dd_d(s0, x); + A1 = div_dd_d(s1, j + 1); + s2 = two_sum(2 * lambda, j + 2 * k); + A2 = div_dd_d(s2, -j - 2); + //--------------iteration-----------------------------------// + temp1 = two_prod(A1.H, b1); + temp2 = two_prod(A2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + k]); + err_temp = A1.L * b1 + A2.L * b2 + A1.H * errb1 + A2.H * errb2 + temp1.L + temp2.L + temp3.L + temp4.L; + + b2 = b1; + b1 = temp4.H; + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(C.H, b1); + temp1.L = C.H * errb1 + temp1.L + C.L * b1; + res = temp1.H + temp1.L; + + return res; +} + +/*AccGegenDerK evaluates the k-th derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method */ +dd_real AccGegenDerK(double *P, unsigned int n, double x, double lambda, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0, err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + dd_real C, Ctemp, A1, A2; + C.H = 1.0; + C.L = 0; + dd_real s0, s1, s2; + int i; + double j; + for (i = 1; i <= k; i++) + { + Ctemp = two_sum(lambda, i - 1); + C = prod_dd_dd(C, Ctemp); + C.H = 2 * C.H; + C.L = 2 * C.L; + } + + for (i = n - k; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + s0 = two_sum(2 * j + 2 * k, 2 * lambda); + s1 = prod_dd_d(s0, x); + A1 = div_dd_d(s1, j + 1); + s2 = two_sum(2 * lambda, j + 2 * k); + A2 = div_dd_d(s2, -j - 2); + //--------------iteration-----------------------------------// + temp1 = two_prod(A1.H, b1); + temp2 = two_prod(A2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + k]); + err_temp = A1.L * b1 + A2.L * b2 + A1.H * errb1 + A2.H * errb2 + temp1.L + temp2.L + temp3.L + temp4.L; + + b2 = b1; + b1 = temp4.H; + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(C.H, b1); + temp1.L = C.H * errb1 + temp1.L + C.L * b1; + res = quick_two_sum(temp1.H, temp1.L); + + return res; +} + +/*GegenValwErr evaluates a series of Gegenbauer polynomial at the point x, which is in [-1, 1], and performs a running-error bound */ +double GegenValwErr(double *P, unsigned int n, double x, double lambda, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double t, b1 = 0, b2 = 0; + int j; + double abst = 0, absb1 = 0; + int na, nb; + na = 3; + nb = 2; + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + double *A = (double *)malloc(sizeof(double) * (n + 2)); + double *C = (double *)malloc(sizeof(double) * (n + 2)); + + RecurCoefGegen(n, lambda, A, C); + + for (j = n; j >= 0; j--) + { + t = *(A + j) * x * b1 - *(C + j + 1) * b2 + P[j]; + abst = fabs(t); + + errz = errz1 * fabs(*(A + j) * x) + errz2 * fabs(*(C + j + 1)) + fabs(P[j]); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + free(A); + free(C); + *(runerrbound) = (errz1 - (2 + na) * abst) * unit; + + return b1; +} + +/*GegenDerwErr evaluates the first derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1], and performs a running-error bound */ +double GegenDerwErr(double *P, unsigned int n, double x, double lambda, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double t, b1 = 0, b2 = 0; + double A1, A2; + int i; + double j; + double abst = 0, absb1 = 0; + int na, nb, nc; + na = 3; + nb = 2; + nc = 0; + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + double C; + C = 2 * lambda; + + for (i = n - 1; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + A1 = 2 * (j + 1 + lambda) * x / (j + 1); + A2 = -(j + 2 * lambda + 2) / (j + 2); + //--------------iteration-----------------------------------// + t = A1 * b1 + A2 * b2 + P[i + 1]; + + abst = fabs(t); + + errz = errz1 * fabs(A1) + errz2 * fabs(A2) + (nc + 2) * fabs(P[i + 1]); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + *(runerrbound) = (errz1 - (1 + na) * abst) * unit * C; + return C * b1; +} + +/*GegenDerKwErr evaluates the k-th derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1], and performs a running-error bound */ +double GegenDerKwErr(double *P, unsigned int n, double x, double lambda, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double s = 1.0, t, b1 = 0, b2 = 0; + double A1, A2; + int i; + double j; + for (i = 1; i <= k; i++) + { + s = 2 * s * (lambda + i - 1); + } + double abst = 0, absb1 = 0; + int na, nb, nc; + na = 3; + nb = 2; + nc = 0; + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + A1 = 2 * (j + k + lambda) * x / (j + 1); + A2 = -(j + 2 * lambda + 2 * k) / (j + 2); + //--------------iteration-----------------------------------// + t = A1 * b1 + A2 * b2 + P[i + k]; + + abst = fabs(t); + errz = errz1 * fabs(A1) + errz2 * fabs(A2) + (nc + 2) * fabs(P[i + k]); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + *(runerrbound) = (errz1 - (1 + na) * abst) * unit * s; + return s * b1; +} + +/*CompGegenValwErr evaluates a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +double CompGegenValwErr(double *P, unsigned int n, double x, double lambda, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0; + double res, err_temp, err_temp1, err_temp2, err_temp3, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3, temp4, temp5; + int j; + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 3; + nb = 2; + ne = 8; + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + dd_real *A = (dd_real *)malloc(sizeof(dd_real) * (n + 2)); + dd_real *C = (dd_real *)malloc(sizeof(dd_real) * (n + 2)); + + RecurCoefGegen_DD(n, lambda, A, C); + + for (j = n; j >= 0; j--) + { + temp1 = two_prod((A + j)->H, x); + temp2 = two_prod(temp1.H, b1); + temp3 = two_prod((C + j + 1)->H, b2); + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[j]); + //--------------the compensated part---------------// + err_temp1 = temp1.L * b1 + temp2.L; + err_temp2 = ((A + j)->L) * x * b1 - ((C + j + 1)->L) * b2; + err_temp3 = err_temp1 - temp3.L + temp4.L + temp5.L + err_temp2; + err_temp = temp1.H * errb1 - ((C + j + 1)->H) * errb2 + err_temp3; + //--------------the running error bound-----------// + abst = fabs(err_temp); + errz = errz1 * fabs(temp1.H) + errz2 * fabs((C + j + 1)->H) + (ne + 1) * fabs(err_temp3); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //--------------the next iteration-----------------// + b2 = b1; + b1 = temp5.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + res = b1 + errb1; + *(runerrbound) = ((errz1 - (2 + na) * abst) * unit + fabs(errb1 - (res - b1))) / (1 - unit * 2); + free(A); + free(C); + + return res; +} + +/*CompGegenDerwErr evaluates the first derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +double CompGegenDerwErr(double *P, unsigned int n, double x, double lambda, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0; + double res, err_temp, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3, temp4; + dd_real A1, A2; + dd_real s0, s1, s2; + int i; + double j; + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 3; + nb = 2; + ne = 6; + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + double C; + C = 2 * lambda; + + for (i = n - 1; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + s0 = two_sum(2 * j + 2, 2 * lambda); + s1 = prod_dd_d(s0, x); + A1 = div_dd_d(s1, j + 1); + s2 = two_sum(C, j + 2); + A2 = div_dd_d(s2, -j - 2); + //--------------iteration-----------------------------------// + temp1 = two_prod(A1.H, b1); + temp2 = two_prod(A2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + 1]); + //--------------the compensated part------------------------// + err_P = A1.L * b1 + A2.L * b2 + temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = A1.H * errb1 + A2.H * errb2 + err_P; + //--------------the runninge error bound-------------------// + abst = fabs(err_temp); + errz = errz1 * fabs(A1.H) + errz2 * fabs(A2.H) + (ne + 1) * fabs(err_P); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = temp4.H; + errb2 = errb1; + errb1 = err_temp; + errztemp = errz; + absb1 = abst; + } + temp1 = two_prod(C, b1); + res = temp1.H + C * errb1 + temp1.L; + *(runerrbound) = ((errz1 - (1 + na) * abst) * unit * C + fabs(C * errb1 + temp1.L - (res - temp1.H))) / (1 - unit * 2); + + return res; +} + +/*CompGegenDerKwErr evaluates the k-th derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +double CompGegenDerKwErr(double *P, unsigned int n, double x, double lambda, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double res, b1 = 0, b2 = 0, err_temp, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3, temp4; + dd_real C, Ctemp, A1, A2; + dd_real s0, s1, s2; + int i; + double j; + C.H = 1.0; + C.L = 0; + for (i = 1; i <= k; i++) + { + Ctemp = two_sum(lambda, i - 1); + C = prod_dd_dd(C, Ctemp); + C.H = 2 * C.H; + C.L = 2 * C.L; + } + + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 3; + nb = 2; + ne = 6; + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + s0 = two_sum(2 * j + 2 * k, 2 * lambda); + s1 = prod_dd_d(s0, x); + A1 = div_dd_d(s1, j + 1); + s2 = two_sum(2 * lambda, j + 2 * k); + A2 = div_dd_d(s2, -j - 2); + //--------------iteration-----------------------------------// + temp1 = two_prod(A1.H, b1); + temp2 = two_prod(A2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + k]); + //--------------the compensated part------------------------// + err_P = A1.L * b1 + A2.L * b2 + temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = A1.H * errb1 + A2.H * errb2 + err_P; + //--------------the runninge error bound-------------------// + abst = fabs(err_temp); + errz = errz1 * fabs(A1.H) + errz2 * fabs(A2.H) + (ne + 1) * fabs(err_P); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = temp4.H; + + errb2 = errb1; + errb1 = err_temp; + errztemp = errz; + absb1 = abst; + } + temp1 = two_prod(C.H, b1); + temp1.L = C.H * errb1 + temp1.L + C.L * b1; + res = temp1.H + temp1.L; + *(runerrbound) = ((errz1 - (2 + na) * abst) * unit * C.H + fabs(temp1.L - (res - temp1.H))) / (1 - unit * 3); + + return res; +} + +/*AccGegenValwErr evaluates a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +dd_real AccGegenValwErr(double *P, unsigned int n, double x, double lambda, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0; + double err_temp, err_temp1, err_temp2, err_temp3, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4, temp5; + int j; + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 3; + nb = 2; + ne = 8; + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + dd_real *A = (dd_real *)malloc(sizeof(dd_real) * (n + 2)); + dd_real *C = (dd_real *)malloc(sizeof(dd_real) * (n + 2)); + + RecurCoefGegen_DD(n, lambda, A, C); + + for (j = n; j >= 0; j--) + { + temp1 = two_prod((A + j)->H, x); + temp2 = two_prod(temp1.H, b1); + temp3 = two_prod((C + j + 1)->H, b2); + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[j]); + //--------------the compensated part---------------// + err_temp1 = temp1.L * b1 + temp2.L; + err_temp2 = ((A + j)->L) * x * b1 - ((C + j + 1)->L) * b2; + err_temp3 = err_temp1 - temp3.L + temp4.L + temp5.L + err_temp2; + err_temp = temp1.H * errb1 - ((C + j + 1)->H) * errb2 + err_temp3; + //--------------the running error bound-----------// + abst = fabs(err_temp); + errz = errz1 * fabs(temp1.H) + errz2 * fabs((C + j + 1)->H) + (ne + 1) * fabs(err_temp3); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //--------------the next iteration-----------------// + b2 = b1; + b1 = temp5.H; + + errb2 = errb1; + errb1 = err_temp; + errztemp = errz; + absb1 = abst; + } + res = quick_two_sum(b1, errb1); + *(runerrbound) = (errz1 - (2 + na) * abst) * unit; + free(A); + free(C); + + return res; +} + +/*AccGegenDerwErr evaluates the first derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +dd_real AccGegenDerwErr(double *P, unsigned int n, double x, double lambda, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + dd_real A1, A2; + dd_real s0, s1, s2; + int i; + double j; + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 3; + nb = 2; + ne = 6; + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + double C; + C = 2 * lambda; + + for (i = n - 1; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + s0 = two_sum(2 * j + 2, 2 * lambda); + s1 = prod_dd_d(s0, x); + A1 = div_dd_d(s1, j + 1); + s2 = two_sum(C, j + 2); + A2 = div_dd_d(s2, -j - 2); + //--------------iteration-----------------------------------// + temp1 = two_prod(A1.H, b1); + temp2 = two_prod(A2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + 1]); + //--------------the compensated part------------------------// + err_P = A1.L * b1 + A2.L * b2 + temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = A1.H * errb1 + A2.H * errb2 + err_P; + //--------------the runninge error bound-------------------// + abst = fabs(err_temp); + errz = errz1 * fabs(A1.H) + errz2 * fabs(A2.H) + (ne + 1) * fabs(err_P); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = temp4.H; + + errb2 = errb1; + errb1 = err_temp; + errztemp = errz; + absb1 = abst; + } + temp1 = two_prod(C, b1); + res = quick_two_sum(temp1.H, C * errb1 + temp1.L); + *(runerrbound) = (errz1 - (1 + na) * abst) * unit * C; + + return res; +} + +/*AccGegenDerKwErr evaluates the k-th derivative of a series of Gegenbauer polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +dd_real AccGegenDerKwErr(double *P, unsigned int n, double x, double lambda, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + assert(lambda > -0.5); + assert(lambda != 0); + double b1 = 0, b2 = 0, err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + dd_real C, Ctemp, A1, A2; + dd_real s0, s1, s2; + int i; + double j; + C.H = 1.0; + C.L = 0; + for (i = 1; i <= k; i++) + { + Ctemp = two_sum(lambda, i - 1); + C = prod_dd_dd(C, Ctemp); + C.H = 2 * C.H; + C.L = 2 * C.L; + } + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 3; + nb = 2; + ne = 6; + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + j = 1.0 * i; + //-------------recurrence coefficients-----------------------// + s0 = two_sum(2 * j + 2 * k, 2 * lambda); + s1 = prod_dd_d(s0, x); + A1 = div_dd_d(s1, j + 1); + s2 = two_sum(2 * lambda, j + 2 * k); + A2 = div_dd_d(s2, -j - 2); + //--------------iteration-----------------------------------// + temp1 = two_prod(A1.H, b1); + temp2 = two_prod(A2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + k]); + //--------------the compensated part------------------------// + err_P = A1.L * b1 + A2.L * b2 + temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = A1.H * errb1 + A2.H * errb2 + err_P; + //--------------the runninge error bound-------------------// + abst = fabs(err_temp); + errz = errz1 * fabs(A1.H) + errz2 * fabs(A2.H) + (ne + 1) * fabs(err_P); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = temp4.H; + + errb2 = errb1; + errb1 = err_temp; + errztemp = errz; + absb1 = abst; + } + temp1 = two_prod(C.H, b1); + temp1.L = C.H * errb1 + temp1.L + C.L * b1; + res = quick_two_sum(temp1.H, temp1.L); + *(runerrbound) = (errz1 - (2 + na) * abst) * unit * C.H; + + return res; +} diff --git a/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/hermite_series.c b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/hermite_series.c new file mode 100644 index 000000000..f73727241 --- /dev/null +++ b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/hermite_series.c @@ -0,0 +1,1484 @@ +/****************************************************************************** +% Set of subroutines and functions to evaluate series of Hermite polynomials at the point x. +% It allows to evaluate the series and derivatives of it at any point using standard double precision with and without +% error bounds to provide information of the quality of the evaluation. It also allows ACCURATE evaluations using +% a new compensated algorithm. +% +% Licensing: +% +% This code is distributed under the GNU General Public License 3 (GPLv3). +% +% Modified: +% +% 7 November 2016 +% +% Authors: +% +% Roberto Barrio, Peibing Du, Hao Jiang and Sergio Serrano +% +% Algorithm: +% BCS-algorithm with running error bound +% References: +% R. Barrio, J.M. Pe~na, +% Numerical evaluation of the pth derivative of Jacobi series, +% Applied Numerical Mathmetics 43 335-357, (2002). +% +% H. Jiang, R. Barrio, H. Li, X. Liao, L. Cheng, F. Su, +% Accurate evaluation of a polynomial in Chebyshev form +% Applied Mathematics and Computation 217 (23), 9702-9716, (2011). +%*****************************************************************************/ + +#include +#include +#include +#include + +#include"inline.h" +#include"hermite_series.h" + +/* Herm1Val evaluates a series of Hermite polynomial He at the point x.*/ +double Herm1Val(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double t,b1=0,b2=0; + int i; + + for(i=n; i>=0; i--) + { + t=x*b1-(i+1)*b2+P[i]; + b2=b1; + b1=t; + } + return b1; +} + +/*CompHerm1Val evaluates a series of Hermite polynomial He at the point x, with compensated method.*/ +double CompHerm1Val(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0, res; + dd_real temp1,temp2,temp3,temp4; + int i; + + for(i=n; i>=0; i--) + { + temp1=two_prod(x,b1); + temp2=two_prod(i+1,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_sum(temp3.H,P[i]); + + b2=b1; + b1=temp4.H; +//--------------the compensated part---------------// + err_temp=x*errb1-(i+1)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L); + errb2=errb1; + errb1=err_temp; + } + res=b1+errb1; + + return res; +} + +/*AccHerm1Val evaluates a series of Hermite polynomial He at the point x, with compensated method.*/ +dd_real AccHerm1Val(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4; + int i; + + for(i=n; i>=0; i--) + { + temp1=two_prod(x,b1); + temp2=two_prod(i+1,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_sum(temp3.H,P[i]); + + b2=b1; + b1=temp4.H; +//--------------the compensated part---------------// + err_temp=x*errb1-(i+1)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L); + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(b1,errb1); + + return res; +} + +/*Herm2Val evaluates a series of Hermite polynomial H at the point x. */ +double Herm2Val(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double xx,t,b1=0,b2=0; + int i; + xx=2*x; + + for(i=n; i>=0; i--) + { + t=xx*b1-2*(i+1)*b2+P[i]; + b2=b1; + b1=t; + } + return b1; +} + +/*CompHerm2Val evaluates a series of Hermite polynomial H at the point x, with compensated method.*/ +double CompHerm2Val(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double xx,b1=0,b2=0; + double err_temp, errb1=0, errb2=0, res; + dd_real temp1,temp2,temp3,temp4; + int i; + xx=2*x; + + for(i=n; i>=0; i--) + { + temp1=two_prod(xx,b1); + temp2=two_prod(2*i+2,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_sum(temp3.H,P[i]); + + b2=b1; + b1=temp4.H; +//--------------the compensated part---------------// + err_temp=xx*errb1-(2*i+2)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L); + errb2=errb1; + errb1=err_temp; + } + res=b1+errb1; + + return res; +} + +/*AccHerm2Val evaluates a series of Hermite polynomial H at the point x, with compensated method.*/ +dd_real AccHerm2Val(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double xx,b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4; + int i; + xx=2*x; + + for(i=n; i>=0; i--) + { + temp1=two_prod(xx,b1); + temp2=two_prod(2*i+2,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_sum(temp3.H,P[i]); + + b2=b1; + b1=temp4.H; +//--------------the compensated part---------------// + err_temp=xx*errb1-(2*i+2)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L); + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(b1,errb1); + + return res; +} + +/*Herm1Der evaluates the first derivative of a series of Hermite polynomial He at the point x. */ +double Herm1Der(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double t,b1=0,b2=0; + int i; + + for(i=n-1; i>=0; i--) + { + t=x*b1-(i+1)*b2+(i+1)*P[i+1]; + b2=b1; + b1=t; + } + return b1; +} + +/*CompHerm1Der evaluates the first derivative of a series of Hermite polynomial He at the point x, with compensated method.*/ +double CompHerm1Der(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0, res; + dd_real temp1,temp2,temp3,temp4,temp5; + int i; + + for(i=n-1; i>=0; i--) + { + temp1=two_prod(x,b1); + temp2=two_prod(i+1,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(i+1,P[i+1]); + temp5=two_sum(temp3.H,temp4.H); + + b2=b1; + b1=temp5.H; +//--------------the compensated part---------------// + err_temp=x*errb1-(i+1)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L+temp5.L); + errb2=errb1; + errb1=err_temp; + } + res=b1+errb1; + + return res; +} + +/*AccHerm1Der evaluates the first derivative of a series of Hermite polynomial He at the point x, with compensated method.*/ +dd_real AccHerm1Der(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + int i; + + for(i=n-1; i>=0; i--) + { + temp1=two_prod(x,b1); + temp2=two_prod(i+1,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(i+1,P[i+1]); + temp5=two_sum(temp3.H,temp4.H); + + b2=b1; + b1=temp5.H; +//--------------the compensated part---------------// + err_temp=x*errb1-(i+1)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L+temp5.L); + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(b1,errb1); + + return res; +} + +/*Herm2Der evaluates the first derivative of a series of Hermite polynomial H at the point x. */ +double Herm2Der(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double xx,t,b1=0,b2=0; + int i; + xx=2*x; + + for(i=n-1; i>=0; i--) + { + t=xx*b1-2*(i+1)*b2+2*(i+1)*P[i+1]; + b2=b1; + b1=t; + } + return b1; +} + +/*CompHerm2Der evaluates the first derivative of a series of Hermite polynomial H at the point x, with compensated method.*/ +double CompHerm2Der(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double xx,b1=0,b2=0; + double err_temp, errb1=0, errb2=0, res; + dd_real temp1,temp2,temp3,temp4,temp5; + int i; + xx=2*x; + + for(i=n-1; i>=0; i--) + { + temp1=two_prod(xx,b1); + temp2=two_prod(2*i+2,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(2*i+2,P[i+1]); + temp5=two_sum(temp3.H,temp4.H); + + b2=b1; + b1=temp5.H; +//--------------the compensated part---------------// + err_temp=xx*errb1-2*(i+1)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L+temp5.L); + errb2=errb1; + errb1=err_temp; + } + res=b1+errb1; + + return res; +} + +/*AccHerm2Der evaluates the first derivative of a series of Hermite polynomial H at the point x, with compensated method.*/ +dd_real AccHerm2Der(double *P, unsigned int n, double x) +{ + assert ( 0 < n); + double xx,b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + int i; + xx=2*x; + + for(i=n-1; i>=0; i--) + { + temp1=two_prod(xx,b1); + temp2=two_prod(2*i+2,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(2*i+2,P[i+1]); + temp5=two_sum(temp3.H,temp4.H); + + b2=b1; + b1=temp5.H; +//--------------the compensated part---------------// + err_temp=xx*errb1-2*(i+1)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L+temp5.L); + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(b1,errb1); + + return res; +} + +/*Herm1DerK evaluates the k-th derivative of a series of Hermite polynomial He at the point x. */ +double Herm1DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert ( 0 < n); + double t,s,b1=0,b2=0; + int i,j; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + t=x*b1-(i+1)*b2+s*P[i+k]; + b2=b1; + b1=t; + } + return b1; +} + +/*CompHerm1DerK evaluates the k-th derivative of a series of Hermite polynomial He at the point x, with compensated method.*/ +double CompHerm1DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert ( 0 < n); + double s,b1=0,b2=0; + double err_temp, errb1=0, errb2=0, res; + dd_real temp1,temp2,temp3,temp4,temp5; + int i,j; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + temp1=two_prod(x,b1); + temp2=two_prod(i+1,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(s,P[i+k]); + temp5=two_sum(temp3.H,temp4.H); + + b2=b1; + b1=temp5.H; +//--------------the compensated part---------------// + err_temp=x*errb1-(i+1)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L+temp5.L); + errb2=errb1; + errb1=err_temp; + } + res=b1+errb1; + + return res; +} + +/*AccHerm1DerK evaluates the k-th derivative of a series of Hermite polynomial He at the point x, with compensated method.*/ +dd_real AccHerm1DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert ( 0 < n); + double s,b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + int i,j; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + temp1=two_prod(x,b1); + temp2=two_prod(i+1,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(s,P[i+k]); + temp5=two_sum(temp3.H,temp4.H); + + b2=b1; + b1=temp5.H; +//--------------the compensated part---------------// + err_temp=x*errb1-(i+1)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L+temp5.L); + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(b1,errb1); + + return res; +} + +/*Herm2DerK evaluates the k-th derivative of a series of Hermite polynomial H at the point x. */ +double Herm2DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert ( 0 < n); + double xx,C=1.0,s,t,b1=0,b2=0; + int i,j; + for(i=k;i>0;i--) + { + C=2*C; + } + xx=2*x; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + t=xx*b1-2*(i+1)*b2+s*P[i+k]; + + b2=b1; + b1=t; + } +return C*b1; +} + +/*CompHerm2DerK evaluates the k-th derivative of a series of Hermite polynomial H at the point x, with compensated method.*/ +double CompHerm2DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert ( 0 < n); + double xx,C=1.0,s,b1=0,b2=0; + double err_temp, errb1=0, errb2=0, res; + dd_real temp1,temp2,temp3,temp4,temp5; + int i,j; + for(i=k;i>0;i--) + { + C=2*C; + } + xx=2*x; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + temp1=two_prod(xx,b1); + temp2=two_prod(2*i+2,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(s,P[i+k]); + temp5=two_sum(temp3.H,temp4.H); + + b2=b1; + b1=temp5.H; +//--------------the compensated part---------------// + err_temp=xx*errb1-2*(i+1)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L+temp5.L); + errb2=errb1; + errb1=err_temp; + } + res=C*(b1+errb1); + + return res; +} + +/*AccHerm2DerK evaluates the k-th derivative of a series of Hermite polynomial H at the point x, with compensated method.*/ +dd_real AccHerm2DerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert ( 0 < n); + double xx,C=1.0,s,b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + int i,j; + for(i=k;i>0;i--) + { + C=2*C; + } + xx=2*x; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + temp1=two_prod(xx,b1); + temp2=two_prod(2*i+2,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(s,P[i+k]); + temp5=two_sum(temp3.H,temp4.H); + + b2=b1; + b1=temp5.H; +//--------------the compensated part---------------// + err_temp=xx*errb1-2*(i+1)*errb2+(temp1.L-temp2.L+temp3.L+temp4.L+temp5.L); + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(C*b1,C*errb1); + + return res; +} + +/* Herm1ValwErr evaluates a series of Hermite polynomial He at the point x, and performs a running-error bound.*/ +double Herm1ValwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double t,b1=0,b2=0; + double abst=0,absb1=0; + int i; + double j; + double absx; + absx=fabs(x); + int na,nb; + na=0; + nb=0; + + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n; i>=0; i--) + { + j=1.0*i; + t=x*b1-(j+1)*b2+P[i]; + abst=fabs(t); + + errz=errz1*absx+(j+1)*errz2+fabs(P[i]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + *(runerrbound)=(errz1-(2+na)*abst)*unit; + + return b1; +} + +/*Herm2ValwErr evaluates a series of Hermite polynomial H at the point x, and performs a running-error bound.*/ +double Herm2ValwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double xx,t,b1=0,b2=0; + double abst=0,absb1=0; + int i; + double j; + xx=2*x; + double absxx; + absxx=fabs(xx); + int na,nb; + na=0; + nb=0; + + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n; i>=0; i--) + { + j=1.0*i; + t=xx*b1-2*(j+1)*b2+P[i]; + abst=fabs(t); + + errz=errz1*absxx+2*(j+1)*errz2+fabs(P[i]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + *(runerrbound)=(errz1-(2+na)*abst)*unit; + + return b1; +} + +/* Herm1DerwErr evaluates the first derivative of series of Hermite polynomial He at the point x, and performs a running-error bound.*/ +double Herm1DerwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + + double t,b1=0,b2=0; + double abst=0,absb1=0; + int i; + double j; + double absx; + absx=fabs(x); + int na,nb,nc; + na=0; + nb=0; + nc=0; + + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-1; i>=0; i--) + { + j=1.0*i; + t=x*b1-(j+1)*b2+(j+1)*P[i+1]; + + abst=fabs(t); + + errz=errz1*absx+(j+1)*errz2+(nc+2)*(j+1)*fabs(P[i+1]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + *(runerrbound)=(errz1-(1+na)*abst)*unit; + + return b1; +} + + +/*Herm2DerwErr evaluates the first derivative of series of Hermite polynomial H at the point x, and performs a running-error bound.*/ + +double Herm2DerwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double xx,t,b1=0,b2=0; + + double abst=0,absb1=0,absxx; + xx=2*x; + absxx=fabs(xx); + int i; + double j; + int na,nb,nc; + na=0; + nb=0; + nc=0; + + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-1; i>=0; i--) + { + j=1.0*i; + t=xx*b1-2*(j+1)*b2+2*(j+1)*P[i+1]; + + abst=fabs(t); + + errz=errz1*absxx+errz2*2*(j+1)+2*(j+1)*(nc+2)*fabs(P[i+1]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + *(runerrbound)=(errz1-(1+na)*abst)*unit; + + return b1; +} + +/* Herm1DerKwErr evaluates the k-th derivative of series of Hermite polynomial He at the point x, and performs a running-error bound.*/ +double Herm1DerKwErr(double *P, unsigned int n, double x, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + + double t,s,b1=0,b2=0; + int i,j; + + double abst=0,absb1=0; + double absx; + absx=fabs(x); + int na,nb,nc; + na=0; + nb=0; + nc=0; + + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + t=x*b1-(i+1)*b2+s*P[i+k];; + + abst=fabs(t); + + errz=errz1*absx+(i+1)*errz2+(nc+2)*(s)*fabs(P[i+k]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + *(runerrbound)=(errz1-(1+na)*abst)*unit; + + return b1; +} + +/*Herm2DerKwErr evaluates the k-th derivative of series of Hermite polynomial H at the point x, and performs a running-error bound */ +double Herm2DerKwErr(double *P, unsigned int n, double x, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + + int na,nb,nc; + na=0; + nb=0; + nc=0; + + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + double xx,C=1.0,s,t,b1=0,b2=0; + int i,j; + for(i=k;i>0;i--) + { + C=2*C; + } + xx=2*x; + double abst=0,absb1=0,absxx; + absxx=fabs(xx); + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + t=xx*b1-2*(i+1)*b2+s*P[i+k]; + + abst=fabs(t); + + errz=errz1*absxx+errz2*2*(i+1)+(s)*(nc+2)*fabs(P[i+k]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + *(runerrbound)=(errz1-(1+na)*abst)*unit*C; + + return C*b1; +} + +/*CompHerm1ValwErr evaluates a series of Hermite polynomial He at the point x, with compensated method, together with the running error bound.*/ +double CompHerm1ValwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double b1=0,b2=0; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4; + int i; + + double abst=0,absb1=0; + double absx; + absx=fabs(x); + int na,nb,ne; + na=0; + nb=0; + ne=3; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n; i>=0; i--) + { + temp1=two_prod(x,b1); + temp2=two_prod(i+1,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_sum(temp3.H,P[i]); +//--------------the compensated part---------------// + err_P=temp1.L-temp2.L+temp3.L+temp4.L; + err_temp=x*errb1-(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absx+(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; +//--------------the next iteration-----------------// + b2=b1; + b1=temp4.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=b1+errb1; + *(runerrbound)=((errz1-(2+na)*abst)*unit+fabs(errb1-(res-b1)))/(1-unit*2); + + return res; +} + +/*CompHerm2ValwErr evaluates a series of Hermite polynomial H at the point x, with compensated method, together with the running error bound.*/ +double CompHerm2ValwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double xx,b1=0,b2=0; + double res,err_temp=0, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4; + int i; + xx=2*x; + + double abst=0,absb1=0; + double absxx; + absxx=fabs(xx); + int na,nb,ne; + na=0; + nb=0; + ne=3; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n; i>=0; i--) + { + temp1=two_prod(xx,b1); + temp2=two_prod(2*(i+1),b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_sum(temp3.H,P[i]); + + b2=b1; + b1=temp4.H; +//--------------the compensated part---------------// + err_P=temp1.L-temp2.L+temp3.L+temp4.L; + err_temp=xx*errb1-2*(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absxx+2*(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=b1+err_temp; + *(runerrbound)=((errz1-(2+na)*abst)*unit+fabs(err_temp-(res-b1)))/(1-unit*2); + + return res; +} + +/*CompHerm1DerwErr evaluates the first derivative of a series of Hermite polynomial He at the point x, with compensated method, together with running error bound.*/ +double CompHerm1DerwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double b1=0,b2=0; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5; + int i; + + double abst=0,absb1=0; + double absx; + absx=fabs(x); + int na,nb,ne; + na=0; + nb=0; + ne=4; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-1; i>=0; i--) + { + temp1=two_prod(x,b1); + temp2=two_prod(i+1,P[i+1]); + temp3=two_sum(temp1.H, temp2.H); + temp4=two_prod(i+1,b2); + temp5=two_sum(temp3.H,-temp4.H); + + b2=b1; + b1=temp5.H; +//--------------the compensated part---------------// + err_P=temp1.L+temp2.L+temp3.L-temp4.L+temp5.L; + err_temp=x*errb1-(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absx+(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=b1+errb1; + *(runerrbound)=((errz1-(1+na)*abst)*unit+fabs(errb1-(res-b1)))/(1-unit*2); + + return res; +} + +/*CompHerm2DerwErr evaluates the first derivative of a series of Hermite polynomial H at the point x, with compensated method, together with the running error bound.*/ +double CompHerm2DerwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double xx,b1=0,b2=0; + xx=2*x; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5; + + int i; + double absxx; + absxx=fabs(xx); + + double abst=0,absb1=0; + int na,nb,ne; + na=0; + nb=0; + ne=4; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-1; i>=0; i--) + { + temp1=two_prod(xx,b1); + temp2=two_prod(2*(i+1),b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(2*(i+1),P[i+1]); + temp5=two_sum(temp3.H,temp4.H); +//--------------the compensated part---------------// + err_P=temp1.L-temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=xx*errb1-2*(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absxx+2*(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; +//------------- the next step---------------------// + b2=b1; + b1=temp5.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=b1+errb1; + *(runerrbound)=((errz1-(1+na)*abst)*unit+fabs(errb1-(res-b1)))/(1-unit*2); + + return res; +} + +/*CompHerm1DerKwErr evaluates the k-th derivative of a series of Hermite polynomial He at the point x, with compensated method, together with running error bound.*/ +double CompHerm1DerKwErr(double *P, unsigned int n, double x, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + double s,b1=0,b2=0; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5; + int i,j; + + double abst=0,absb1=0; + double absx; + absx=fabs(x); + int na,nb,ne; + na=0; + nb=0; + ne=4; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + temp1=two_prod(x,b1); + temp2=two_prod(i+1,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(s,P[i+k]); + temp5=two_sum(temp3.H,temp4.H); +//--------------the compensated part---------------// + err_P=temp1.L-temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=x*errb1-(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absx+(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=temp5.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=b1+errb1; + *(runerrbound)=((errz1-(2+na)*abst)*unit+fabs(errb1-(res-b1)))/(1-unit*2); + + return res; +} + +/*CompHerm2DerKwErr evaluates the k-th derivative of a series of Hermite polynomial H at the point x, with compensated method, together with the running error bound.*/ +double CompHerm2DerKwErr(double *P, unsigned int n, double x, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + double xx,C=1.0,s,b1=0,b2=0; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5; + int i,j; + for(i=k;i>0;i--) + { + C=2*C; + } + xx=2*x; + double absxx; + absxx=fabs(xx); + + double abst=0,absb1=0; + int na,nb,ne; + na=0; + nb=0; + ne=4; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + temp1=two_prod(xx,b1); + temp2=two_prod(2*i+2,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(s,P[i+k]); + temp5=two_sum(temp3.H,temp4.H); +//--------------the compensated part---------------// + err_P=temp1.L-temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=xx*errb1-2*(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absxx+2*(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; +//------------- the next step---------------------// + b2=b1; + b1=temp5.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=C*(b1+errb1); + *(runerrbound)=((errz1-(2+na)*abst)*unit*C+fabs(C*errb1-(res-C*b1)))/(1-unit*2); + + return res; +} + +/*AccHerm1ValwErr evaluates a series of Hermite polynomial He at the point x, with compensated method, together with the running error bound.*/ +dd_real AccHerm1ValwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4; + int i; + + double abst=0,absb1=0; + double absx; + absx=fabs(x); + int na,nb,ne; + na=0; + nb=0; + ne=3; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n; i>=0; i--) + { + temp1=two_prod(x,b1); + temp2=two_prod(i+1,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_sum(temp3.H,P[i]); +//--------------the compensated part---------------// + err_P=temp1.L-temp2.L+temp3.L+temp4.L; + err_temp=x*errb1-(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absx+(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; +//--------------the next iteration-----------------// + b2=b1; + b1=temp4.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(b1,errb1); + *(runerrbound)=(errz1-(2+na)*abst)*unit; + + return res; +} + +/*AccHerm2ValwErr evaluates a series of Hermite polynomial H at the point x, with compensated method, together with the running error bound.*/ +dd_real AccHerm2ValwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double xx,b1=0,b2=0; + double err_temp=0, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4; + int i; + xx=2*x; + + double abst=0,absb1=0; + double absxx; + absxx=fabs(xx); + int na,nb,ne; + na=0; + nb=0; + ne=3; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n; i>=0; i--) + { + temp1=two_prod(xx,b1); + temp2=two_prod(2*(i+1),b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_sum(temp3.H,P[i]); + + b2=b1; + b1=temp4.H; +//--------------the compensated part---------------// + err_P=temp1.L-temp2.L+temp3.L+temp4.L; + err_temp=xx*errb1-2*(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absxx+2*(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(b1,err_temp); + *(runerrbound)=(errz1-(2+na)*abst)*unit; + + return res; +} + +/*AccHerm1DerwErr evaluates the first derivative of a series of Hermite polynomial He at the point x, with compensated method, together with running error bound.*/ +dd_real AccHerm1DerwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + int i; + + double abst=0,absb1=0; + double absx; + absx=fabs(x); + int na,nb,ne; + na=0; + nb=0; + ne=4; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-1; i>=0; i--) + { + temp1=two_prod(x,b1); + temp2=two_prod(i+1,P[i+1]); + temp3=two_sum(temp1.H, temp2.H); + temp4=two_prod(i+1,b2); + temp5=two_sum(temp3.H,-temp4.H); + + b2=b1; + b1=temp5.H; +//--------------the compensated part---------------// + err_P=temp1.L+temp2.L+temp3.L-temp4.L+temp5.L; + err_temp=x*errb1-(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absx+(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(b1,errb1); + *(runerrbound)=(errz1-(1+na)*abst)*unit; + + return res; +} + +/*AccHerm2DerwErr evaluates the first derivative of a series of Hermite polynomial H at the point x, with compensated method, together with the running error bound.*/ +dd_real AccHerm2DerwErr(double *P, unsigned int n, double x, double * runerrbound) +{ + assert ( 0 < n); + double xx,b1=0,b2=0; + xx=2*x; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + + int i; + double absxx; + absxx=fabs(xx); + + double abst=0,absb1=0; + int na,nb,ne; + na=0; + nb=0; + ne=4; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-1; i>=0; i--) + { + temp1=two_prod(xx,b1); + temp2=two_prod(2*(i+1),b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(2*(i+1),P[i+1]); + temp5=two_sum(temp3.H,temp4.H); +//--------------the compensated part---------------// + err_P=temp1.L-temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=xx*errb1-2*(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absxx+2*(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; +//------------- the next step---------------------// + b2=b1; + b1=temp5.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(b1,errb1); + *(runerrbound)=(errz1-(1+na)*abst)*unit; + + return res; +} + +/*AccHerm1DerKwErr evaluates the k-th derivative of a series of Hermite polynomial He at the point x, with compensated method, together with running error bound.*/ +dd_real AccHerm1DerKwErr(double *P, unsigned int n, double x, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + double s,b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + int i,j; + + double abst=0,absb1=0; + double absx; + absx=fabs(x); + int na,nb,ne; + na=0; + nb=0; + ne=4; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + temp1=two_prod(x,b1); + temp2=two_prod(i+1,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(s,P[i+k]); + temp5=two_sum(temp3.H,temp4.H); +//--------------the compensated part---------------// + err_P=temp1.L-temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=x*errb1-(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absx+(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=temp5.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(b1,errb1); + *(runerrbound)=(errz1-(2+na)*abst)*unit; + + return res; +} + +/*AccHerm2DerKwErr evaluates the k-th derivative of a series of Hermite polynomial H at the point x, with compensated method, together with the running error bound.*/ +dd_real AccHerm2DerKwErr(double *P, unsigned int n, double x, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + double xx,C=1.0,s,b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + int i,j; + for(i=k;i>0;i--) + { + C=2*C; + } + xx=2*x; + double absxx; + absxx=fabs(xx); + + double abst=0,absb1=0; + int na,nb,ne; + na=0; + nb=0; + ne=4; + + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-k; i>=0; i--) + { + s=1.0; + for(j=i+k;j>=i+1;j--) + { + s=s*j; + } + temp1=two_prod(xx,b1); + temp2=two_prod(2*i+2,b2); + temp3=two_sum(temp1.H,-temp2.H); + temp4=two_prod(s,P[i+k]); + temp5=two_sum(temp3.H,temp4.H); +//--------------the compensated part---------------// + err_P=temp1.L-temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=xx*errb1-2*(i+1)*errb2+err_P; +//--------------the running error bound------------// + abst=fabs(err_temp); + errz=errz1*absxx+2*(i+1)*errz2+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; +//------------- the next step---------------------// + b2=b1; + b1=temp5.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(C*b1,C*errb1); + *(runerrbound)=(errz1-(2+na)*abst)*unit*C; + + return res; +} + + + + + + + + + diff --git a/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/inline_function.c b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/inline_function.c new file mode 100644 index 000000000..cb7e00b3d --- /dev/null +++ b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/inline_function.c @@ -0,0 +1,180 @@ +#include + +#ifndef SPLITTER +#define SPLITTER 134217729.0 // = 2^27 + 1 +#endif +//int const _splitter_ = (1<<27)+1; + + + +/*********** Basic Functions ************/ +/* Computes fl(a+b) and err(a+b). Assumes |a| >= |b|. */ +inline dd_real quick_two_sum(double a, double b) { + dd_real res; + res.H = a + b; + res.L = b - (res.H - a); + return res; +} + + +/* Computes fl(a+b) and err(a+b). */ + inline dd_real two_sum(double a, double b) { + dd_real res; +res.H = a + b; +double bb = res.H - a; +res.L = (a - (res.H - bb)) + (b - bb); + return res; +} + +/* Computes high word and lo word of a */ + inline dd_real split(double a) { +double temp; + dd_real res; + temp = SPLITTER * a; + res.H = temp - (temp - a); + res.L = a - res.H; + return res; +} + + +/* Computes fl(a*b) and err(a*b). */ + inline dd_real two_prod(double a, double b) { + dd_real res,aa,bb; +res.H = a * b; +aa=split(a); +bb=split(b); +res.L = ((aa.H * bb.H - res.H) + aa.H * bb.L + aa.L * bb.H) + aa.L * bb.L; + return res; +} + + +/*********** Additions ************/ +/* double+double equals to two_sum */ +/* double-double + double */ + inline dd_real add_dd_d(const dd_real aa, double b) { +dd_real res,temp; +temp=two_sum(aa.H,b); +temp.L+=aa.L; +res=quick_two_sum(temp.H, temp.L); +return res; +} + +/* double-double + double-double */ +/* the sloppy version from QD library*/ + + inline dd_real add_dd_dd(const dd_real aa, const dd_real bb) { +dd_real res,temp; +temp=two_sum(aa.H,bb.H); +temp.L+=(aa.L+bb.L); +res=quick_two_sum(temp.H, temp.L); +return res; +} + +/*********** Multiplications ************/ +/* double * double equals to two_prod */ +/* double-double * double */ + inline dd_real prod_dd_d(const dd_real aa, double b) { +dd_real res,temp; +temp=two_prod(aa.H,b); +temp.L += (aa.L * b); +res=quick_two_sum(temp.H, temp.L); +return res; +} + +/* double-double * double-double */ + inline dd_real prod_dd_dd(const dd_real aa, const dd_real bb) { +dd_real res,temp; +temp=two_prod(aa.H,bb.H); +temp.L += (aa.L * bb.H + aa.H * bb.L); +res=quick_two_sum(temp.H, temp.L); +return res; +} + + + +/*********** Divisions ************/ +/* double / double */ + inline dd_real div_d_d(double a, double b) { +double q1, q2; +dd_real res,temp1,temp2; +q1 = a / b; + /* Compute a - q1 * b */ +temp1=two_prod(q1,b); +temp2=two_sum(a,-temp1.H); +temp2.L=temp2.L-temp1.L; + /* get next approximation */ +q2=(temp2.H+temp2.L)/b; + +res=quick_two_sum(q1, q2); +return res; +} + +/* double-double / double */ + inline dd_real div_dd_d(const dd_real aa, double b) { +double q1, q2; +dd_real res,temp1,temp2; + +q1 = aa.H / b; + /* Compute this - q1 * d */ +temp1=two_prod(q1,b); +temp2=two_sum(aa.H,-temp1.H); +temp2.L=temp2.L+aa.L; +temp2.L=temp2.L-temp1.L; + /* get next approximation. */ +q2=(temp2.H+temp2.L)/b; + +res=quick_two_sum(q1, q2); +return res; +} + + +/* double-double / double-double */ +/* the sloppy version from QD library*/ + inline dd_real div_dd_dd(const dd_real aa, const dd_real bb) { +double q1, q2; +dd_real res,temp1,temp2; + +q1 = aa.H / bb.H; +temp1=prod_dd_d(bb,q1); +temp2=two_sum(aa.H,-temp1.H); +temp2.L=temp2.L-temp1.L; +temp2.L=temp2.L+aa.L; + /* get next approximation */ +q2=(temp2.H+temp2.L)/bb.H; + +res=quick_two_sum(q1, q2); +return res; +} + + +/* double-double / double-double */ +/* the sloppy version not from QD library*/ + inline dd_real div_d_dd(double a, const dd_real bb) { +double q1, q2; +dd_real res,temp1,temp2; + +q1 = a / bb.H; +temp1=prod_dd_d(bb,q1); +temp2=two_sum(a,-temp1.H); +temp2.L=temp2.L-temp1.L; + /* get next approximation */ +q2=(temp2.H+temp2.L)/bb.H; + +res=quick_two_sum(q1, q2); +return res; +} + + + +/* double-double - double-double */ +/* the sloppy version from QD library*/ + + inline dd_real diff_dd_dd(const dd_real aa, const dd_real bb) { +dd_real res,temp; +temp=two_sum(aa.H,-bb.H); +temp.L+=(aa.L-bb.L); +res=quick_two_sum(temp.H, temp.L); +return res; +} + + diff --git a/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/jacobi_series.c b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/jacobi_series.c new file mode 100644 index 000000000..bb5f3e2aa --- /dev/null +++ b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/jacobi_series.c @@ -0,0 +1,1302 @@ +/****************************************************************************** +% Set of subroutines and functions to evaluate series of JACOBI polynomials at the point x, which is in [-1, 1]. +% It allows to evaluate the series and derivatives of it at any point using standard double precision with and without +% error bounds to provide information of the quality of the evaluation. It also allows ACCURATE evaluations using +% a new compensated algorithm. +% +% Licensing: +% +% This code is distributed under the GNU General Public License 3 (GPLv3). +% +% Modified: +% +% 4 November 2016 +% +% Authors: +% +% Roberto Barrio, Peibing Du, Hao Jiang and Sergio Serrano +% +% Algorithm: +% BCS-algorithm with running error bound +% References: +% R. Barrio, J.M. Pe~na, +% Numerical evaluation of the pth derivative of Jacobobi series, +% Applied Numerical Mathmetics 43 335-357, (2002). +% +% H. Jiang, R. Barrio, H. Li, X. Liao, L. Cheng, F. Su, +% Accurate evaluation of a polynomial in Chebyshev form +% Applied Mathematics and Computation 217 (23), 9702-9716, (2011). +%*****************************************************************************/ + +#include +#include +#include +#include + +#include"inline.h" +#include"jacobi_series.h" +//----------------------- The three-term recurrence coefficients of jacobi polynomial ---------------------------------- +void RecurCoefJacob (double n, double alpha, double beta, double *A, double *B, double *C) +{ + int i; + double j; + for (i=1;i<=n+2;i++) + { + j=1.0*i; + *(A+i-1)=(2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + *(B+i-1)=(alpha*alpha-beta*beta)*(2*j+alpha+beta-1)/(2*j*(j+alpha+beta)*(2*j+alpha+beta-2)); + *(C+i-1)=(j-1+alpha)*(j-1+beta)*(2*j+alpha+beta)/(j*(j+alpha+beta)*(2*j+alpha+beta-2)); + } +} + +void RecurCoefJacob_DD (double n, double alpha, double beta, dd_real *A, dd_real *B, dd_real *C) +{ + int i; + double j; + dd_real tempA,tempB,temp1,temp2,temp3,temp4,temp5, temp6; + dd_real s0,s1,s2,s3,w1,w2; + tempA=two_sum(alpha,beta); + tempB=two_sum(alpha,-beta); + + for (i=1;i<=n+2;i++) + { + j=1.0*i; + temp1=add_dd_d(tempA,j); + temp2=add_dd_d(tempA,2*j-2); + temp3=add_dd_d(tempA,2*j-1); + temp4=add_dd_d(tempA,2*j); + temp5=prod_dd_d(temp1,j); + temp6.H=2*temp5.H; + temp6.L=2*temp5.L; + s0=prod_dd_dd(temp3,temp4); + *(A+i-1)=div_dd_dd(s0,temp6); + s1=prod_dd_dd(tempA,tempB); + s2=prod_dd_dd(s1,temp3); + s3=prod_dd_dd(temp6,temp2); + *(B+i-1)=div_dd_dd(s2,s3); + w1=two_sum(j-1,alpha); + w2=two_sum(j-1,beta); + s1=prod_dd_dd(w1,w2); + s2=prod_dd_dd(s1,temp4); + s3=prod_dd_dd(temp5,temp2); + *(C+i-1)=div_dd_dd(s2,s3); + } +} + +/* JacobVal evaluates a series of Jacobobi polynomial at the point x, which is in [-1, 1].*/ +double JacobVal(double *P, unsigned int n, double x, double alpha, double beta) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + + double t,b1=0,b2=0; + int j; + + double *A=(double *) malloc(sizeof(double)*(n+2)); + double *B=(double *) malloc(sizeof(double)*(n+2)); + double *C=(double *) malloc(sizeof(double)*(n+2)); + + RecurCoefJacob(n,alpha,beta,A,B,C); + + for(j=n; j>=0; j--) + { + t=(*(A+j)*x+*(B+j))*b1-*(C+j+1)*b2+P[j]; + + b2=b1; + b1=t; + } + free(A); + free(B); + free(C); + + return b1; +} + +/*CompJacobVal evaluates a series of Jacobobi polynomial at the point x, which is in [-1, 1], with compensated method.*/ +double CompJacobVal(double *P, unsigned int n, double x, double alpha, double beta) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double res,err_temp, err_temp1, err_temp2, err_temp3, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5,temp6; + int j; + + dd_real *A=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *B=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *C=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + + RecurCoefJacob_DD(n,alpha,beta,A,B,C); + + for(j=n; j>=0; j--) + { + temp1=two_prod((A+j)->H,x); + temp2=two_sum(temp1.H,(B+j)->H); + temp3=two_prod(temp2.H,b1); + + temp4=two_prod((C+j+1)->H,b2); + temp5=two_sum(temp3.H,-temp4.H); + temp6=two_sum(temp5.H,P[j]); +//--------------the compensated part---------------// + err_temp1=(temp1.L+temp2.L)*b1+temp3.L; + err_temp2=(((A+j)->L)*x+((B+j)->L))*b1-((C+j+1)->L)*b2; + err_temp3=err_temp1-temp4.L+temp5.L+temp6.L+err_temp2; + err_temp=temp2.H*errb1-((C+j+1)->H)*errb2+err_temp3; +//--------------the next iteration-----------------// + b2=b1; + b1=temp6.H; + errb2=errb1; + errb1=err_temp; + } + res=b1+errb1; + free(A); + free(B); + free(C); + + return res; +} + +/*AccJacobVal evaluates a series of Jacobobi polynomial at the point x, which is in [-1, 1], with compensated method.*/ +dd_real AccJacobVal(double *P, unsigned int n, double x, double alpha, double beta) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double err_temp, err_temp1, err_temp2, err_temp3, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5,temp6; + int j; + + dd_real *A=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *B=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *C=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + + RecurCoefJacob_DD(n,alpha,beta,A,B,C); + + for(j=n; j>=0; j--) + { + temp1=two_prod((A+j)->H,x); + temp2=two_sum(temp1.H,(B+j)->H); + temp3=two_prod(temp2.H,b1); + + temp4=two_prod((C+j+1)->H,b2); + temp5=two_sum(temp3.H,-temp4.H); + temp6=two_sum(temp5.H,P[j]); +//--------------the compensated part---------------// + err_temp1=(temp1.L+temp2.L)*b1+temp3.L; + err_temp2=(((A+j)->L)*x+((B+j)->L))*b1-((C+j+1)->L)*b2; + err_temp3=err_temp1-temp4.L+temp5.L+temp6.L+err_temp2; + err_temp=temp2.H*errb1-((C+j+1)->H)*errb2+err_temp3; +//--------------the next iteration-----------------// + b2=b1; + b1=temp6.H; + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(b1,errb1); + free(A); + free(B); + free(C); + + return res; +} + +/*JacobDer evaluates the first derivative of a series of Jacobobi polynomial at the point x, which is in [-1, 1]. */ +double JacobDer(double *P, unsigned int n, double x, double alpha, double beta) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double t,b1=0,b2=0; + double Ac, A1, A2; + double a10,a11,a12,a20,a21; + int i; + double j; + double C=0.5; + + for(i=n-1; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + Ac=j+2+alpha+beta; + a10=(2*j+3+alpha+beta)/((2*j+2)*(j+3+alpha+beta)); + a11=(2*j+4+alpha+beta)*x; + a12=((alpha-beta)*(alpha+beta+2))/(alpha+beta+2*j+2); + A1=a10*(a11+a12); + a20=-(j+2+alpha)*(j+2+beta)/((j+2)*(alpha+beta+j+4)); + a21=(alpha+beta+2*j+6)/(alpha+beta+2*j+4); + A2=a20*a21; +//--------------iteration-----------------------------------// + t=A1*b1+A2*b2+Ac*P[i+1]; + + b2=b1; + b1=t; + } + return C*b1; +} + +/*CompJacobDer evaluates the first derivative of a series of Jacobobi polynomial at the point x, which is in [-1, 1], with compensated method */ +double CompJacobDer(double *P, unsigned int n, double x, double alpha, double beta) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5; + dd_real Ac, A1, A2; + dd_real a10,a11,a12,a20,a21; + dd_real u,u1,u2,u3,u4,u5,u6,u7; + dd_real w,s1,s2,s3,s4,s5,s6,s7,s8; + int i; + double j,temp; + double C=0.5; + + u=two_sum(alpha,beta); + w=two_sum(alpha,-beta); + + for(i=n-1; i>=0; i--) + { + j=1.0*i; + + u1=add_dd_d(u,j+2); + u2=add_dd_d(u,j+3); + u3=add_dd_d(u,j+4); + u4=add_dd_d(u,2*j+2); + u5=add_dd_d(u,2*j+3); + u6=add_dd_d(u,2*j+4); + u7=add_dd_d(u,2*j+6); +//-------------recurrence coefficients-----------------------// + Ac=u1; + + s1=prod_dd_d(u2,(2*j+2)); + a10=div_dd_dd(u5,s1); + a11=prod_dd_d(u6,x); + s2=add_dd_d(u,2); + s3=prod_dd_dd(w,s2); + a12=div_dd_dd(s3,u4); + s4=add_dd_dd(a11,a12); + A1=prod_dd_dd(a10,s4); + + s5=two_sum(j+2,alpha); + s6=two_sum(j+2,beta); + s5.H=-s5.H; + s5.L=-s5.L; + s7=prod_dd_dd(s5,s6); + s8=prod_dd_d(u3,j+2); + a20=div_dd_dd(s7,s8); + a21=div_dd_dd(u7,u6); + A2=prod_dd_dd(a20,a21); +//--------------iteration-----------------------------------// + temp1=two_prod(Ac.H,P[i+1]); + temp2=two_prod(A1.H,b1); + temp3=two_prod(A2.H,b2); + temp4=two_sum(temp1.H,temp2.H); + temp5=two_sum(temp3.H,temp4.H); + temp=temp1.L+temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=Ac.L*P[i+1]+A1.L*b1+A2.L*b2+A1.H*errb1+A2.H*errb2+temp; + + b2=b1; + b1=temp5.H; + errb2=errb1; + errb1=err_temp; + } + res=C*(b1+errb1); + return res; +} + +/*AccJacobDer evaluates the first derivative of a series of Jacobobi polynomial at the point x, which is in [-1, 1], with compensated method */ +dd_real AccJacobDer(double *P, unsigned int n, double x, double alpha, double beta) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + dd_real Ac, A1, A2; + dd_real a10,a11,a12,a20,a21; + dd_real u,u1,u2,u3,u4,u5,u6,u7; + dd_real w,s1,s2,s3,s4,s5,s6,s7,s8; + int i; + double j,temp; + double C=0.5; + + u=two_sum(alpha,beta); + w=two_sum(alpha,-beta); + + for(i=n-1; i>=0; i--) + { + j=1.0*i; + + u1=add_dd_d(u,j+2); + u2=add_dd_d(u,j+3); + u3=add_dd_d(u,j+4); + u4=add_dd_d(u,2*j+2); + u5=add_dd_d(u,2*j+3); + u6=add_dd_d(u,2*j+4); + u7=add_dd_d(u,2*j+6); +//-------------recurrence coefficients-----------------------// + Ac=u1; + + s1=prod_dd_d(u2,(2*j+2)); + a10=div_dd_dd(u5,s1); + a11=prod_dd_d(u6,x); + s2=add_dd_d(u,2); + s3=prod_dd_dd(w,s2); + a12=div_dd_dd(s3,u4); + s4=add_dd_dd(a11,a12); + A1=prod_dd_dd(a10,s4); + + s5=two_sum(j+2,alpha); + s6=two_sum(j+2,beta); + s5.H=-s5.H; + s5.L=-s5.L; + s7=prod_dd_dd(s5,s6); + s8=prod_dd_d(u3,j+2); + a20=div_dd_dd(s7,s8); + a21=div_dd_dd(u7,u6); + A2=prod_dd_dd(a20,a21); +//--------------iteration-----------------------------------// + temp1=two_prod(Ac.H,P[i+1]); + temp2=two_prod(A1.H,b1); + temp3=two_prod(A2.H,b2); + temp4=two_sum(temp1.H,temp2.H); + temp5=two_sum(temp3.H,temp4.H); + temp=temp1.L+temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=Ac.L*P[i+1]+A1.L*b1+A2.L*b2+A1.H*errb1+A2.H*errb2+temp; + + b2=b1; + b1=temp5.H; + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(b1,errb1); + res.H=C*res.H; + res.L=C*res.L; + + return res; +} + +/*JacobDerK evaluates the k-th derivative of a series of Jacobobi polynomial at the point x, which is in [-1, 1]. */ +double JacobDerK(double *P, unsigned int n, double x, double alpha, double beta, unsigned int k) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double t,b1=0,b2=0; + double A1, A2,s; + double a10,a11,a12,a20,a21; + int i,j; + double C=1.0; + for(i=k;i>0;i--) + { + C=C/2.0; + } + + for(i=n-k; i>=0; i--) + { +//-------------recurrence coefficients-----------------------// + s=1.0; + for(j=1;j<=k;j++) + { + s=s*(alpha+beta+i+k+j); + } + a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); + a11=(2*i+2+2*k+alpha+beta)*x; + a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); + A1=a10*(a11+a12); + + a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); + a21=(alpha+beta+2*i+4+2*k)/(alpha+beta+2*i+2+2*k); + A2=a20*a21; +//--------------iteration-----------------------------------// + t=A1*b1+A2*b2+s*P[i+k]; + + b2=b1; + b1=t; + } + return C*b1; +} + +/*CompJacobDerK evaluates the k-th derivative of a series of Jacobobi polynomial at the point x, which is in [-1, 1], with compensated method */ +double CompJacobDerK(double *P, unsigned int n, double x, double alpha, double beta, unsigned int k) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5; + dd_real A1, A2; + dd_real a10,a11,a12,a20,a21; + dd_real u,u1,u2,u3,u4,u5,u6,u7,u8,u9; + dd_real w,s1,s2,s3,s4,s5,s6,s7,s8; + int i,j; + double temp; + double C=1.0; + for(i=k;i>0;i--) + { + C=C/2.0; + } + u=two_sum(alpha,beta); + w=two_sum(alpha,-beta); + + for(j=n-k; j>=0; j--) + { + u1=add_dd_d(u,j+k+1); + u2=add_dd_d(u,j+2*k+1); + u3=add_dd_d(u,j+2*k+2); + u4=add_dd_d(u,2*j+2*k); + u5=add_dd_d(u,2*j+2*k+1); + u6=add_dd_d(u,2*j+2*k+2); + u7=add_dd_d(u,2*j+2*k+4); +//-------------recurrence coefficients-----------------------// + u9.H=1.0; + u9.L=0.0; + for(i=1;i<=k;i++) + { + u8=add_dd_d(u1,i-1); + u9=prod_dd_dd(u9,u8); + } + s1=prod_dd_d(u2,(2*j+2)); + a10=div_dd_dd(u5,s1); + a11=prod_dd_d(u6,x); + s2=add_dd_d(u,2*k); + s3=prod_dd_dd(w,s2); + a12=div_dd_dd(s3,u4); + s4=add_dd_dd(a11,a12); + A1=prod_dd_dd(a10,s4); + + s5=two_sum(j+1+k,alpha); + s6=two_sum(j+1+k,beta); + s5.H=-s5.H; + s5.L=-s5.L; + s7=prod_dd_dd(s5,s6); + s8=prod_dd_d(u3,j+2); + a20=div_dd_dd(s7,s8); + a21=div_dd_dd(u7,u6); + A2=prod_dd_dd(a20,a21); +//--------------iteration-----------------------------------// + temp1=two_prod(u9.H,P[j+k]); + temp2=two_prod(A1.H,b1); + temp3=two_prod(A2.H,b2); + temp4=two_sum(temp1.H,temp2.H); + temp5=two_sum(temp3.H,temp4.H); + temp=temp1.L+temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=u9.L*P[j+k]+A1.L*b1+A2.L*b2+A1.H*errb1+A2.H*errb2+temp; + + b2=b1; + b1=temp5.H; + errb2=errb1; + errb1=err_temp; + } + res=C*(b1+errb1); + return res; +} + +/*AccJacobDerK evaluates the k-th derivative of a series of Jacobobi polynomial at the point x, which is in [-1, 1], with compensated method */ +dd_real AccJacobDerK(double *P, unsigned int n, double x, double alpha, double beta, unsigned int k) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + dd_real A1, A2; + dd_real a10,a11,a12,a20,a21; + dd_real u,u1,u2,u3,u4,u5,u6,u7,u8,u9; + dd_real w,s1,s2,s3,s4,s5,s6,s7,s8; + int i,j; + double temp; + double C=1.0; + for(i=k;i>0;i--) + { + C=C/2.0; + } + u=two_sum(alpha,beta); + w=two_sum(alpha,-beta); + + for(j=n-k; j>=0; j--) + { + u1=add_dd_d(u,j+k+1); + u2=add_dd_d(u,j+2*k+1); + u3=add_dd_d(u,j+2*k+2); + u4=add_dd_d(u,2*j+2*k); + u5=add_dd_d(u,2*j+2*k+1); + u6=add_dd_d(u,2*j+2*k+2); + u7=add_dd_d(u,2*j+2*k+4); +//-------------recurrence coefficients-----------------------// + u9.H=1.0; + u9.L=0.0; + for(i=1;i<=k;i++) + { + u8=add_dd_d(u1,i-1); + u9=prod_dd_dd(u9,u8); + } + s1=prod_dd_d(u2,(2*j+2)); + a10=div_dd_dd(u5,s1); + a11=prod_dd_d(u6,x); + s2=add_dd_d(u,2*k); + s3=prod_dd_dd(w,s2); + a12=div_dd_dd(s3,u4); + s4=add_dd_dd(a11,a12); + A1=prod_dd_dd(a10,s4); + + s5=two_sum(j+1+k,alpha); + s6=two_sum(j+1+k,beta); + s5.H=-s5.H; + s5.L=-s5.L; + s7=prod_dd_dd(s5,s6); + s8=prod_dd_d(u3,j+2); + a20=div_dd_dd(s7,s8); + a21=div_dd_dd(u7,u6); + A2=prod_dd_dd(a20,a21); +//--------------iteration-----------------------------------// + temp1=two_prod(u9.H,P[j+k]); + temp2=two_prod(A1.H,b1); + temp3=two_prod(A2.H,b2); + temp4=two_sum(temp1.H,temp2.H); + temp5=two_sum(temp3.H,temp4.H); + temp=temp1.L+temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=u9.L*P[j+k]+A1.L*b1+A2.L*b2+A1.H*errb1+A2.H*errb2+temp; + + b2=b1; + b1=temp5.H; + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(C*b1,C*errb1); + return res; +} + +/*----------------------- JacobValwErr evaluates a series of Jacobobi polynomial at the point x, which is in [-1, 1], and performs a running-error bound */ +double JacobValwErr(double *P, unsigned int n, double x, double alpha, double beta, double * runerrbound) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double t,b1=0,b2=0; + int j; + double abst=0,absb1=0; + int na,nb; + na=6; + nb=5; + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + double coef1; + + double *A=(double *) malloc(sizeof(double)*(n+2)); + double *B=(double *) malloc(sizeof(double)*(n+2)); + double *C=(double *) malloc(sizeof(double)*(n+2)); + + RecurCoefJacob(n,alpha,beta,A,B,C); + + for(j=n; j>=0; j--) + { + coef1=(*(A+j)*x+*(B+j)); + t=coef1*b1-*(C+j+1)*b2+P[j]; + abst=fabs(t); + + errz=errz1*fabs(coef1)+errz2*fabs(*(C+j+1))+fabs(P[j]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + free(A); + free(B); + free(C); + *(runerrbound)=(errz1-(2+na)*abst)*unit; + + return b1; +} + +/*----------------------- JacobDerwErr evaluates the first derivative of a series of Jacobi polynomial at the point x, which is in [-1, 1], and performs a running-error bound */ +double JacobDerwErr(double *P, unsigned int n, double x, double alpha, double beta, double * runerrbound) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double t,b1=0,b2=0; + double Ac, A1, A2; + double a10,a11,a12,a20,a21; + int i; + double j; + double C=0.5; + + double abst=0,absb1=0; + int na,nb,nc; + na=7; + nb=5; + nc=2; + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-1; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + Ac=j+2+alpha+beta; + a10=(2*j+3+alpha+beta)/((2*j+2)*(j+3+alpha+beta)); + a11=(2*j+4+alpha+beta)*x; + a12=((alpha-beta)*(alpha+beta+2))/(alpha+beta+2*j+2); + A1=a10*(a11+a12); + a20=-(j+2+alpha)*(j+2+beta)/((j+2)*(alpha+beta+j+4)); + a21=(alpha+beta+2*j+6)/(alpha+beta+2*j+4); + A2=a20*a21; +//--------------iteration-----------------------------------// + t=A1*b1+A2*b2+Ac*P[i+1]; + abst=fabs(t); + + errz=errz1*fabs(A1)+errz2*fabs(A2)+(nc+2)*fabs(Ac)*fabs(P[i+1]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + *(runerrbound)=(errz1-(1+na)*abst)*unit*C; + return C*b1; +} + +/*----------------------- JacobDerKwErr evaluates the k-th derivative of a series of Jacobi polynomial at the point x, which is in [-1, 1], and performs a running-error bound */ +double JacobDerKwErr(double *P, unsigned int n, double x, double alpha, double beta, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double t,b1=0,b2=0; + double A1, A2,s; + double a10,a11,a12,a20,a21; + int i,j; + double C=1.0; + for(i=k;i>0;i--) + { + C=C/2.0; + } + + double abst=0,absb1=0; + int na,nb,nc; + na=7; + nb=5; + nc=k+1; + if (k==0){ + na=6; + nc=1; + } + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-k; i>=0; i--) + { +//-------------recurrence coefficients-----------------------// + s=1.0; + for(j=1;j<=k;j++) + { + s=s*(alpha+beta+i+k+j); + } + + a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); + a11=(2*i+2+2*k+alpha+beta)*x; + a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); + A1=a10*(a11+a12); + + a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); + a21=(alpha+beta+2*i+4+2*k)/(alpha+beta+2*i+2+2*k); + A2=a20*a21; +//--------------iteration-----------------------------------// + t=A1*b1+A2*b2+s*P[i+k]; + abst=fabs(t); + + errz=errz1*fabs(A1)+errz2*fabs(A2)+(nc+2)*fabs(s)*fabs(P[i+k]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + *(runerrbound)=(errz1-(1+na)*abst)*unit*C; + return C*b1; +} + +/*----------------------- CompJacobValwErr evaluates a series of Jacobi polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +double CompJacobValwErr(double *P, unsigned int n, double x, double alpha, double beta, double * runerrbound) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double res,err_temp, err_temp1, err_temp2, err_temp3, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5,temp6; + int j; + + double abst=0,absb1=0; + int na,nb,ne; + na=6; + nb=5; + ne=9; + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + dd_real *A=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *B=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *C=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + + RecurCoefJacob_DD(n,alpha,beta,A,B,C); + + for(j=n; j>=0; j--) + { + temp1=two_prod((A+j)->H,x); + temp2=two_sum(temp1.H,(B+j)->H); + temp3=two_prod(temp2.H,b1); + + temp4=two_prod((C+j+1)->H,b2); + temp5=two_sum(temp3.H,-temp4.H); + temp6=two_sum(temp5.H,P[j]); +//--------------the compensated part---------------// + err_temp1=(temp1.L+temp2.L)*b1+temp3.L; + err_temp2=(((A+j)->L)*x+((B+j)->L))*b1-((C+j+1)->L)*b2; + err_temp3=err_temp1-temp4.L+temp5.L+temp6.L+err_temp2; + err_temp=temp2.H*errb1-((C+j+1)->H)*errb2+err_temp3; +//--------------the running error bound-----------// + abst=fabs(err_temp); + errz=errz1*fabs(temp2.H)+errz2*fabs((C+j+1)->H)+(ne+1)*fabs(err_temp3); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; +//--------------the next iteration-----------------// + b2=b1; + b1=temp6.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=b1+errb1; + *(runerrbound)=((errz1-(2+na)*abst)*unit+fabs(errb1-(res-b1)))/(1-unit*2); + free(A); + free(B); + free(C); + + return res; +} + +/*----------------------- CompJacobDerwErr evaluates the first derivative of a series of Jacobi polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +double CompJacobDerwErr(double *P, unsigned int n, double x, double alpha, double beta, double * runerrbound) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5; + dd_real Ac, A1, A2; + dd_real a10,a11,a12,a20,a21; + dd_real u,u1,u2,u3,u4,u5,u6,u7; + dd_real w,s1,s2,s3,s4,s5,s6,s7,s8; + int i; + double j; + double C=0.5; + + double abst=0,absb1=0; + int na,nb,ne; + na=7; + nb=5; + ne=8; + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + u=two_sum(alpha,beta); + w=two_sum(alpha,-beta); + + for(i=n-1; i>=0; i--) + { + j=1.0*i; + u1=add_dd_d(u,j+2); + u2=add_dd_d(u,j+3); + u3=add_dd_d(u,j+4); + u4=add_dd_d(u,2*j+2); + u5=add_dd_d(u,2*j+3); + u6=add_dd_d(u,2*j+4); + u7=add_dd_d(u,2*j+6); +//-------------recurrence coefficients-----------------------// + Ac=u1; + + s1=prod_dd_d(u2,(2*j+2)); + a10=div_dd_dd(u5,s1); + a11=prod_dd_d(u6,x); + s2=add_dd_d(u,2); + s3=prod_dd_dd(w,s2); + a12=div_dd_dd(s3,u4); + s4=add_dd_dd(a11,a12); + A1=prod_dd_dd(a10,s4); + + s5=two_sum(j+2,alpha); + s6=two_sum(j+2,beta); + s5.H=-s5.H; + s5.L=-s5.L; + s7=prod_dd_dd(s5,s6); + s8=prod_dd_d(u3,j+2); + a20=div_dd_dd(s7,s8); + a21=div_dd_dd(u7,u6); + A2=prod_dd_dd(a20,a21); +//--------------iteration-----------------------------------// + temp1=two_prod(Ac.H,P[i+1]); + temp2=two_prod(A1.H,b1); + temp3=two_prod(A2.H,b2); + temp4=two_sum(temp1.H,temp2.H); + temp5=two_sum(temp3.H,temp4.H); +//--------------the compensated part------------------------// + err_P=Ac.L*P[i+1]+A1.L*b1+A2.L*b2+temp1.L+temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=A1.H*errb1+A2.H*errb2+err_P; +//--------------the runninge error bound-------------------// + abst=fabs(err_temp); + errz=errz1*fabs(A1.H)+errz2*fabs(A2.H)+(ne+1)*fabs(err_P); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=temp5.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=C*(b1+errb1); + *(runerrbound)=((errz1-(1+na)*abst)*unit*C+fabs(C*errb1-(res-C*b1)))/(1-unit*2); + + return res; +} + +/*----------------------- CompJacobDerKwErr evaluates the k-th derivative of a series of Jacobi polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +double CompJacobDerKwErr(double *P, unsigned int n, double x, double alpha, double beta, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5; + dd_real A1, A2; + dd_real a10,a11,a12,a20,a21; + dd_real u,u1,u2,u3,u4,u5,u6,u7,u8,u9; + dd_real w,s1,s2,s3,s4,s5,s6,s7,s8; + int i,j; + double C=1.0; + for(i=k;i>0;i--) + { + C=C/2.0; + } + u=two_sum(alpha,beta); + w=two_sum(alpha,-beta); + + double abst=0,absb1=0; + int na,nb,ne; + na=7; + nb=5; + ne=8; + if(k==0){ + na=6; + ne=9; + } + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + u=two_sum(alpha,beta); + w=two_sum(alpha,-beta); + + for(j=n-k; j>=0; j--) + { + u1=add_dd_d(u,j+k+1); + u2=add_dd_d(u,j+2*k+1); + u3=add_dd_d(u,j+2*k+2); + u4=add_dd_d(u,2*j+2*k); + u5=add_dd_d(u,2*j+2*k+1); + u6=add_dd_d(u,2*j+2*k+2); + u7=add_dd_d(u,2*j+2*k+4); +//-------------recurrence coefficients-----------------------// + u9.H=1.0; + u9.L=0.0; + for(i=1;i<=k;i++) + { + u8=add_dd_d(u1,i-1); + u9=prod_dd_dd(u9,u8); + } + + s1=prod_dd_d(u2,(2*j+2)); + a10=div_dd_dd(u5,s1); + a11=prod_dd_d(u6,x); + s2=add_dd_d(u,2*k); + s3=prod_dd_dd(w,s2); + a12=div_dd_dd(s3,u4); + s4=add_dd_dd(a11,a12); + A1=prod_dd_dd(a10,s4); + + s5=two_sum(j+1+k,alpha); + s6=two_sum(j+1+k,beta); + s5.H=-s5.H; + s5.L=-s5.L; + s7=prod_dd_dd(s5,s6); + s8=prod_dd_d(u3,j+2); + a20=div_dd_dd(s7,s8); + a21=div_dd_dd(u7,u6); + A2=prod_dd_dd(a20,a21); +//--------------iteration-----------------------------------// + temp1=two_prod(u9.H,P[j+k]); + temp2=two_prod(A1.H,b1); + temp3=two_prod(A2.H,b2); + temp4=two_sum(temp1.H,temp2.H); + temp5=two_sum(temp3.H,temp4.H); +//--------------the compensated part------------------------// + err_P=u9.L*P[j+k]+A1.L*b1+A2.L*b2+temp1.L+temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=A1.H*errb1+A2.H*errb2+err_P; +//--------------the runninge error bound-------------------// + abst=fabs(err_temp); + errz=errz1*fabs(A1.H)+errz2*fabs(A2.H)+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=temp5.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=C*(b1+errb1); + *(runerrbound)=((errz1-(2+na)*abst)*unit*C+fabs(C*errb1-(res-C*b1)))/(1-unit*3); + + return res; +} + +/*----------------------- AccJacobValwErr evaluates a series of Jacobi polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +dd_real AccJacobValwErr(double *P, unsigned int n, double x, double alpha, double beta, double * runerrbound) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double err_temp, err_temp1, err_temp2, err_temp3, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5,temp6; + int j; + + double abst=0,absb1=0; + int na,nb,ne; + na=6; + nb=5; + ne=9; + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + dd_real *A=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *B=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *C=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + + RecurCoefJacob_DD(n,alpha,beta,A,B,C); + + for(j=n; j>=0; j--) + { + temp1=two_prod((A+j)->H,x); + temp2=two_sum(temp1.H,(B+j)->H); + temp3=two_prod(temp2.H,b1); + + temp4=two_prod((C+j+1)->H,b2); + temp5=two_sum(temp3.H,-temp4.H); + temp6=two_sum(temp5.H,P[j]); +//--------------the compensated part---------------// + err_temp1=(temp1.L+temp2.L)*b1+temp3.L; + err_temp2=(((A+j)->L)*x+((B+j)->L))*b1-((C+j+1)->L)*b2; + err_temp3=err_temp1-temp4.L+temp5.L+temp6.L+err_temp2; + err_temp=temp2.H*errb1-((C+j+1)->H)*errb2+err_temp3; +//--------------the running error bound-----------// + abst=fabs(err_temp); + errz=errz1*fabs(temp2.H)+errz2*fabs((C+j+1)->H)+(ne+1)*fabs(err_temp3); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; +//--------------the next iteration-----------------// + b2=b1; + b1=temp6.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(b1,errb1); + *(runerrbound)=(errz1-(2+na)*abst)*unit; + free(A); + free(B); + free(C); + + return res; +} + +/*----------------------- AccJacobDerwErr evaluates the first derivative of a series of Jacobi polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +dd_real AccJacobDerwErr(double *P, unsigned int n, double x, double alpha, double beta, double * runerrbound) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + dd_real Ac, A1, A2; + dd_real a10,a11,a12,a20,a21; + dd_real u,u1,u2,u3,u4,u5,u6,u7; + dd_real w,s1,s2,s3,s4,s5,s6,s7,s8; + int i; + double j; + double C=0.5; + + double abst=0,absb1=0; + int na,nb,ne; + na=7; + nb=5; + ne=8; + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + u=two_sum(alpha,beta); + w=two_sum(alpha,-beta); + + for(i=n-1; i>=0; i--) + { + j=1.0*i; + u1=add_dd_d(u,j+2); + u2=add_dd_d(u,j+3); + u3=add_dd_d(u,j+4); + u4=add_dd_d(u,2*j+2); + u5=add_dd_d(u,2*j+3); + u6=add_dd_d(u,2*j+4); + u7=add_dd_d(u,2*j+6); +//-------------recurrence coefficients-----------------------// + Ac=u1; + + s1=prod_dd_d(u2,(2*j+2)); + a10=div_dd_dd(u5,s1); + a11=prod_dd_d(u6,x); + s2=add_dd_d(u,2); + s3=prod_dd_dd(w,s2); + a12=div_dd_dd(s3,u4); + s4=add_dd_dd(a11,a12); + A1=prod_dd_dd(a10,s4); + + s5=two_sum(j+2,alpha); + s6=two_sum(j+2,beta); + s5.H=-s5.H; + s5.L=-s5.L; + s7=prod_dd_dd(s5,s6); + s8=prod_dd_d(u3,j+2); + a20=div_dd_dd(s7,s8); + a21=div_dd_dd(u7,u6); + A2=prod_dd_dd(a20,a21); +//--------------iteration-----------------------------------// + temp1=two_prod(Ac.H,P[i+1]); + temp2=two_prod(A1.H,b1); + temp3=two_prod(A2.H,b2); + temp4=two_sum(temp1.H,temp2.H); + temp5=two_sum(temp3.H,temp4.H); +//--------------the compensated part------------------------// + err_P=Ac.L*P[i+1]+A1.L*b1+A2.L*b2+temp1.L+temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=A1.H*errb1+A2.H*errb2+err_P; +//--------------the runninge error bound-------------------// + abst=fabs(err_temp); + errz=errz1*fabs(A1.H)+errz2*fabs(A2.H)+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=temp5.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(b1,errb1); + res.H=C*res.H; + res.L=C*res.L; + *(runerrbound)=(errz1-(1+na)*abst)*unit*C; + + return res; +} + +/*----------------------- AccJacobDerKwErr evaluates the k-th derivative of a series of Jacobi polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +dd_real AccJacobDerKwErr(double *P, unsigned int n, double x, double alpha, double beta, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + assert (fabs(x)<=1.0); + assert (alpha>-1.0); + assert (beta>-1.0); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5; + dd_real A1, A2; + dd_real a10,a11,a12,a20,a21; + dd_real u,u1,u2,u3,u4,u5,u6,u7,u8,u9; + dd_real w,s1,s2,s3,s4,s5,s6,s7,s8; + int i,j; + double C=1.0; + for(i=k;i>0;i--) + { + C=C/2.0; + } + u=two_sum(alpha,beta); + w=two_sum(alpha,-beta); + + double abst=0,absb1=0; + int na,nb,ne; + na=7; + nb=5; + ne=8; + if(k==0){ + na=6; + ne=9; + } + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + u=two_sum(alpha,beta); + w=two_sum(alpha,-beta); + + for(j=n-k; j>=0; j--) + { + u1=add_dd_d(u,j+k+1); + u2=add_dd_d(u,j+2*k+1); + u3=add_dd_d(u,j+2*k+2); + u4=add_dd_d(u,2*j+2*k); + u5=add_dd_d(u,2*j+2*k+1); + u6=add_dd_d(u,2*j+2*k+2); + u7=add_dd_d(u,2*j+2*k+4); +//-------------recurrence coefficients-----------------------// + u9.H=1.0; + u9.L=0.0; + for(i=1;i<=k;i++) + { + u8=add_dd_d(u1,i-1); + u9=prod_dd_dd(u9,u8); + } + + s1=prod_dd_d(u2,(2*j+2)); + a10=div_dd_dd(u5,s1); + a11=prod_dd_d(u6,x); + s2=add_dd_d(u,2*k); + s3=prod_dd_dd(w,s2); + a12=div_dd_dd(s3,u4); + s4=add_dd_dd(a11,a12); + A1=prod_dd_dd(a10,s4); + + s5=two_sum(j+1+k,alpha); + s6=two_sum(j+1+k,beta); + s5.H=-s5.H; + s5.L=-s5.L; + s7=prod_dd_dd(s5,s6); + s8=prod_dd_d(u3,j+2); + a20=div_dd_dd(s7,s8); + a21=div_dd_dd(u7,u6); + A2=prod_dd_dd(a20,a21); +//--------------iteration-----------------------------------// + temp1=two_prod(u9.H,P[j+k]); + temp2=two_prod(A1.H,b1); + temp3=two_prod(A2.H,b2); + temp4=two_sum(temp1.H,temp2.H); + temp5=two_sum(temp3.H,temp4.H); +//--------------the compensated part------------------------// + err_P=u9.L*P[j+k]+A1.L*b1+A2.L*b2+temp1.L+temp2.L+temp3.L+temp4.L+temp5.L; + err_temp=A1.H*errb1+A2.H*errb2+err_P; +//--------------the runninge error bound-------------------// + abst=fabs(err_temp); + errz=errz1*fabs(A1.H)+errz2*fabs(A2.H)+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=temp5.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(C*b1,C*errb1); + *(runerrbound)=(errz1-(2+na)*abst)*unit*C; + + return res; +} + + + + + + + + + + + + + + + diff --git a/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/laguerre_series.c b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/laguerre_series.c new file mode 100644 index 000000000..1b12344f8 --- /dev/null +++ b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/laguerre_series.c @@ -0,0 +1,973 @@ +/****************************************************************************** +% Set of subroutines and functions to evaluate series of LAGUERRE polynomials at the point x, which is in (0, +infty). +% It allows to evaluate the series and derivatives of it at any point using standard double precision with and without +% error bounds to provide information of the quality of the evaluation. It also allows ACCURATE evaluations using +% a new compensated algorithm. +% +% Licensing: +% +% This code is distributed under the GNU General Public License 3 (GPLv3). +% +% Modified: +% +% 8 November 2016 +% +% Authors: +% +% Roberto Barrio, Peibing Du, Hao Jiang and Sergio Serrano +% +% Algorithm: +% BCS-algorithm with running error bound +% References: +% R. Barrio, J.M. Pe~na, +% Numerical evaluation of the pth derivative of Jacobi series, +% Applied Numerical Mathmetics 43 335-357, (2002). +% +% H. Jiang, R. Barrio, H. Li, X. Liao, L. Cheng, F. Su, +% Accurate evaluation of a polynomial in Chebyshev form +% Applied Mathematics and Computation 217 (23), 9702-9716, (2011). +%*****************************************************************************/ + +#include +#include +#include +#include + +#include"inline.h" +#include"laguerre_series.h" + +//----------------------- The three-term recurrence coefficients of laguerre polynomial ---------------------------------- +void RecurCoefLague (double n, double alpha, double *A, double *B, double *C) +{ + int i; + double j; + for (i=1;i<=n+2;i++) + { + j=1.0*i; + *(A+i-1)=-1/j; + *(B+i-1)=(2*j+alpha-1)/j; + *(C+i-1)=(j-1+alpha)/j; + } +} + +void RecurCoefLague_DD (double n, double alpha, dd_real *A, dd_real *B, dd_real *C) +{ + int i; + double j; + dd_real s0,s1; + + for (i=1;i<=n+2;i++) + { + j=1.0*i; + *(A+i-1)=div_d_d(-1,j); + s0=two_sum(2*j-1,alpha); + *(B+i-1)=div_dd_d(s0,j); + s1=two_sum(j-1,alpha); + *(C+i-1)=div_dd_d(s1,j); + } +} + +/* LagueVal evaluates a series of Laguerre polynomial at the point x, which is in (0, +infty).*/ +double LagueVal(double *P, unsigned int n, double x, double alpha) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double t,b1=0,b2=0; + int j; + + double *A=(double *) malloc(sizeof(double)*(n+2)); + double *B=(double *) malloc(sizeof(double)*(n+2)); + double *C=(double *) malloc(sizeof(double)*(n+2)); + + RecurCoefLague(n,alpha,A,B,C); + + for(j=n; j>=0; j--) + { + t=(*(A+j)*x+*(B+j))*b1-*(C+j+1)*b2+P[j]; + + b2=b1; + b1=t; + } + free(A); + free(B); + free(C); + + return b1; +} + +/*CompLagueVal evaluates a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method.*/ +double CompLagueVal(double *P, unsigned int n, double x, double alpha) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0, res; + double err_temp, err_temp1, err_temp2, err_temp3, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5,temp6; + int j; + + dd_real *A=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *B=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *C=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + + RecurCoefLague_DD(n,alpha,A,B,C); + + for(j=n; j>=0; j--) + { + temp1=two_prod((A+j)->H,x); + temp2=two_sum(temp1.H,(B+j)->H); + temp3=two_prod(temp2.H,b1); + + temp4=two_prod((C+j+1)->H,b2); + temp5=two_sum(temp3.H,-temp4.H); + temp6=two_sum(temp5.H,P[j]); +//--------------the compensated part---------------// + err_temp1=(temp1.L+temp2.L)*b1+temp3.L; + err_temp2=(((A+j)->L)*x+((B+j)->L))*b1-((C+j+1)->L)*b2; + err_temp3=err_temp1-temp4.L+temp5.L+temp6.L+err_temp2; + err_temp=temp2.H*errb1-((C+j+1)->H)*errb2+err_temp3; +//--------------the next iteration-----------------// + b2=b1; + b1=temp6.H; + errb2=errb1; + errb1=err_temp; + } + res=b1+errb1; + free(A); + free(B); + free(C); + + return res; +} + +/*AccLagueVal evaluates a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method.*/ +dd_real AccLagueVal(double *P, unsigned int n, double x, double alpha) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double err_temp, err_temp1, err_temp2, err_temp3, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5,temp6; + int j; + + dd_real *A=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *B=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *C=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + + RecurCoefLague_DD(n,alpha,A,B,C); + + for(j=n; j>=0; j--) + { + temp1=two_prod((A+j)->H,x); + temp2=two_sum(temp1.H,(B+j)->H); + temp3=two_prod(temp2.H,b1); + + temp4=two_prod((C+j+1)->H,b2); + temp5=two_sum(temp3.H,-temp4.H); + temp6=two_sum(temp5.H,P[j]); +//--------------the compensated part---------------// + err_temp1=(temp1.L+temp2.L)*b1+temp3.L; + err_temp2=(((A+j)->L)*x+((B+j)->L))*b1-((C+j+1)->L)*b2; + err_temp3=err_temp1-temp4.L+temp5.L+temp6.L+err_temp2; + err_temp=temp2.H*errb1-((C+j+1)->H)*errb2+err_temp3; +//--------------the next iteration-----------------// + b2=b1; + b1=temp6.H; + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(b1,errb1); + free(A); + free(B); + free(C); + + return res; +} + +/*LagueDer evaluates the first derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty). */ +double LagueDer(double *P, unsigned int n, double x, double alpha) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double t,b1=0,b2=0; + double A1,A2; + int i; + double j; + double C=1; + + for(i=n-1; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + A1=-x/(j+1)+(2*j+alpha+2)/(j+1); + A2=-(j+alpha+2)/(j+2); +//--------------iteration-----------------------------------// + t=A1*b1+A2*b2-P[i+1]; + + b2=b1; + b1=t; + } + return C*b1; +} + +/*CompLagueDer evaluates the first derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method */ +double CompLagueDer(double *P, unsigned int n, double x, double alpha) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0, res; + dd_real temp1,temp2,temp3,temp4; + dd_real A1,A2; + dd_real s0,s1,s2; + int i; + double j,temp; + + for(i=n-1; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + s0=two_sum(2*j+2,alpha); + s1=add_dd_d(s0,-x); + A1=div_dd_d(s1,j+1); + + s2=two_sum(j+2,alpha); + s2.H=-s2.H; + s2.L=-s2.L; + A2=div_dd_d(s2,j+2); +//--------------iteration-----------------------------------// + temp1=two_prod(A1.H,b1); + temp2=two_prod(A2.H,b2); + temp3=two_sum(-P[i+1],temp1.H); + temp4=two_sum(temp2.H,temp3.H); + temp=temp1.L+temp2.L+temp3.L+temp4.L; + err_temp=A1.L*b1+A2.L*b2+A1.H*errb1+A2.H*errb2+temp; + + b2=b1; + b1=temp4.H; + errb2=errb1; + errb1=err_temp; + } + res=b1+errb1; + + return res; +} + +/*AccLagueDer evaluates the first derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method */ +dd_real AccLagueDer(double *P, unsigned int n, double x, double alpha) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4; + dd_real A1,A2; + dd_real s0,s1,s2; + int i; + double j,temp; + + for(i=n-1; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + s0=two_sum(2*j+2,alpha); + s1=add_dd_d(s0,-x); + A1=div_dd_d(s1,j+1); + + s2=two_sum(j+2,alpha); + s2.H=-s2.H; + s2.L=-s2.L; + A2=div_dd_d(s2,j+2); +//--------------iteration-----------------------------------// + temp1=two_prod(A1.H,b1); + temp2=two_prod(A2.H,b2); + temp3=two_sum(-P[i+1],temp1.H); + temp4=two_sum(temp2.H,temp3.H); + temp=temp1.L+temp2.L+temp3.L+temp4.L; + err_temp=A1.L*b1+A2.L*b2+A1.H*errb1+A2.H*errb2+temp; + + b2=b1; + b1=temp4.H; + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(b1,errb1); + + return res; +} + +/*LagueDerK evaluates the k-th derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty). */ +double LagueDerK(double *P, unsigned int n, double x, double alpha, unsigned int k) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double t,b1=0,b2=0; + double A1,A2; + int i; + double j; + int C=1; + for(i=k;i>0;i--) + { + C=-C; + } + + for(i=n-k; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + A1=-x/(j+1)+(2*j+alpha+k+1)/(j+1); + A2=-(j+alpha+k+1)/(j+2); +//--------------iteration-----------------------------------// + t=A1*b1+A2*b2+P[i+k]; + + b2=b1; + b1=t; + } + return C*b1; +} + +/*CompLagueDerK evaluates the k-th derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method */ +double CompLagueDerK(double *P, unsigned int n, double x, double alpha, unsigned int k) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0, res; + dd_real temp1,temp2,temp3,temp4; + dd_real A1,A2; + dd_real s0,s1,s2; + int i; + double j,temp; + int C=1; + for(i=k;i>0;i--) + { + C=-C; + } + + for(i=n-k; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + s0=two_sum(2*j+k+1,alpha); + s1=add_dd_d(s0,-x); + A1=div_dd_d(s1,j+1); + + s2=two_sum(j+k+1,alpha); + A2=div_dd_d(s2,-j-2); +//--------------iteration-----------------------------------// + temp1=two_prod(A1.H,b1); + temp2=two_prod(A2.H,b2); + temp3=two_sum(P[i+k],temp1.H); + temp4=two_sum(temp2.H,temp3.H); + temp=temp1.L+temp2.L+temp3.L+temp4.L; + err_temp=A1.L*b1+A2.L*b2+A1.H*errb1+A2.H*errb2+temp; + + b2=b1; + b1=temp4.H; + errb2=errb1; + errb1=err_temp; + } + res=C*(b1+errb1); + + return res; +} + +/*AccLagueDerK evaluates the k-th derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method */ +dd_real AccLagueDerK(double *P, unsigned int n, double x, double alpha, unsigned int k) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4; + dd_real A1,A2; + dd_real s0,s1,s2; + int i; + double j,temp; + int C=1; + for(i=k;i>0;i--) + { + C=-C; + } + + for(i=n-k; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + s0=two_sum(2*j+k+1,alpha); + s1=add_dd_d(s0,-x); + A1=div_dd_d(s1,j+1); + + s2=two_sum(j+k+1,alpha); + A2=div_dd_d(s2,-j-2); +//--------------iteration-----------------------------------// + temp1=two_prod(A1.H,b1); + temp2=two_prod(A2.H,b2); + temp3=two_sum(P[i+k],temp1.H); + temp4=two_sum(temp2.H,temp3.H); + temp=temp1.L+temp2.L+temp3.L+temp4.L; + err_temp=A1.L*b1+A2.L*b2+A1.H*errb1+A2.H*errb2+temp; + + b2=b1; + b1=temp4.H; + errb2=errb1; + errb1=err_temp; + } + res=quick_two_sum(C*b1,C*errb1); + + return res; +} + +/*----------------------- LagueValwErr evaluates a series of Laguerre polynomial at the point x, which is in (0, +infty), and performs a running-error bound */ +double LagueValwErr(double *P, unsigned int n, double x, double alpha, double * runerrbound) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double t,b1=0,b2=0; + int j; + double abst=0,absb1=0; + int na,nb; + na=3; + nb=2; + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + double coef1; + + double *A=(double *) malloc(sizeof(double)*(n+2)); + double *B=(double *) malloc(sizeof(double)*(n+2)); + double *C=(double *) malloc(sizeof(double)*(n+2)); + + RecurCoefLague(n,alpha,A,B,C); + + for(j=n; j>=0; j--) + { + coef1=(*(A+j)*x+*(B+j)); + t=coef1*b1-*(C+j+1)*b2+P[j]; + abst=fabs(t); + + errz=errz1*fabs(coef1)+errz2*fabs(*(C+j+1))+fabs(P[j]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + free(A); + free(B); + free(C); + *(runerrbound)=(errz1-(2+na)*abst)*unit; + + return b1; +} + +/*----------------------- LagueDerwErr evaluates the first derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty), and performs a running-error bound */ +double LagueDerwErr(double *P, unsigned int n, double x, double alpha, double * runerrbound) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double t,b1=0,b2=0; + double A1, A2; + int i; + double j; + + double abst=0,absb1=0; + int na,nb,nc; + na=3; + nb=2; + nc=0; + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-1; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + A1=(2*(j+1)+alpha-x)/(j+1); + A2=-(j+alpha+2)/(j+2); +//--------------iteration-----------------------------------// + t=A1*b1+A2*b2-P[i+1]; + abst=fabs(t); + + errz=errz1*fabs(A1)+errz2*fabs(A2)+(nc+2)*fabs(P[i+1]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + *(runerrbound)=(errz1-(1+na)*abst)*unit; + return b1; +} + +/*----------------------- LagueDerKwErr evaluates the k-th derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty), and performs a running-error bound */ +double LagueDerKwErr(double *P, unsigned int n, double x, double alpha, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double t,b1=0,b2=0; + double A1,A2; + int i; + double j; + int C=1; + for(i=k;i>0;i--) + { + C=-C; + } + double abst=0,absb1=0; + int na,nb,nc; + na=3; + nb=2; + nc=0; + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-k; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + A1=-x/(j+1)+(2*j+alpha+k+1)/(j+1); + A2=-(j+alpha+k+1)/(j+2); +//--------------iteration-----------------------------------// + t=A1*b1+A2*b2+P[i+k]; + abst=fabs(t); + + errz=errz1*fabs(A1)+errz2*fabs(A2)+(nc+2)*fabs(P[i+k]); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=t; + + errztemp=errz; + absb1=abst; + } + *(runerrbound)=(errz1-(1+na)*abst)*unit; + return C*b1; +} + +/*----------------------- CompLagueValwErr evaluates a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method, and performs a running-error bound */ +double CompLagueValwErr(double *P, unsigned int n, double x, double alpha, double * runerrbound) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double res,err_temp, err_temp1, err_temp2, err_temp3, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4,temp5,temp6; + int j; + + double abst=0,absb1=0; + int na,nb,ne; + na=3; + nb=2; + ne=9; + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + dd_real *A=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *B=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *C=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + + RecurCoefLague_DD(n,alpha,A,B,C); + + for(j=n; j>=0; j--) + { + temp1=two_prod((A+j)->H,x); + temp2=two_sum(temp1.H,(B+j)->H); + temp3=two_prod(temp2.H,b1); + + temp4=two_prod((C+j+1)->H,b2); + temp5=two_sum(temp3.H,-temp4.H); + temp6=two_sum(temp5.H,P[j]); +//--------------the compensated part---------------// + err_temp1=(temp1.L+temp2.L)*b1+temp3.L; + err_temp2=(((A+j)->L)*x+((B+j)->L))*b1-((C+j+1)->L)*b2; + err_temp3=err_temp1-temp4.L+temp5.L+temp6.L+err_temp2; + err_temp=temp2.H*errb1-((C+j+1)->H)*errb2+err_temp3; +//--------------the running error bound-----------// + abst=fabs(err_temp); + errz=errz1*fabs(temp2.H)+errz2*fabs((C+j+1)->H)+(ne+1)*fabs(err_temp3); + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; +//--------------the next iteration-----------------// + b2=b1; + b1=temp6.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=b1+errb1; + *(runerrbound)=((errz1-(2+na)*abst)*unit+fabs(errb1-(res-b1)))/(1-unit*2); + free(A); + free(B); + free(C); + + return res; +} + +/*----------------------- CompLagueDerwErr evaluates the first derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method, and performs a running-error bound */ +double CompLagueDerwErr(double *P, unsigned int n, double x, double alpha, double * runerrbound) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4; + dd_real A1, A2; + dd_real s0,s1,s2; + int i; + double j; + + double abst=0,absb1=0; + int na,nb,ne; + na=3; + nb=2; + ne=6; + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-1; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + s0=two_sum(2*j+2,alpha); + s1=add_dd_d(s0,-x); + A1=div_dd_d(s1,j+1); + + s2=two_sum(j+2,alpha); + s2.H=-s2.H; + s2.L=-s2.L; + A2=div_dd_d(s2,j+2); +//--------------iteration-----------------------------------// + temp1=two_prod(A1.H,b1); + temp2=two_prod(A2.H,b2); + temp3=two_sum(temp1.H,temp2.H); + temp4=two_sum(temp3.H,-P[i+1]); +//--------------the compensated part------------------------// + err_P=A1.L*b1+A2.L*b2+temp1.L+temp2.L+temp3.L+temp4.L; + err_temp=A1.H*errb1+A2.H*errb2+err_P; +//--------------the runninge error bound-------------------// + abst=fabs(err_temp); + errz=errz1*fabs(A1.H)+errz2*fabs(A2.H)+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=temp4.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=b1+errb1; + *(runerrbound)=((errz1-(1+na)*abst)*unit+fabs(errb1-(res-b1)))/(1-unit*2); + + return res; +} + +/*----------------------- CompLagueDerKwErr evaluates the k-th derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method, and performs a running-error bound */ +double CompLagueDerKwErr(double *P, unsigned int n, double x, double alpha, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double res,err_temp, errb1=0, errb2=0; + dd_real temp1,temp2,temp3,temp4; + dd_real A1,A2; + dd_real s0,s1,s2; + int i; + double j; + int C=1; + for(i=k;i>0;i--) + { + C=-C; + } + double abst=0,absb1=0; + int na,nb,ne; + na=3; + nb=2; + ne=6; + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-k; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + s0=two_sum(2*j+k+1,alpha); + s1=add_dd_d(s0,-x); + A1=div_dd_d(s1,j+1); + + s2=two_sum(j+k+1,alpha); + A2=div_dd_d(s2,-j-2); +//--------------iteration-----------------------------------// + temp1=two_prod(A1.H,b1); + temp2=two_prod(A2.H,b2); + temp3=two_sum(P[i+k],temp1.H); + temp4=two_sum(temp2.H,temp3.H); +//--------------the compensated part------------------------// + err_P=A1.L*b1+A2.L*b2+temp1.L+temp2.L+temp3.L+temp4.L; + err_temp=A1.H*errb1+A2.H*errb2+err_P; +//--------------the runninge error bound-------------------// + abst=fabs(err_temp); + errz=errz1*fabs(A1.H)+errz2*fabs(A2.H)+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=temp4.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=C*(b1+errb1); + *(runerrbound)=((errz1-(2+na)*abst)*unit+fabs(C*errb1-(res-C*b1)))/(1-unit*3); + + return res; +} + +/*----------------------- AccLagueValwErr evaluates a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method, and performs a running-error bound */ +dd_real AccLagueValwErr(double *P, unsigned int n, double x, double alpha, double * runerrbound) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double err_temp, err_temp1, err_temp2, err_temp3, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4,temp5,temp6; + int j; + + double abst=0,absb1=0; + int na,nb,ne; + na=3; + nb=2; + ne=9; + double errz,errz1,errz2, errztemp; + errz1=0; + errz2=0; + errztemp=0; + + dd_real *A=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *B=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + dd_real *C=(dd_real *) malloc(sizeof(dd_real)*(n+2)); + + RecurCoefLague_DD(n,alpha,A,B,C); + + for(j=n; j>=0; j--) + { + temp1=two_prod((A+j)->H,x); + temp2=two_sum(temp1.H,(B+j)->H); + temp3=two_prod(temp2.H,b1); + + temp4=two_prod((C+j+1)->H,b2); + temp5=two_sum(temp3.H,-temp4.H); + temp6=two_sum(temp5.H,P[j]); +//--------------the compensated part---------------// + err_temp1=(temp1.L+temp2.L)*b1+temp3.L; + err_temp2=(((A+j)->L)*x+((B+j)->L))*b1-((C+j+1)->L)*b2; + err_temp3=err_temp1-temp4.L+temp5.L+temp6.L+err_temp2; + err_temp=temp2.H*errb1-((C+j+1)->H)*errb2+err_temp3; +//--------------the running error bound-----------// + abst=fabs(err_temp); + errz=errz1*fabs(temp2.H)+errz2*fabs((C+j+1)->H)+(ne+1)*fabs(err_temp3); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; +//--------------the next iteration-----------------// + b2=b1; + b1=temp6.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(b1,errb1); + *(runerrbound)=(errz1-(2+na)*abst)*unit; + free(A); + free(B); + free(C); + + return res; +} + +/*----------------------- AccLagueDerwErr evaluates the first derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method, and performs a running-error bound */ +dd_real AccLagueDerwErr(double *P, unsigned int n, double x, double alpha, double * runerrbound) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4; + dd_real A1, A2; + dd_real s0,s1,s2; + int i; + double j; + + double abst=0,absb1=0; + int na,nb,ne; + na=3; + nb=2; + ne=6; + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-1; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + s0=two_sum(2*j+2,alpha); + s1=add_dd_d(s0,-x); + A1=div_dd_d(s1,j+1); + + s2=two_sum(j+2,alpha); + s2.H=-s2.H; + s2.L=-s2.L; + A2=div_dd_d(s2,j+2); +//--------------iteration-----------------------------------// + temp1=two_prod(A1.H,b1); + temp2=two_prod(A2.H,b2); + temp3=two_sum(temp1.H,temp2.H); + temp4=two_sum(temp3.H,-P[i+1]); +//--------------the compensated part------------------------// + err_P=A1.L*b1+A2.L*b2+temp1.L+temp2.L+temp3.L+temp4.L; + err_temp=A1.H*errb1+A2.H*errb2+err_P; +//--------------the runninge error bound-------------------// + abst=fabs(err_temp); + errz=errz1*fabs(A1.H)+errz2*fabs(A2.H)+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=temp4.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(b1,errb1); + *(runerrbound)=(errz1-(1+na)*abst)*unit; + + return res; +} + +/*----------------------- AccLagueDerKwErr evaluates the k-th derivative of a series of Laguerre polynomial at the point x, which is in (0, +infty), with compensated method, and performs a running-error bound */ +dd_real AccLagueDerKwErr(double *P, unsigned int n, double x, double alpha, double * runerrbound, unsigned int k) +{ + assert ( 0 < n); + assert (x>0); + assert (alpha>-1.0); + double b1=0,b2=0; + double err_temp, errb1=0, errb2=0; + dd_real res,temp1,temp2,temp3,temp4; + dd_real A1,A2; + dd_real s0,s1,s2; + int i; + double j; + int C=1; + for(i=k;i>0;i--) + { + C=-C; + } + double abst=0,absb1=0; + int na,nb,ne; + na=3; + nb=2; + ne=6; + double errz,errz1,errz2, errztemp, err_P; + errz1=0; + errz2=0; + errztemp=0; + + for(i=n-k; i>=0; i--) + { + j=1.0*i; +//-------------recurrence coefficients-----------------------// + s0=two_sum(2*j+k+1,alpha); + s1=add_dd_d(s0,-x); + A1=div_dd_d(s1,j+1); + + s2=two_sum(j+k+1,alpha); + A2=div_dd_d(s2,-j-2); +//--------------iteration-----------------------------------// + temp1=two_prod(A1.H,b1); + temp2=two_prod(A2.H,b2); + temp3=two_sum(P[i+k],temp1.H); + temp4=two_sum(temp2.H,temp3.H); +//--------------the compensated part------------------------// + err_P=A1.L*b1+A2.L*b2+temp1.L+temp2.L+temp3.L+temp4.L; + err_temp=A1.H*errb1+A2.H*errb2+err_P; +//--------------the runninge error bound-------------------// + abst=fabs(err_temp); + errz=errz1*fabs(A1.H)+errz2*fabs(A2.H)+(ne+1)*fabs(err_P); + + errz2=errztemp+(nb+2)*absb1; + errz1=errz+(na+3)*abst; + + b2=b1; + b1=temp4.H; + + errb2=errb1; + errb1=err_temp; + + errztemp=errz; + absb1=abst; + } + res=quick_two_sum(C*b1,C*errb1); + *(runerrbound)=(errz1-(2+na)*abst)*unit; + + return res; +} + + + + + diff --git a/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/legendre_series.c b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/legendre_series.c new file mode 100644 index 000000000..b62033786 --- /dev/null +++ b/src/modules/Polynomial/src/assets/OrthoPoly_C_v1.0/src/legendre_series.c @@ -0,0 +1,882 @@ +/****************************************************************************** +% Set of subroutines and functions to evaluate series of LEGENDRE polynomials at the point x, which is in [-1, 1]. +% It allows to evaluate the series and derivatives of it at any point using standard double precision with and without +% error bounds to provide information of the quality of the evaluation. It also allows ACCURATE evaluations using +% a new compensated algorithm. +% +% Licensing: +% +% This code is distributed under the GNU General Public License 3 (GPLv3). +% +% Modified: +% +% 5 November 2016 +% +% Authors: +% +% Roberto Barrio, Peibing Du, Hao Jiang and Sergio Serrano +% +% Algorithm: +% BCS-algorithm with running error bound +% References: +% R. Barrio, J.M. Pe~na, +% Numerical evaluation of the pth derivative of Jacobi series, +% Applied Numerical Mathmetics 43 335-357, (2002). +% +% H. Jiang, R. Barrio, H. Li, X. Liao, L. Cheng, F. Su, +% Accurate evaluation of a polynomial in Chebyshev form +% Applied Mathematics and Computation 217 (23), 9702-9716, (2011). +%*****************************************************************************/ + +#include +#include +#include +#include + +#include "inline.h" +#include "legendre_series.h" + +/* LegenVal evaluates a series of legendre polynomial at the point x, which is in [-1, 1].*/ +double LegenVal(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double t, b1 = 0, b2 = 0; + int j; + double i; + + for (j = n; j >= 1; j--) + { + i = 1.0 * j; + t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + P[j]; + b2 = b1; + b1 = t; + } + return x * b1 - b2 / 2 + P[0]; +} + +/*CompLegenVal evaluates a series of legendre polynomial at the point x, which is in [-1, 1], with compensated method.*/ +double CompLegenVal(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, s, t, errb1 = 0, errb2 = 0, res; + dd_real A, C, temp1, temp2, temp3, temp4, temp5; + int j; + double i; + + for (j = n; j >= 1; j--) + { + i = 1.0 * j; + A = div_d_d(2 * i + 1, i + 1); + C = div_d_d(i + 1, i + 2); + temp1 = two_prod(A.H, x); + temp2 = two_prod(temp1.H, b1); + s = temp1.L * b1 + temp2.L; + + temp3 = two_prod(C.H, b2); + + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[j]); + + t = A.L * x * b1 - C.L * b2; + + b2 = b1; + b1 = temp5.H; + //--------------the compensated part---------------// + err_temp = temp1.H * errb1 - C.H * errb2 + (s - temp3.L + temp4.L + temp5.L + t); + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(x, b1); + s = -b2 / 2; + temp2 = two_sum(temp1.H, s); + temp3 = two_sum(temp2.H, P[0]); + //--------------the compensated part---------------// + err_temp = x * errb1 - errb2 / 2 + (temp1.L + temp2.L + temp3.L); + res = temp3.H + err_temp; + + return res; +} + +/*AccLegenVal evaluates a series of legendre polynomial at the point x, which is in [-1, 1], with compensated method.*/ +dd_real AccLegenVal(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, s, t, errb1 = 0, errb2 = 0; + dd_real res, A, C, temp1, temp2, temp3, temp4, temp5; + int j; + double i; + + for (j = n; j >= 1; j--) + { + i = 1.0 * j; + A = div_d_d(2 * i + 1, i + 1); + C = div_d_d(i + 1, i + 2); + temp1 = two_prod(A.H, x); + temp2 = two_prod(temp1.H, b1); + s = temp1.L * b1 + temp2.L; + + temp3 = two_prod(C.H, b2); + + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[j]); + + t = A.L * x * b1 - C.L * b2; + + b2 = b1; + b1 = temp5.H; + //--------------the compensated part---------------// + err_temp = temp1.H * errb1 - C.H * errb2 + (s - temp3.L + temp4.L + temp5.L + t); + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(x, b1); + s = -b2 / 2; + temp2 = two_sum(temp1.H, s); + temp3 = two_sum(temp2.H, P[0]); + //--------------the compensated part---------------// + err_temp = x * errb1 - errb2 / 2 + (temp1.L + temp2.L + temp3.L); + res = quick_two_sum(temp3.H, err_temp); + + return res; +} + +/*LegenDer evaluates the first derivative of a series of legendre polynomial at the point x, which is in [-1, 1]. */ +double LegenDer(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double t, b1 = 0, b2 = 0; + int j; + double i; + + for (j = n - 1; j >= 0; j--) + { + i = 1.0 * j; + t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + P[j + 1]; + b2 = b1; + b1 = t; + } + return b1; +} + +/*CompLegenDer evaluates the first derivative of a series of legendre polynomial at the point x, which is in [-1, 1], with compensated method.*/ +double CompLegenDer(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, s, t, errb1 = 0, errb2 = 0, res; + dd_real A1, A2, temp1, temp2, temp3, temp4, temp5; + int j; + double i; + + for (j = n - 1; j >= 0; j--) + { + i = 1.0 * j; + A1 = div_d_d(2 * i + 3, i + 1); + A2 = div_d_d(i + 3, i + 2); + temp1 = two_prod(A1.H, x); + temp2 = two_prod(temp1.H, b1); + s = temp1.L * b1 + temp2.L; + + temp3 = two_prod(A2.H, b2); + + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[j + 1]); + + t = A1.L * x * b1 - A2.L * b2; + + b2 = b1; + b1 = temp5.H; + //--------------the compensated part---------------// + err_temp = A1.H * x * errb1 - A2.H * errb2 + (s - temp3.L + temp4.L + temp5.L + t); + errb2 = errb1; + errb1 = err_temp; + } + res = b1 + errb1; + return res; +} + +/*AccLegenDer evaluates the first derivative of a series of legendre polynomial at the point x, which is in [-1, 1], with compensated method.*/ +dd_real AccLegenDer(double *P, unsigned int n, double x) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, s, t, errb1 = 0, errb2 = 0; + dd_real res, A1, A2, temp1, temp2, temp3, temp4, temp5; + int j; + double i; + + for (j = n - 1; j >= 0; j--) + { + i = 1.0 * j; + A1 = div_d_d(2 * i + 3, i + 1); + A2 = div_d_d(i + 3, i + 2); + temp1 = two_prod(A1.H, x); + temp2 = two_prod(temp1.H, b1); + s = temp1.L * b1 + temp2.L; + + temp3 = two_prod(A2.H, b2); + + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[j + 1]); + + t = A1.L * x * b1 - A2.L * b2; + + b2 = b1; + b1 = temp5.H; + //--------------the compensated part---------------// + err_temp = A1.H * x * errb1 - A2.H * errb2 + (s - temp3.L + temp4.L + temp5.L + t); + errb2 = errb1; + errb1 = err_temp; + } + res = quick_two_sum(b1, errb1); + return res; +} + +/*LegenDerK evaluates the k-th derivative of a series of legendre polynomial at the point x, which is in [-1, 1]. */ +double LegenDerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double s = 1.0, t, b1 = 0, b2 = 0; + int j; + double i; + + for (j = 2 * k - 1; j > 0; j = j - 2) + { + s = j * s; + } + double A1, A2; + + for (j = n - k; j >= 0; j--) + { + i = 1.0 * j; + A1 = (2 * i + 2 * k + 1) / (i + 1) * x; + A2 = -(i + 2 * k + 1) / (i + 2); + t = A1 * b1 + A2 * b2 + P[j + k]; + + b2 = b1; + b1 = t; + } + return s * b1; +} + +/*CompLegenDerK evaluates the k-th derivative of a series of legendre polynomial at the point x, which is in [-1, 1], with compensated method.*/ +double CompLegenDerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double s = 1.0, t, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0, res; + dd_real A1, A2, temp1, temp2, temp3, temp4, temp5; + int i; + + for (i = 2 * k - 1; i > 0; i = i - 2) + { + s = i * s; + } + + for (i = n - k; i >= 0; i--) + { + A1 = div_d_d(2 * i + 2 * k + 1, i + 1); + A2 = div_d_d(i + 2 * k + 1, i + 2); + temp1 = two_prod(A1.H, x); + temp2 = two_prod(temp1.H, b1); + temp2.L = temp1.L * b1 + temp2.L; + + temp3 = two_prod(A2.H, b2); + + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[i + k]); + + t = A1.L * x * b1 - A2.L * b2; + + b2 = b1; + b1 = temp5.H; + //--------------the compensated part---------------// + err_temp = temp1.H * errb1 - A2.H * errb2 + (temp2.L - temp3.L + temp4.L + temp5.L + t); + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(s, b1); + temp1.L = s * errb1 + temp1.L; + res = temp1.H + temp1.L; + + return res; +} + +/*AccLegenDerK evaluates the k-th derivative of a series of legendre polynomial at the point x, which is in [-1, 1], with compensated method.*/ +dd_real AccLegenDerK(double *P, unsigned int n, double x, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double s = 1.0, t, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, A1, A2, temp1, temp2, temp3, temp4, temp5; + int i; + + for (i = 2 * k - 1; i > 0; i = i - 2) + { + s = i * s; + } + + for (i = n - k; i >= 0; i--) + { + A1 = div_d_d(2 * i + 2 * k + 1, i + 1); + A2 = div_d_d(i + 2 * k + 1, i + 2); + temp1 = two_prod(A1.H, x); + temp2 = two_prod(temp1.H, b1); + temp2.L = temp1.L * b1 + temp2.L; + + temp3 = two_prod(A2.H, b2); + + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[i + k]); + + t = A1.L * x * b1 - A2.L * b2; + + b2 = b1; + b1 = temp5.H; + //--------------the compensated part---------------// + err_temp = temp1.H * errb1 - A2.H * errb2 + (temp2.L - temp3.L + temp4.L + temp5.L + t); + errb2 = errb1; + errb1 = err_temp; + } + temp1 = two_prod(s, b1); + temp1.L = s * errb1 + temp1.L; + res = quick_two_sum(temp1.H, temp1.L); + + return res; +} + +/*----------------------- LegenValwErr evaluates a series of Legendre polynomial at the point x, which is in [-1, 1], and performs a running-error bound */ +double LegenValwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double t, b1 = 0, b2 = 0; + double abst, absb1 = 0; + int i; + double j; + double A1, A2, absx; + absx = fabs(x); + int na, nb; + na = 2; + nb = 1; + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n; i >= 1; i--) + { + j = 1.0 * i; + A1 = (2 * j + 1) / (j + 1); + A2 = -(j + 1) / (j + 2); + t = A1 * x * b1 + A2 * b2 + P[i]; + abst = fabs(t); + + errz = errz1 * A1 * absx + errz2 * fabs(A2) + fabs(P[i]); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + t = x * b1 - b2 / 2 + P[0]; + abst = fabs(t); + + errz = errz1 * absx + errz2 / 2 + fabs(P[0]); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + *(runerrbound) = (errz1 - (2 + na) * abst) * unit; + + return b1; +} + +/*----------------------- LegenDerwErr evaluates the first derivative of a series of Legendre polynomial at the point x, which is in [-1, 1], and performs a running-error bound */ +double LegenDerwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double t, b1 = 0, b2 = 0; + double A1, A2; + double abst = 0, absb1 = 0; + int i; + double j; + int na, nb, nc; + na = 2; + nb = 1; + nc = 0; + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - 1; i >= 0; i--) + { + j = 1.0 * i; + A1 = (2 * j + 3) / (j + 1) * x; + A2 = -(j + 3) / (j + 2); + t = A1 * b1 + A2 * b2 + P[i + 1]; + + abst = fabs(t); + + errz = errz1 * fabs(A1) + errz2 * fabs(A2) + (nc + 2) * fabs(P[i + 1]); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + *(runerrbound) = (errz1 - (1 + na) * abst) * unit; + + return b1; +} + +/*----------------------- LegenDerKwErr evaluates the k-th derivative of a series of Legendre polynomial at the point x, which is in [-1, 1], and performs a running-error bound */ +double LegenDerKwErr(double *P, unsigned int n, double x, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double s = 1.0, t, b1 = 0, b2 = 0; + int j; + double i; + + for (j = 2 * k - 1; j > 0; j = j - 2) + { + s = j * s; + } + double A1, A2; + double abst = 0, absb1 = 0; + + int na, nb, nc; + na = 2; + nb = 1; + nc = 0; + double errz, errz1, errz2, errztemp; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (j = n - k; j >= 0; j--) + { + i = 1.0 * j; + A1 = (2 * i + 2 * k + 1) / (i + 1) * x; + A2 = -(i + 2 * k + 1) / (i + 2); + t = A1 * b1 + A2 * b2 + P[j + k]; + + abst = fabs(t); + + errz = errz1 * fabs(A1) + errz2 * fabs(A2) + (nc + 2) * fabs(P[j + k]); + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + + b2 = b1; + b1 = t; + + errztemp = errz; + absb1 = abst; + } + *(runerrbound) = (errz1 - (1 + na) * abst) * unit * s; + + return s * b1; +} + +/*CompLegenValwErr evaluates a series of Legendre polynomial at the point x, which is in [-1, 1], with compensated method, together with the running error bound.*/ +double CompLegenValwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double res, err_temp, errb1 = 0, errb2 = 0; + dd_real A1, A2, temp1, temp2, temp3, temp4, temp5; + int i; + double j; + + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 8; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n; i >= 0; i--) + { + j = 1.0 * i; + + A1 = div_d_d(2 * j + 1, j + 1); + + A2 = div_d_d(-j - 1, j + 2); + + temp1 = two_prod(A1.H, x); + temp2 = two_prod(temp1.H, b1); + + temp3 = two_prod(A2.H, b2); + + temp4 = two_sum(temp2.H, temp3.H); + temp5 = two_sum(temp4.H, P[i]); + //--------------the compensated part---------------// + err_P = temp1.L * b1 + temp2.L + temp3.L + temp4.L + temp5.L + A1.L * x * b1 + A2.L * b2; + err_temp = temp1.H * errb1 + A2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(temp1.H) + errz2 * (-A2.H) + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //--------------the next iteration-----------------// + b2 = b1; + b1 = temp5.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + res = b1 + errb1; + *(runerrbound) = ((errz1 - (2 + na) * abst) * unit + fabs(errb1 - (res - b1))) / (1 - unit * 2); + + return res; +} + +/*----------------------- CompLegenDerwErr evaluates the first derivative of a series of Legendre polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +double CompLegenDerwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double res, err_temp, errb1 = 0, errb2 = 0; + dd_real temp1, temp2, temp3, temp4; + dd_real Temp, A1, A2; + int i; + double j; + + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 6; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - 1; i >= 0; i--) + { + j = 1.0 * i; + + Temp = two_prod(2 * j + 3, x); + A1 = div_dd_d(Temp, j + 1); + + A2 = div_d_d(-j - 3, j + 2); + + temp1 = two_prod(A1.H, b1); + temp2 = two_prod(A2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + 1]); + //--------------the compensated part---------------// + err_P = A1.L * b1 + A2.L * b2 + temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = A1.H * errb1 + A2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(A1.H) + errz2 * fabs(A2.H) + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //------------- the next step---------------------// + b2 = b1; + b1 = temp4.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + res = b1 + errb1; + *(runerrbound) = ((errz1 - (1 + na) * abst) * unit + fabs(errb1 - (res - b1))) / (1 - unit * 2); + + return res; +} + +/*----------------------- CompLegenDerKwErr evaluates the k-th derivative of a series of Legendre polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +double CompLegenDerKwErr(double *P, unsigned int n, double x, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + + double s = 1.0, t, b1 = 0, b2 = 0; + double res, err_temp, errb1 = 0, errb2 = 0; + dd_real A1, A2, temp1, temp2, temp3, temp4, temp5; + int i; + + for (i = 2 * k - 1; i > 0; i = i - 2) + { + s = i * s; + } + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 6; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + A1 = div_d_d(2 * i + 2 * k + 1, i + 1); + A2 = div_d_d(i + 2 * k + 1, i + 2); + + temp1 = two_prod(A1.H, x); + temp2 = two_prod(temp1.H, b1); + temp2.L = temp1.L * b1 + temp2.L; + + temp3 = two_prod(A2.H, b2); + + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[i + k]); + + t = A1.L * x * b1 - A2.L * b2; + //--------------the compensated part---------------// + err_P = temp2.L - temp3.L + temp4.L + temp5.L + t; + err_temp = temp1.H * errb1 - A2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(temp1.H) + errz2 * A2.H + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //------------- the next step---------------------// + b2 = b1; + b1 = temp5.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + temp1 = two_prod(s, b1); + temp1.L = s * errb1 + temp1.L; + + res = temp1.H + temp1.L; + *(runerrbound) = ((errz1 - (2 + na) * abst) * unit * s + fabs(temp1.L - (res - temp1.H))) / (1 - unit * 3); + + return res; +} + +/*----------------------- AccLegenValwErr evaluates a series of Legendre polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +dd_real AccLegenValwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real A1, A2, res, temp1, temp2, temp3, temp4, temp5; + int i; + double j; + + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 8; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n; i >= 0; i--) + { + j = 1.0 * i; + + A1 = div_d_d(2 * j + 1, j + 1); + A2 = div_d_d(-j - 1, j + 2); + + temp1 = two_prod(A1.H, x); + temp2 = two_prod(temp1.H, b1); + + temp3 = two_prod(A2.H, b2); + + temp4 = two_sum(temp2.H, temp3.H); + temp5 = two_sum(temp4.H, P[i]); + //--------------the compensated part---------------// + err_P = temp1.L * b1 + temp2.L + temp3.L + temp4.L + temp5.L + A1.L * x * b1 + A2.L * b2; + err_temp = temp1.H * errb1 + A2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(temp1.H) + errz2 * (-A2.H) + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //--------------the next iteration-----------------// + b2 = b1; + b1 = temp5.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + res = quick_two_sum(b1, errb1); + *(runerrbound) = (errz1 - (2 + na) * abst) * unit; + + return res; +} + +/*----------------------- AccLegenDerwErr evaluates the first derivative of a series of Legendre polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +dd_real AccLegenDerwErr(double *P, unsigned int n, double x, double *runerrbound) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + double b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, temp1, temp2, temp3, temp4; + dd_real Temp, A1, A2; + int i; + double j; + + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 6; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - 1; i >= 0; i--) + { + j = 1.0 * i; + + Temp = two_prod(2 * j + 3, x); + A1 = div_dd_d(Temp, j + 1); + A2 = div_d_d(-j - 3, j + 2); + + temp1 = two_prod(A1.H, b1); + temp2 = two_prod(A2.H, b2); + temp3 = two_sum(temp1.H, temp2.H); + temp4 = two_sum(temp3.H, P[i + 1]); + //--------------the compensated part---------------// + err_P = A1.L * b1 + A2.L * b2 + temp1.L + temp2.L + temp3.L + temp4.L; + err_temp = A1.H * errb1 + A2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(A1.H) + errz2 * fabs(A2.H) + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //------------- the next step---------------------// + b2 = b1; + b1 = temp4.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + res = quick_two_sum(b1, errb1); + *(runerrbound) = (errz1 - (1 + na) * abst) * unit; + + return res; +} + +/*----------------------- AccLegenDerKwErr evaluates the k-th derivative of a series of Legendre polynomial at the point x, which is in [-1, 1], with compensated method, and performs a running-error bound */ +dd_real AccLegenDerKwErr(double *P, unsigned int n, double x, double *runerrbound, unsigned int k) +{ + assert(0 < n); + assert(fabs(x) <= 1.0); + + double s = 1.0, t, b1 = 0, b2 = 0; + double err_temp, errb1 = 0, errb2 = 0; + dd_real res, A1, A2, temp1, temp2, temp3, temp4, temp5; + int i; + + for (i = 2 * k - 1; i > 0; i = i - 2) + { + s = i * s; + } + double abst = 0, absb1 = 0; + int na, nb, ne; + na = 2; + nb = 1; + ne = 6; + + double errz, errz1, errz2, errztemp, err_P; + errz1 = 0; + errz2 = 0; + errztemp = 0; + + for (i = n - k; i >= 0; i--) + { + A1 = div_d_d(2 * i + 2 * k + 1, i + 1); + A2 = div_d_d(i + 2 * k + 1, i + 2); + + temp1 = two_prod(A1.H, x); + temp2 = two_prod(temp1.H, b1); + temp2.L = temp1.L * b1 + temp2.L; + + temp3 = two_prod(A2.H, b2); + + temp4 = two_sum(temp2.H, -temp3.H); + temp5 = two_sum(temp4.H, P[i + k]); + + t = A1.L * x * b1 - A2.L * b2; + //--------------the compensated part---------------// + err_P = temp2.L - temp3.L + temp4.L + temp5.L + t; + err_temp = temp1.H * errb1 - A2.H * errb2 + err_P; + //--------------the running error bound------------// + abst = fabs(err_temp); + errz = errz1 * fabs(temp1.H) + errz2 * A2.H + (ne + 1) * fabs(err_P); + + errz2 = errztemp + (nb + 2) * absb1; + errz1 = errz + (na + 3) * abst; + //------------- the next step---------------------// + b2 = b1; + b1 = temp5.H; + + errb2 = errb1; + errb1 = err_temp; + + errztemp = errz; + absb1 = abst; + } + temp1 = two_prod(s, b1); + temp1.L = s * errb1 + temp1.L; + res = quick_two_sum(temp1.H, temp1.L); + *(runerrbound) = (errz1 - (2 + na) * abst) * unit * s; + + return res; +} diff --git a/src/modules/Polynomial/src/assets/chebyshev_polynomial.f90 b/src/modules/Polynomial/src/assets/chebyshev_polynomial.f90 new file mode 100644 index 000000000..33cbf1389 --- /dev/null +++ b/src/modules/Polynomial/src/assets/chebyshev_polynomial.f90 @@ -0,0 +1,4320 @@ +subroutine t_mass_matrix ( n, a ) + +!*****************************************************************************80 +! +!! T_MASS_MATRIX computes the mass matrix for the Chebyshev T polynomial. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 July 2015 +! +! Author: +! +! John Burkardt +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) a(0:n,0:n) + integer i + real ( kind = rk ), allocatable :: phi(:,:) + real ( kind = rk ), allocatable :: phiw(:,:) + real ( kind = rk ), allocatable :: w(:) + real ( kind = rk ), allocatable :: x(:) + + allocate ( x(0:n) ) + allocate ( w(0:n) ) + + call t_quadrature_rule ( n + 1, x, w ) + + allocate ( phi(0:n,0:n) ) + + call t_polynomial ( n + 1, n, x, phi ) + + allocate ( phiw(0:n,0:n) ) + + do i = 0, n + phiw(0:n,i) = w(i) * phi(i,0:n) + end do + + a(0:n,0:n) = matmul ( phiw(0:n,0:n), phi(0:n,0:n) ) + + deallocate ( phi ) + deallocate ( phiw ) + deallocate ( w ) + deallocate ( x ) + + return +end +function t_moment ( e ) + +!*****************************************************************************80 +! +!! T_MOMENT: integral ( -1 <= x <= +1 ) x^e / sqrt ( 1 - x^2 ) dx. +! +! Discussion: +! +! Set +! x = cos ( theta ), +! dx = - sin ( theta ) d theta = - sqrt ( 1 - x^2 ) d theta +! to transform the integral to +! integral ( 0 <= theta <= pi ) - ( cos ( theta ) )^e d theta +! which becomes +! 0 if E is odd, +! (1/2^e) * choose ( e, e/2 ) * pi if E is even. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer E, the exponent of X. +! 0 <= E. +! +! Output, real ( kind = rk ) T_MOMENT, the value of the integral. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer e + real ( kind = rk ) r8_choose + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) t_moment + real ( kind = rk ) value + + if ( mod ( e, 2 ) == 1 ) then + + value = 0.0D+00 + + else + + value = r8_choose ( e, e / 2 ) * r8_pi / 2.0D+00 ** e + + end if + + t_moment = value + + return +end +subroutine t_polynomial ( m, n, x, v ) + +!*****************************************************************************80 +! +!! T_POLYNOMIAL evaluates Chebyshev polynomials T(n,x). +! +! Discussion: +! +! Chebyshev polynomials are useful as a basis for representing the +! approximation of functions since they are well conditioned, in the sense +! that in the interval [-1,1] they each have maximum absolute value 1. +! Hence an error in the value of a coefficient of the approximation, of +! size epsilon, is exactly reflected in an error of size epsilon between +! the computed approximation and the theoretical approximation. +! +! Typical usage is as follows, where we assume for the moment +! that the interval of approximation is [-1,1]. The value +! of N is chosen, the highest polynomial to be used in the +! approximation. Then the function to be approximated is +! evaluated at the N+1 points XJ which are the zeroes of the N+1-th +! Chebyshev polynomial. Let these values be denoted by F(XJ). +! +! The coefficients of the approximation are now defined by +! +! C(I) = 2/(N+1) * sum ( 1 <= J <= N+1 ) F(XJ) T(I,XJ) +! +! except that C(0) is given a value which is half that assigned +! to it by the above formula, +! +! and the representation is +! +! F(X) approximated by sum ( 0 <= J <= N ) C(J) T(J,X) +! +! Now note that, again because of the fact that the Chebyshev polynomials +! have maximum absolute value 1, if the higher order terms of the +! coefficients C are small, then we have the option of truncating +! the approximation by dropping these terms, and we will have an +! exact value for maximum perturbation to the approximation that +! this will cause. +! +! It should be noted that typically the error in approximation +! is dominated by the first neglected basis function (some multiple of +! T(N+1,X) in the example above). If this term were the exact error, +! then we would have found the minimax polynomial, the approximating +! polynomial of smallest maximum deviation from the original function. +! The minimax polynomial is hard to compute, and another important +! feature of the Chebyshev approximation is that it tends to behave +! like the minimax polynomial while being easy to compute. +! +! To evaluate a sum like +! +! sum ( 0 <= J <= N ) C(J) T(J,X), +! +! Clenshaw's recurrence formula is recommended instead of computing the +! polynomial values, forming the products and summing. +! +! Assuming that the coefficients C(J) have been computed +! for J = 0 to N, then the coefficients of the representation of the +! indefinite integral of the function may be computed by +! +! B(I) = ( C(I-1) - C(I+1))/2*(I-1) for I=1 to N+1, +! +! with +! +! C(N+1)=0 +! B(0) arbitrary. +! +! Also, the coefficients of the representation of the derivative of the +! function may be computed by: +! +! D(I) = D(I+2)+2*I*C(I) for I=N-1, N-2, ..., 0, +! +! with +! +! D(N+1) = D(N)=0. +! +! Some of the above may have to adjusted because of the irregularity of C(0). +! +! The formula is: +! +! T(N,X) = COS(N*ARCCOS(X)) +! +! Differential equation: +! +! (1-X*X) Y'' - X Y' + N N Y = 0 +! +! First terms: +! +! T(0,X) = 1 +! T(1,X) = 1 X +! T(2,X) = 2 X^2 - 1 +! T(3,X) = 4 X^3 - 3 X +! T(4,X) = 8 X^4 - 8 X^2 + 1 +! T(5,X) = 16 X^5 - 20 X^3 + 5 X +! T(6,X) = 32 X^6 - 48 X^4 + 18 X^2 - 1 +! T(7,X) = 64 X^7 - 112 X^5 + 56 X^3 - 7 X +! +! Inequality: +! +! abs ( T(N,X) ) <= 1 for -1 <= X <= 1 +! +! Orthogonality: +! +! For integration over [-1,1] with weight +! +! W(X) = 1 / sqrt(1-X*X), +! +! if we write the inner product of T(I,X) and T(J,X) as +! +! < T(I,X), T(J,X) > = integral ( -1 <= X <= 1 ) W(X) T(I,X) T(J,X) dX +! +! then the result is: +! +! < T(I,X), T(J,X) > = 0 if I /= J +! < T(I,X), T(J,X) > = PI/2 if I == J /= 0 +! < T(I,X), T(J,X) > = PI if I == J == 0 +! +! A discrete orthogonality relation is also satisfied at each of +! the N zeroes of T(N,X): sum ( 1 <= K <= N ) T(I,X) * T(J,X) +! = 0 if I /= J +! = N/2 if I == J /= 0 +! = N if I == J == 0 +! +! Recursion: +! +! T(0,X) = 1, +! T(1,X) = X, +! T(N,X) = 2 * X * T(N-1,X) - T(N-2,X) +! +! T'(N,X) = N * ( -X * T(N,X) + T(N-1,X) ) / ( 1 - X^2 ) +! +! Special values: +! +! T(N,1) = 1 +! T(N,-1) = (-1)^N +! T(2N,0) = (-1)^N +! T(2N+1,0) = 0 +! T(N,X) = (-1)^N * T(N,-X) +! +! Zeroes: +! +! M-th zero of T(N,X) is X = cos((2*M-1)*PI/(2*N)), M = 1 to N. +! +! Extrema: +! +! M-th extremum of T(N,X) is X = cos(PI*M/N), M = 0 to N. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 March 2001 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Parameters: +! +! Input, integer M, the number of evaluation points. +! +! Input, integer N, the highest polynomial to compute. +! +! Input, real ( kind = rk ) X(1:M), the evaluation points. +! +! Output, real ( kind = rk ) V(1:M,0:N), the values of the polynomials. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + + integer j + real ( kind = rk ) v(1:m,0:n) + real ( kind = rk ) x(1:m) + + if ( n < 0 ) then + return + end if + + v(1:m,0) = 1.0D+00 + + if ( n < 1 ) then + return + end if + + v(1:m,1) = x(1:m) + + do j = 2, n + v(1:m,j) = 2.0D+00 * x(1:m) * v(1:m,j-1) - v(1:m,j-2) + end do + + return +end +subroutine t_polynomial_ab ( a, b, m, n, xab, v ) + +!*****************************************************************************80 +! +!! T_POLYNOMIAL_AB: evaluates Chebyshev polynomials TAB(n,x) in [A,B]. +! +! Discussion: +! +! TAB(n,x) = T(n,(2*x-a-b)/(b-a)) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = rk ) A, B, the domain of definition. +! +! Input, integer M, the number of evaluation points. +! +! Input, integer N, the highest polynomial to compute. +! +! Input, real ( kind = rk ) XAB(M), the evaluation points. +! It must be the case that A <= XAB(*) <= B. +! +! Output, real ( kind = rk ) V(M,N+1), the values. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + + real ( kind = rk ) a + real ( kind = rk ) b + real ( kind = rk ) v(1:m,0:n) + real ( kind = rk ) x(1:m) + real ( kind = rk ) xab(1:m) + + x(1:m) = ( 2.0D+00 * xab(1:m) - a - b ) / ( b - a ) + + call t_polynomial ( m, n, x, v ) + + return +end +subroutine t_polynomial_coefficients ( n, c ) + +!*****************************************************************************80 +! +!! T_POLYNOMIAL_COEFFICIENTS: coefficients of the Chebyshev polynomial T(n,x). +! +! First terms: +! +! N/K 0 1 2 3 4 5 6 7 8 9 10 +! +! 0 1 +! 1 0 1 +! 2 -1 0 2 +! 3 0 -3 0 4 +! 4 1 0 -8 0 8 +! 5 0 5 0 -20 0 16 +! 6 -1 0 18 0 -48 0 32 +! 7 0 -7 0 56 0 -112 0 64 +! +! Recursion: +! +! T(0,X) = 1, +! T(1,X) = X, +! T(N,X) = 2 * X * T(N-1,X) - T(N-2,X) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 May 2003 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Parameters: +! +! Input, integer N, the highest order polynomial to compute. +! Note that polynomials 0 through N will be computed. +! +! Output, real ( kind = rk ) C(0:N,0:N), the coefficients of the Chebyshev T +! polynomials. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) c(0:n,0:n) + integer i + + if ( n < 0 ) then + return + end if + + c(0:n,0:n) = 0.0D+00 + + c(0,0) = 1.0D+00 + + if ( n == 0 ) then + return + end if + + c(1,1) = 1.0D+00 + + do i = 2, n + c(i,0) = - c(i-2,0) + c(i,1:i-2) = 2.0D+00 * c(i-1,0:i-3) - c(i-2,1:i-2) + c(i, i-1) = 2.0D+00 * c(i-1, i-2) + c(i, i ) = 2.0D+00 * c(i-1, i-1) + end do + + return +end +function t_polynomial_value ( n, x ) + +!*****************************************************************************80 +! +!! T_POLYNOMIAL_VALUE: returns the single value T(n,x). +! +! Discussion: +! +! In cases where calling T_POLYNOMIAL is inconvenient, because it returns +! a vector of values for multiple arguments X, this simpler interface +! may be appropriate. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the polynomial. +! +! Input, real ( kind = rk ) X, the argument of the polynomial. +! +! Output, real ( kind = rk ) T_POLYNOMIAL_VALUE, the value of T(n,x). +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + real ( kind = rk ) t_polynomial_value + real ( kind = rk ) value + real ( kind = rk ), allocatable :: vec(:) + real ( kind = rk ) x + real ( kind = rk ) x_vec(1) + + if ( n < 0 ) then + + value = 0.0D+00 + + else + + m = 1 + allocate ( vec(0:n) ) + + x_vec(1) = x + call t_polynomial ( m, n, x_vec, vec ) + + value = vec(n) + deallocate ( vec ) + + end if + + t_polynomial_value = value + + return +end +subroutine t_polynomial_zeros ( n, z ) + +!*****************************************************************************80 +! +!! T_POLYNOMIAL_ZEROS returns zeroes of the Chebyshev polynomial T(n,x). +! +! Discussion: +! +! The I-th zero of T(N,X) is cos((2*I-1)*PI/(2*N)), I = 1 to N +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 March 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the polynomial. +! +! Output, real ( kind = rk ) Z(N), the zeroes of T(N,X). +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) angle + integer i + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) z(n) + + do i = 1, n + angle = real ( 2 * i - 1, kind = rk ) * r8_pi / real ( 2 * n, kind = rk ); + z(i) = cos ( angle ); + end do + + return +end +subroutine t_project_coefficients ( n, f, c ) + +!*****************************************************************************80 +! +!! T_PROJECT_COEFFICIENTS: function projected onto Chebyshev polynomials T(n,x). +! +! Discussion: +! +! It is assumed that the interval of definition is -1 <= x <= +1. +! +! Over this interval, f(x) will be well approximated by +! +! f(x) approx sum ( 0 <= i <= n ) c(i) * T(i,x) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the highest order polynomial to compute. +! +! Input, external real ( kind = rk ) function F ( X ), evaluates the function. +! +! Output, real ( kind = rk ) C(0:N), the projection coefficients of f(x) onto +! T(0,x) through T(n,x). +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) c(0:n) + real ( kind = rk ) d(0:n) + real ( kind = rk ), external :: f + real ( kind = rk ) fac + integer j + integer k + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) total + real ( kind = rk ) y + + do k = 0, n + y = cos ( r8_pi * ( real ( k, kind = rk ) + 0.5D+00 ) & + / real ( n + 1, kind = rk ) ) + d(k) = f ( y ) + end do + + fac = 2.0D+00 / real ( n + 1, kind = rk ) + + do j = 0, n + total = 0.0D+00 + do k = 0, n + total = total + d(k) * cos ( ( r8_pi * real ( j, kind = rk ) ) & + * ( ( real ( k, kind = rk ) + 0.5D+00 ) / real ( n + 1, kind = rk ) ) ) + end do + c(j) = fac * total + end do + + c(0) = c(0) / 2.0D+00 + + return +end +subroutine t_project_coefficients_ab ( n, f, a, b, c ) + +!*****************************************************************************80 +! +!! T_PROJECT_COEFFICIENTS_AB: function projected onto TAB(n,x) over [a,b]. +! +! Discussion: +! +! TAB(n,x) = T(n,(2*x-a-b)/(b-a)) +! +! It is assumed that the interval of definition is a <= x <= b. +! +! Over this interval, f(x) will be well approximated by +! +! f(x) approx sum ( 0 <= i <= n ) c(i) * T(i,(2x-a-b)/(b-a)) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the highest order polynomial to compute. +! +! Input, external real ( kind = rk ) function F ( X ), evaluates the function. +! +! Input, real ( kind = rk ) A, B, the interval of definition. +! +! Output, real ( kind = rk ) C(0:N), the projection coefficients of f(x) onto +! T(0,x) through T(n,x). +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) a + real ( kind = rk ) b + real ( kind = rk ) c(0:n) + real ( kind = rk ) d(0:n) + real ( kind = rk ), external :: f + real ( kind = rk ) fac + integer j + integer k + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) t + real ( kind = rk ) total + real ( kind = rk ) y + + do k = 0, n + + t = cos ( r8_pi * ( real ( k, kind = rk ) - 0.5D+00 ) & + / real ( n + 1, kind = rk ) ) + + y = ( ( 1.0D+00 + t ) * b & + + ( 1.0D+00 - t ) * a ) & + / 2.0D+00 + + d(k) = f ( y ) + + end do + + fac = 2.0D+00 / real ( n + 1, kind = rk ) + + do j = 0, n + total = 0.0D+00 + do k = 0, n + total = total + d(k) * cos ( ( r8_pi * real ( j, kind = rk ) ) & + * ( ( real ( k, kind = rk ) + 0.5D+00 ) / real ( n + 1, kind = rk ) ) ) + end do + c(j) = fac * total + end do + + c(0) = c(0) / 2.0D+00 + + return +end +subroutine t_project_coefficients_data ( a, b, m, n, x, d, c ) + +!*****************************************************************************80 +! +!! T_PROJECT_COEFFICIENTS_DATA: project data onto Chebyshev polynomials T(n,x). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = rk ) A, B, the domain of definition. +! +! Input, integer M, the number of data values. +! +! Input, integer N, the desired order of the Chebyshev +! expansion. +! +! Input, real ( kind = rk ) X(M), the data abscissas. These need not +! be sorted. It must be the case that A <= X() <= B. +! +! Input, real ( kind = rk ) D(M), the data values. +! +! Output, real ( kind = rk ) C(0:N), the approximate Chebshev coefficients. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + + real ( kind = rk ) a + real ( kind = rk ) b + real ( kind = rk ) c(0:n) + real ( kind = rk ) d(m) + logical r8vec_in_ab + real ( kind = rk ) v(m,0:n) + real ( kind = rk ) x(m) + + if ( .not. r8vec_in_ab ( m, x, a, b ) ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) ' T_PROJECT_COEFFICIENTS_DATA- Fatal error!' + write ( *, '(a)' ) ' Some X not in [A,B].' + stop 1 + end if +! +! Compute the M by N+1 Chebyshev Vandermonde matrix V. +! + call t_polynomial_ab ( a, b, m, n, x, v ) +! +! Compute the least-squares solution C. +! + call svd_solve ( m, n + 1, v, d, c ) + + return +end +subroutine t_project_value ( m, n, x, c, v ) + +!*****************************************************************************80 +! +!! T_PROJECT_VALUE evaluates an expansion in Chebyshev polynomials T(n,x). +! +! Discussion: +! +! The projection is assumed to be based on the interval [-1,+1]. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer M, the number of evaluation points. +! +! Input, integer N, the highest order polynomial to compute. +! +! Input, real ( kind = rk ) X(M), the evaluation points. +! +! Input, real ( kind = rk ) C(0:N), the expansion coefficients. +! +! Output, real ( kind = rk ) V(M), the value of the Chebyshev function. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + + real ( kind = rk ) b0(m) + real ( kind = rk ) b1(m) + real ( kind = rk ) b2(m) + real ( kind = rk ) c(0:n) + integer j + real ( kind = rk ) v(m) + real ( kind = rk ) x(m) + + b1(1:m) = 0.0D+00 + b0(1:m) = 0.0D+00 + + do j = n, 0, -1 + b2(1:m) = b1(1:m) + b1(1:m) = b0(1:m) + b0(1:m) = c(j) + 2.0D+00 * x(1:m) * b1(1:m) - b2(1:m) + end do + + v(1:m) = 0.5D+00 * ( c(0) + b0(1:m) - b2(1:m) ) + + return +end +subroutine t_project_value_ab ( m, n, x, c, a, b, v ) + +!*****************************************************************************80 +! +!! T_PROJECT_VALUE_AB evaluates an expansion in Chebyshev polynomials TAB(n,x). +! +! Discussion: +! +! TAB(n,x) = T(n,(2*x-a-b)/(b-a)) +! +! The projection is assumed to be based on the interval [A,B]. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer M, the number of evaluation points. +! +! Input, integer N, the highest order polynomial to compute. +! +! Input, real ( kind = rk ) X(M), the evaluation points. +! +! Input, real ( kind = rk ) C(0:N), the expansion coefficients. +! +! Input, real ( kind = rk ) A, B, the interval of definition. +! +! Output, real ( kind = rk ) V(M), the value of the Chebyshev function. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + + real ( kind = rk ) a + real ( kind = rk ) b + real ( kind = rk ) b0(m) + real ( kind = rk ) b1(m) + real ( kind = rk ) b2(m) + real ( kind = rk ) c(0:n) + integer j + real ( kind = rk ) v(m) + real ( kind = rk ) x(m) + + b1(1:m) = 0.0D+00 + b0(1:m) = 0.0D+00 + + do j = n, 0, -1 + b2(1:m) = b1(1:m) + b1(1:m) = b0(1:m) + b0(1:m) = c(j) + 2.0D+00 / ( b - a ) * ( 2.0D+00 * x(1:m) - a - b ) & + * b1(1:m) - b2(1:m) + end do + + v(1:m) = 0.5D+00 * ( c(0) + b0(1:m) - b2(1:m) ) + + return +end +subroutine t_quadrature_rule ( n, t, w ) + +!*****************************************************************************80 +! +!! T_QUADRATURE_RULE: quadrature rule for T(n,x). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the rule. +! +! Output, real ( kind = rk ) T(N), W(N), the points and weights of the rule. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) bj(n) + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) t(n) + real ( kind = rk ) w(n) + + t(1:n) = 0.0D+00 + + bj(1) = sqrt ( 0.5D+00 ) + bj(2:n) = 0.5D+00 + + w(1) = sqrt ( r8_pi ) + w(2:n) = 0.0D+00 + + call imtqlx ( n, t, bj, w ) + + w(1:n) = w(1:n) ** 2 + + return +end +function tt_product ( i, j, x ) + +!*****************************************************************************80 +! +!! TT_PRODUCT: evaluate T(i,x)*T(j,x) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer I, J, the indices. +! +! Input, real ( kind = rk ) X, the argument. +! +! Output, real ( kind = rk ) TT_PRODUCT, the value. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer i + integer imj + integer ipj + integer j + real ( kind = rk ) t_polynomial_value + real ( kind = rk ) timj + real ( kind = rk ) tipj + real ( kind = rk ) tt_product + real ( kind = rk ) value + real ( kind = rk ) x + + if ( i < 0 .or. j < 0 ) then + value = 0.0D+00 + else + ipj = i + j + tipj = t_polynomial_value ( ipj, x ) + imj = abs ( i - j ) + timj = t_polynomial_value ( imj, x ) + value = 0.5D+00 * ( tipj + timj ) + end if + + tt_product = value + + return +end +function tt_product_integral ( i, j ) + +!*****************************************************************************80 +! +!! TT_PRODUCT_INTEGRAL: integral (-1<=x<=1) T(i,x)*T(j,x)/sqrt(1-x^2) dx +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer I, J, the polynomial indices. +! 0 <= I, J. +! +! Output, real ( kind = rk ) TT_PRODUCT_INTEGRAL, the integral. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer i + integer j + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) tt_product_integral + real ( kind = rk ) value + + if ( i < 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'TT_PRODUCT_INTEGRAL - Fatal error!' + write ( *, '(a)' ) ' 0 <= I is required.' + stop 1 + end if + + if ( j < 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'TT_PRODUCT_INTEGRAL - Fatal error!' + write ( *, '(a)' ) ' 0 <= J is required.' + stop 1 + end if + + if ( i /= j ) then + value = 0.0D+00 + elseif ( i == 0 ) then + value = r8_pi + elseif ( 0 < i ) then + value = r8_pi / 2.0D+00 + end if + + tt_product_integral = value + + return +end +function ttt_product_integral ( i, j, k ) + +!*****************************************************************************80 +! +!! TTT_PRODUCT_INTEGRAL: int (-1<=x<=1) T(i,x)*T(j,x)*T(k,x)/sqrt(1-x^2) dx +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 July 2015 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! John Mason, David Handscomb, +! Chebyshev Polynomials, +! CRC Press, 2002, +! ISBN: 0-8493-035509, +! LC: QA404.5.M37. +! +! Parameters: +! +! Input, integer I, J, K, the polynomial indices. +! 0 <= I, J, K. +! +! Output, real ( kind = rk ) TTT_PRODUCT_INTEGRAL, the integral. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer i + integer j + integer k + real ( kind = rk ) tt_product_integral + real ( kind = rk ) ttt_product_integral + real ( kind = rk ) value + + if ( i < 0 ) then + value = 0.0D+00 + else if ( j < 0 ) then + value = 0.0D+00 + else if ( k < 0 ) then + value = 0.0D+00 + else + value = 0.5D+00 * ( & + tt_product_integral ( i + j, k ) & + + tt_product_integral ( abs ( i - j ), k ) ) + end if + + ttt_product_integral = value + + return +end +function tu_product ( i, j, x ) + +!*****************************************************************************80 +! +!! TU_PRODUCT: evaluate T(i,x)*U(j,x) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer I, J, the indices. +! +! Input, real ( kind = rk ) X, the argument. +! +! Output, real ( kind = rk ) TU_PRODUCT, the value. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer i + integer j + real ( kind = rk ) tu_product + real ( kind = rk ) u_polynomial_value + real ( kind = rk ) uu_product + real ( kind = rk ) value + real ( kind = rk ) x + + if ( i < 0 ) then + value = 0.0D+00 + else if ( j < 0 ) then + value = 0.0D+00 + else if ( i == 0 ) then + value = u_polynomial_value ( j, x ) + else + value = 0.5D+00 * ( uu_product ( i, j, x ) - uu_product ( i - 2, j, x ) ) + end if + + tu_product = value + + return +end +subroutine u_mass_matrix ( n, a ) + +!*****************************************************************************80 +! +!! U_MASS_MATRIX computes the mass matrix for the Chebyshev U polynomial. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 July 2015 +! +! Author: +! +! John Burkardt +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) a(0:n,0:n) + integer i + real ( kind = rk ), allocatable :: phi(:,:) + real ( kind = rk ), allocatable :: phiw(:,:) + real ( kind = rk ), allocatable :: w(:) + real ( kind = rk ), allocatable :: x(:) + + allocate ( x(0:n) ) + allocate ( w(0:n) ) + + call u_quadrature_rule ( n + 1, x, w ) + + allocate ( phi(0:n,0:n) ) + + call u_polynomial ( n + 1, n, x, phi ) + + allocate ( phiw(0:n,0:n) ) + + do i = 0, n + phiw(0:n,i) = w(i) * phi(i,0:n) + end do + + a(0:n,0:n) = matmul ( phiw(0:n,0:n), phi(0:n,0:n) ) + + deallocate ( phi ) + deallocate ( phiw ) + deallocate ( w ) + deallocate ( x ) + + return +end +function u_moment ( e ) + +!*****************************************************************************80 +! +!! U_MOMENT: integral ( -1 <= x <= +1 ) x^e sqrt ( 1 - x^2 ) dx. +! +! Discussion: +! +! E U_INTEGRAL +! -- -------------- +! 0 pi / 2 +! 2 pi / 8 +! 4 pi / 16 +! 6 5 * pi / 128 +! 8 7 * pi / 256 +! 10 21 * pi / 1024 +! 12 33 * pi / 2048 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer E, the exponent of X. +! 0 <= E. +! +! Output, real ( kind = rk ) U_MOMENT, the value of the integral. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + real ( kind = rk ) arg1 + real ( kind = rk ) arg2 + integer e + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) u_moment + real ( kind = rk ) value + + if ( mod ( e, 2 ) == 1 ) then + + value = 0.0D+00 + + else + + arg1 = 0.5D+00 * real ( 1 + e, kind = rk ) + arg2 = 2.0D+00 + 0.5D+00 * real ( e, kind = rk ) + value = 0.5D+00 * sqrt ( r8_pi ) * gamma ( arg1 ) / gamma ( arg2 ) + + end if + + u_moment = value + + return +end +subroutine u_polynomial ( m, n, x, v ) + +!*****************************************************************************80 +! +!! U_POLYNOMIAL evaluates Chebyshev polynomials U(n,x). +! +! Discussion: +! +! The formula is: +! +! If |X| <= 1, then +! +! U(N,X) = sin ( (N+1) * arccos(X) ) / sqrt ( 1 - X^2 ) +! = sin ( (N+1) * arccos(X) ) / sin ( arccos(X) ) +! +! else +! +! U(N,X) = sinh ( (N+1) * arccosh(X) ) / sinh ( arccosh(X) ) +! +! Differential equation: +! +! (1-X*X) Y'' - 3 X Y' + N (N+2) Y = 0 +! +! First terms: +! +! U(0,X) = 1 +! U(1,X) = 2 X +! U(2,X) = 4 X^2 - 1 +! U(3,X) = 8 X^3 - 4 X +! U(4,X) = 16 X^4 - 12 X^2 + 1 +! U(5,X) = 32 X^5 - 32 X^3 + 6 X +! U(6,X) = 64 X^6 - 80 X^4 + 24 X^2 - 1 +! U(7,X) = 128 X^7 - 192 X^5 + 80 X^3 - 8X +! +! Orthogonality: +! +! For integration over [-1,1] with weight +! +! W(X) = sqrt(1-X*X), +! +! we have +! +! < U(I,X), U(J,X) > = integral ( -1 <= X <= 1 ) W(X) U(I,X) U(J,X) dX +! +! then the result is: +! +! < U(I,X), U(J,X) > = 0 if I /= J +! < U(I,X), U(J,X) > = PI/2 if I == J +! +! Recursion: +! +! U(0,X) = 1, +! U(1,X) = 2 * X, +! U(N,X) = 2 * X * U(N-1,X) - U(N-2,X) +! +! Special values: +! +! U(N,1) = N + 1 +! U(2N,0) = (-1)^N +! U(2N+1,0) = 0 +! U(N,X) = (-1)^N * U(N,-X) +! +! Zeroes: +! +! M-th zero of U(N,X) is X = cos( M*PI/(N+1)), M = 1 to N +! +! Extrema: +! +! M-th extremum of U(N,X) is X = cos( M*PI/N), M = 0 to N +! +! Norm: +! +! Integral ( -1 <= X <= 1 ) ( 1 - X^2 ) * U(N,X)^2 dX = PI/2 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 April 2012 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Parameters: +! +! Input, integer M, the number of evaluation points. +! +! Input, integer N, the highest polynomial to compute. +! +! Input, real ( kind = rk ) X(M), the evaluation points. +! +! Output, real ( kind = rk ) V(M,0:N), the values of the N+1 Chebyshev +! polynomials. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + + integer i + real ( kind = rk ) v(m,0:n) + real ( kind = rk ) x(m) + + if ( n < 0 ) then + return + end if + + v(1:m,0) = 1.0D+00 + + if ( n < 1 ) then + return + end if + + v(1:m,1) = 2.0D+00 * x(1:m) + + do i = 2, n + v(1:m,i) = 2.0D+00 * x(1:m) * v(1:m,i-1) - v(1:m,i-2) + end do + + return +end +subroutine u_polynomial_01_values ( n_data, n, x, fx ) + +!*****************************************************************************80 +! +!! U_POLYNOMIAL_01_VALUES: values of shifted Chebyshev polynomials U01(n,x). +! +! Discussion: +! +! The shifted Chebyshev polynomial U01(n,x) = U(n,2*x-1). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 July 2015 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, integer N, the order of the function. +! +! Output, real ( kind = rk ) X, the point where the function is evaluated. +! +! Output, real ( kind = rk ) FX, the value of the function. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer, parameter :: n_max = 25 + + real ( kind = rk ) fx + real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & + 0.000000000000000D+00, & + 1.000000000000000D+00, & + 1.400000000000000D+00, & + 0.9600000000000000D+00, & + -0.05600000000000000D+00, & + -1.038400000000000D+00, & + -1.397760000000000D+00, & + -0.9184640000000000D+00, & + 0.1119104000000000D+00, & + 1.075138560000000D+00, & + 1.393283584000000D+00, & + 0.8754584576000000D+00, & + -0.1676417433600000D+00, & + -1.110156898304000D+00, & + -8.000000000000000D+00, & + 1.511014400000000D+00, & + -1.133260800000000D+00, & + -0.1636352000000000D+00, & + 1.019801600000000D+00, & + 0.000000000000000D+00, & + -1.019801600000000D+00, & + 0.1636352000000000D+00, & + 1.133260800000000D+00, & + -1.511014400000000D+00, & + 8.000000000000000D+00 /) + integer n + integer n_data + integer, save, dimension ( n_max ) :: n_vec = (/ & + -1, & + 0, 1, 2, & + 3, 4, 5, & + 6, 7, 8, & + 9, 10, 11, & + 12, 7, 7, & + 7, 7, 7, & + 7, 7, 7, & + 7, 7, 7 /) + real ( kind = rk ) x + real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.00D+00, & + 0.10D+00, & + 0.20D+00, & + 0.30D+00, & + 0.40D+00, & + 0.50D+00, & + 0.60D+00, & + 0.70D+00, & + 0.80D+00, & + 0.90D+00, & + 1.00D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + n = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + n = n_vec(n_data) + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +subroutine u_polynomial_ab ( a, b, m, n, xab, v ) + +!*****************************************************************************80 +! +!! U_POLYNOMIAL_AB: evaluates Chebyshev polynomials UAB(n,x) in [A,B]. +! +! Discussion: +! +! UAB(n,x) = U(n,(2*x-a-b)/(b-a)) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = rk ) A, B, the domain of definition. +! +! Input, integer M, the number of evaluation points. +! +! Input, integer N, the highest polynomial to compute. +! +! Input, real ( kind = rk ) XAB(M), the evaluation points. +! It must be the case that A <= XAB(*) <= B. +! +! Output, real ( kind = rk ) V(M,N+1), the values. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + + real ( kind = rk ) a + real ( kind = rk ) b + real ( kind = rk ) v(1:m,0:n) + real ( kind = rk ) x(1:m) + real ( kind = rk ) xab(1:m) + + x(1:m) = ( 2.0D+00 * xab(1:m) - a - b ) / ( b - a ) + + call u_polynomial ( m, n, x, v ) + + return +end +function u_polynomial_ab_value ( a, b, n, xab ) + +!*****************************************************************************80 +! +!! U_POLYNOMIAL_AB_VALUE: evaluates Chebyshev polynomials UAB(n,x) in [A,B]. +! +! Discussion: +! +! UAB(n,x) = U(n,(2*x-a-b)/(b-a)) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = rk ) A, B, the domain of definition. +! +! Input, integer N, the highest polynomial to compute. +! +! Input, real ( kind = rk ) XAB, the evaluation point. +! It must be the case that A <= XAB <= B. +! +! Output, real ( kind = rk ) U_POLYNOMIAL_AB_VALUE, the value. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) a + real ( kind = rk ) b + real ( kind = rk ) u_polynomial_ab_value + real ( kind = rk ) u_polynomial_value + real ( kind = rk ) value + real ( kind = rk ) x + real ( kind = rk ) xab + + x = ( 2.0D+00 * xab - a - b ) / ( b - a ) + + value = u_polynomial_value ( n, x ) + + u_polynomial_ab_value = value + + return +end +subroutine u_polynomial_coefficients ( n, c ) + +!*****************************************************************************80 +! +!! U_POLYNOMIAL_COEFFICIENTS: coefficients of Chebyshev polynomials U(n,x). +! +! First terms: +! +! N/K 0 1 2 3 4 5 6 7 8 9 10 +! +! 0 1 +! 1 0 2 +! 2 -1 0 4 +! 3 0 -4 0 8 +! 4 1 0 -12 0 16 +! 5 0 6 0 -32 0 32 +! 6 -1 0 24 0 -80 0 64 +! 7 0 -8 0 80 0 -192 0 128 +! +! Recursion: +! +! U(0,X) = 1, +! U(1,X) = 2*X, +! U(N,X) = 2 * X * U(N-1,X) - U(N-2,X) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 February 2003 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Parameters: +! +! Input, integer N, the highest order polynomial to compute. +! Note that polynomials 0 through N will be computed. +! +! Output, real ( kind = rk ) C(0:N,0:N), the coefficients. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) c(0:n,0:n) + integer i + + if ( n < 0 ) then + return + end if + + c(0:n,0:n) = 0.0D+00 + + c(0,0) = 1.0D+00 + + if ( n == 0 ) then + return + end if + + c(1,1) = 2.0D+00 + + do i = 2, n + c(i,0) = - c(i-2,0) + c(i,1:i-2) = 2.0D+00 * c(i-1,0:i-3) - c(i-2,1:i-2) + c(i, i-1) = 2.0D+00 * c(i-1, i-2) + c(i, i ) = 2.0D+00 * c(i-1, i-1) + end do + + return +end +subroutine u_polynomial_plot ( n_num, n_val, output_filename ) + +!*****************************************************************************80 +! +!! U_POLYNOMIAL_PLOT plots Chebyshev polynomials U(n,x). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N_NUM, the number of polynomials to be plotted. +! +! Input, integer N_VAL(N_NUM), the degrees of 1 or more +! Chebyshev polynomials to be plotted together. +! +! Input, character ( len = * ) OUTPUT_FILENAME, the name into which the +! graphics information is to be stored. Note that the PNG format will +! be used. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer, parameter :: m = 501 + integer n_num + + real ( kind = rk ) a + real ( kind = rk ) b + integer column + character ( len = 255 ) command_filename + integer command_unit + character ( len = 255 ) data_filename + integer data_unit + integer i + integer i4vec_max + integer j + integer n + integer n_max + integer n_val(n_num) + character ( len = * ) output_filename + real ( kind = rk ), allocatable :: v(:,:) + real ( kind = rk ) x(m) + + a = -1.0D+00 + b = +1.0D+00 + + call r8vec_linspace ( m, a, b, x ) +! +! Compute all the data. +! + n_max = i4vec_max ( n_num, n_val ) + allocate ( v(m,0:n_max) ) + call u_polynomial ( m, n_max, x, v ) +! +! Create the data file. +! + data_filename = 'u_polynomial_data.txt' + call get_unit ( data_unit ) + open ( unit = data_unit, file = data_filename, status = 'replace' ) + do i = 1, m + write ( data_unit, '(2x,g14.6)', advance = 'no' ) x(i) + do j = 1, n_num + n = n_val(j) + write ( data_unit, '(2x,g14.6)', advance = 'no' ) v(i,n) + end do + write ( data_unit, '(a)' ) '' + end do + close ( unit = data_unit ) + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) & + ' Created graphics data file "' // trim ( data_filename ) // '".' +! +! Plot the selected data. +! + command_filename = 'u_polynomial_commands.txt' + call get_unit ( command_unit ) + open ( unit = command_unit, file = command_filename, status = 'replace' ) + + write ( command_unit, '(a)' ) '# ' // trim ( command_filename ) + write ( command_unit, '(a)' ) '#' + write ( command_unit, '(a)' ) '# Usage:' + write ( command_unit, '(a)' ) '# gnuplot < ' // trim ( command_filename ) + write ( command_unit, '(a)' ) '#' + write ( command_unit, '(a)' ) 'set term png' + write ( command_unit, '(a)' ) 'set nokey' + write ( command_unit, '(a)' ) & + 'set output "' // trim ( output_filename ) // '"' + write ( command_unit, '(a)' ) 'set xlabel "<---X--->"' + write ( command_unit, '(a)' ) 'set ylabel "<---U(n,x)--->"' + write ( command_unit, '(a)' ) & + 'set title "Chebyshev Polynomials U(n,x)"' + write ( command_unit, '(a)' ) 'set grid' + write ( command_unit, '(a)' ) 'set style data lines' + do j = 1, n_num + column = n_val(j) + 1 + if ( j == 1 ) then + write ( command_unit, '(a)', advance = 'no' ) 'plot ' + else + write ( command_unit, '(a)', advance = 'no' ) ' ' + end if + write ( command_unit, '(a,i2,a)', advance = 'no' ) & + '"' // trim ( data_filename ) // & + '" using 1:', column, ' lw 3 linecolor rgb "red"' + if ( j < n_num ) then + write ( command_unit, '(a)' ) ', \' + else + write ( command_unit, '(a)' ) '' + end if + end do + + close ( unit = command_unit ) + write ( *, '(a)' ) & + ' Created graphics command file "' // trim ( command_filename ) // '".' + + deallocate ( v ) + + return +end +function u_polynomial_value ( n, x ) + +!*****************************************************************************80 +! +!! U_POLYNOMIAL_VALUE: returns the single value U(n,x). +! +! Discussion: +! +! In cases where calling U_POLYNOMIAL is inconvenient, because it returns +! a vector of values for multiple arguments X, this simpler interface +! may be appropriate. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the polynomial. +! +! Input, real ( kind = rk ) X, the argument of the polynomial. +! +! Output, real ( kind = rk ) U_POLYNOMIAL_VALUE, the value of U(n,x). +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + real ( kind = rk ) u_polynomial_value + real ( kind = rk ) value + real ( kind = rk ), allocatable :: vec(:) + real ( kind = rk ) x + real ( kind = rk ) x_vec(1) + + if ( n < 0 ) then + + value = 0.0D+00 + + else + + m = 1 + allocate ( vec(0:n) ) + + x_vec(1) = x + call u_polynomial ( m, n, x_vec, vec ) + + value = vec(n) + deallocate ( vec ) + + end if + + u_polynomial_value = value + + return +end +subroutine u_polynomial_values ( n_data, n, x, fx ) + +!*****************************************************************************80 +! +!! U_POLYNOMIAL_VALUES returns values of Chebyshev polynomials U(n,x). +! +! Discussion: +! +! In Mathematica, the function can be evaluated by: +! +! ChebyshevU[n,x] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2015 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, integer N, the order of the function. +! +! Output, real ( kind = rk ) X, the point where the function is evaluated. +! +! Output, real ( kind = rk ) FX, the value of the function. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer, parameter :: n_max = 14 + + real ( kind = rk ) fx + real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & + 0.0000000000000000D+00, & + 0.1000000000000000D+01, & + 0.1600000000000000D+01, & + 0.1560000000000000D+01, & + 0.8960000000000000D+00, & + -0.1264000000000000D+00, & + -0.1098240000000000D+01, & + -0.1630784000000000D+01, & + -0.1511014400000000D+01, & + -0.7868390400000000D+00, & + 0.2520719360000000D+00, & + 0.1190154137600000D+01, & + 0.1652174684160000D+01, & + 0.1453325357056000D+01 /) + integer n + integer n_data + integer, save, dimension ( n_max ) :: n_vec = (/ & + -1, & + 0, 1, 2, & + 3, 4, 5, & + 6, 7, 8, & + 9, 10, 11, & + 12 /) + real ( kind = rk ) x + real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + n = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + n = n_vec(n_data) + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +subroutine u_polynomial_zeros ( n, z ) + +!*****************************************************************************80 +! +!! U_POLYNOMIAL_ZEROS returns zeroes of Chebyshev polynomials U(n,x). +! +! Discussion: +! +! The I-th zero of U(N,X) is cos((I-1)*PI/(N-1)), I = 1 to N +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the polynomial. +! +! Output, real ( kind = rk ) Z(N), the zeroes of U(N,X). +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) angle + integer i + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) z(n) + + do i = 1, n + angle = real ( i, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) + z(i) = cos ( angle ) + end do + + return +end +subroutine u_quadrature_rule ( n, t, w ) + +!*****************************************************************************80 +! +!! U_QUADRATURE_RULE: quadrature rule for U(n,x). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 23 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the rule. +! +! Output, real ( kind = rk ) T(N), W(N), the points and weights of the rule. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) bj(n) + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) t(n) + real ( kind = rk ) w(n) + + t(1:n) = 0.0D+00 + + bj(1:n) = 0.5D+00 + + w(1) = sqrt ( r8_pi / 2.0D+00 ) + w(2:n) = 0.0D+00 + + call imtqlx ( n, t, bj, w ) + + w(1:n) = w(1:n) ** 2 + + return +end +function uu_product ( i, j, x ) + +!*****************************************************************************80 +! +!! UU_PRODUCT: evaluate U(i,x)*U(j,x) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer I, J, the indices. +! +! Input, real ( kind = rk ) X, the argument. +! +! Output, real ( kind = rk ) UU_PRODUCT, the value. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer i + integer j + integer k + real ( kind = rk ) u_polynomial_value + real ( kind = rk ) uu_product + real ( kind = rk ) value + real ( kind = rk ) x + + value = 0.0D+00 + do k = abs ( i - j ), i + j, 2 + value = value + u_polynomial_value ( k, x ) + end do + + uu_product = value + + return +end +function uu_product_integral ( i, j ) + +!*****************************************************************************80 +! +!! UU_PRODUCT_INTEGRAL: integral (-1<=x<=1) U(i,x)*U(j,x)*sqrt(1-x^2) dx +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer I, J, the polynomial indices. +! 0 <= I, J. +! +! Output, real ( kind = rk ) UU_PRODUCT_INTEGRAL, the integral. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer i + integer j + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) uu_product_integral + real ( kind = rk ) value + + if ( i < 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'UU_PRODUCT_INTEGRAL - Fatal error!' + write ( *, '(a)' ) ' 0 <= I is required.' + stop 1 + end if + + if ( j < 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'UU_PRODUCT_INTEGRAL - Fatal error!' + write ( *, '(a)' ) ' 0 <= J is required.' + stop 1 + end if + + if ( i /= j ) then + value = 0.0D+00 + else + value = r8_pi / 2.0D+00 + end if + + uu_product_integral = value + + return +end +subroutine v_mass_matrix ( n, a ) + +!*****************************************************************************80 +! +!! V_MASS_MATRIX computes the mass matrix for the Chebyshev V polynomial. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 July 2015 +! +! Author: +! +! John Burkardt +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) a(0:n,0:n) + integer i + real ( kind = rk ), allocatable :: phi(:,:) + real ( kind = rk ), allocatable :: phiw(:,:) + real ( kind = rk ), allocatable :: w(:) + real ( kind = rk ), allocatable :: x(:) + + allocate ( x(0:n) ) + allocate ( w(0:n) ) + + call v_quadrature_rule ( n + 1, x, w ) + + allocate ( phi(0:n,0:n) ) + + call v_polynomial ( n + 1, n, x, phi ) + + allocate ( phiw(0:n,0:n) ) + + do i = 0, n + phiw(0:n,i) = w(i) * phi(i,0:n) + end do + + a(0:n,0:n) = matmul ( phiw(0:n,0:n), phi(0:n,0:n) ) + + deallocate ( phi ) + deallocate ( phiw ) + deallocate ( w ) + deallocate ( x ) + + return +end +function v_moment ( e ) + +!*****************************************************************************80 +! +!! V_MOMENT: integral ( -1 <= x <= +1 ) x^e sqrt(1+x) / sqrt(1-x) dx. +! +! Discussion: +! +! E V_MOMENT +! -- -------------- +! 0 pi +! 1 pi / 2 +! 2 pi / 2 +! 3 3 pi / 8 +! 4 3 pi / 8 +! 5 5 pi / 16 +! 6 5 pi / 16 +! 7 35 pi / 128 +! 8 35 pi / 128 +! 9 63 pi / 256 +! 10 63 pi / 256 +! 11 231 pi / 1024 +! 12 231 pi / 1024 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer E, the exponent of X. +! 0 <= E. +! +! Output, real ( kind = rk ) V_MOMENT, the value of the integral. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + real ( kind = rk ) f1 + real ( kind = rk ) f2 + real ( kind = rk ) f3 + real ( kind = rk ) f4 + real ( kind = rk ) f5 + real ( kind = rk ) f6 + real ( kind = rk ) f7 + real ( kind = rk ) f8 + integer e + real ( kind = rk ) r8_e + real ( kind = rk ) r8_factorial + real ( kind = rk ) r8_hyper_2f1 + real ( kind = rk ) r8_mop + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) v_moment + real ( kind = rk ) value + + r8_e = real ( e, kind = rk ) + + f1 = 1.0D+00 / gamma ( 1.5D+00 + r8_e ) + f2 = r8_mop ( e ) + f3 = r8_pi * gamma ( 1.5D+00 + r8_e ) + f4 = 2.0D+00 * r8_hyper_2f1 ( 0.5D+00, -r8_e, 1.0D+00, 2.0D+00 ) + f5 = ( -1.0D+00 + r8_mop ( e ) ) & + * r8_hyper_2f1 ( 0.5D+00, -r8_e, 2.0D+00, 2.0D+00 ) + f6 = sqrt ( r8_pi ) * r8_factorial ( e ) + f7 = ( -1.0D+00 + r8_mop ( e ) ) & + * r8_hyper_2f1 ( -0.5D+00, 1.0D+00 + r8_e, 1.5D+00 + r8_e, - 1.0D+00 ) + f8 = 2.0D+00 & + * r8_hyper_2f1 ( 0.5D+00, 1.0D+00 + r8_e, 1.5D+00 + r8_e, -1.0D+00 ) + + value = f1 * f2 * ( f3 * ( f4 + f5 ) - f6 * ( f7 + f8 ) ) + + v_moment = value + + return +end +subroutine v_polynomial ( m, n, x, v ) + +!*****************************************************************************80 +! +!! V_POLYNOMIAL evaluates Chebyshev polynomials V(n,x). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 23 April 2012 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Parameters: +! +! Input, integer M, the number of evaluation points. +! +! Input, integer N, the highest polynomial to compute. +! +! Input, real ( kind = rk ) X(M), the evaluation points. +! +! Output, real ( kind = rk ) V(M,0:N), the values. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + + integer i + real ( kind = rk ) v(m,0:n) + real ( kind = rk ) x(m) + + if ( n < 0 ) then + return + end if + + v(1:m,0) = 1.0D+00 + + if ( n < 1 ) then + return + end if + + v(1:m,1) = 2.0D+00 * x(1:m) - 1.0D+00 + + do i = 2, n + v(1:m,i) = 2.0D+00 * x(1:m) * v(1:m,i-1) - v(1:m,i-2) + end do + + return +end +subroutine v_polynomial_01_values ( n_data, n, x, fx ) + +!*****************************************************************************80 +! +!! V_POLYNOMIAL_01_VALUES: values of shifted Chebyshev polynomials V01(n,x). +! +! Discussion: +! +! The shifted Chebyshev polynomial V01(n,x) = V(n,2*x-1). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 July 2015 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, integer N, the order of the function. +! +! Output, real ( kind = rk ) X, the point where the function is evaluated. +! +! Output, real ( kind = rk ) FX, the value of the function. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer, parameter :: n_max = 25 + + real ( kind = rk ) fx + real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & + 0.0000000000000000D+00, & + 1.0000000000000000D+00, & + 0.4000000000000000D+00, & + -0.4400000000000000D+00, & + -1.0160000000000000D+00, & + -0.9824000000000000D+00, & + -0.3593600000000000D+00, & + 0.4792960000000000D+00, & + 1.0303744000000000D+00, & + 0.9632281600000000D+00, & + 0.3181450240000000D+00, & + -0.5178251264000000D+00, & + -1.0431002009600000D+00, & + -0.9425151549440000D+00, & + -15.000000000000000D+00, & + 3.1417984000000000D+00, & + -1.3912448000000000D+00, & + -1.2177792000000000D+00, & + 1.1837056000000000D+00, & + 1.0000000000000000D+00, & + -0.8558976000000000D+00, & + -0.8905088000000000D+00, & + 0.8752768000000000D+00, & + 0.1197696000000000D+00, & + 1.0000000000000000D+00 /) + integer n + integer n_data + integer, save, dimension ( n_max ) :: n_vec = (/ & + -1, & + 0, 1, 2, & + 3, 4, 5, & + 6, 7, 8, & + 9, 10, 11, & + 12, 7, 7, & + 7, 7, 7, & + 7, 7, 7, & + 7, 7, 7 /) + real ( kind = rk ) x + real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.85D+00, & + 0.00D+00, & + 0.10D+00, & + 0.20D+00, & + 0.30D+00, & + 0.40D+00, & + 0.50D+00, & + 0.60D+00, & + 0.70D+00, & + 0.80D+00, & + 0.90D+00, & + 1.00D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + n = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + n = n_vec(n_data) + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +subroutine v_polynomial_ab ( a, b, m, n, xab, v ) + +!*****************************************************************************80 +! +!! V_POLYNOMIAL_AB: evaluates Chebyshev polynomials VAB(n,x) in [A,B]. +! +! Discussion: +! +! VAB(n,x) = V(n,(2*x-a-b)/(b-a)) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = rk ) A, B, the domain of definition. +! +! Input, integer M, the number of evaluation points. +! +! Input, integer N, the highest polynomial to compute. +! +! Input, real ( kind = rk ) XAB(M), the evaluation points. +! It must be the case that A <= XAB(*) <= B. +! +! Output, real ( kind = rk ) V(M,N+1), the values. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + + real ( kind = rk ) a + real ( kind = rk ) b + real ( kind = rk ) v(1:m,0:n) + real ( kind = rk ) x(1:m) + real ( kind = rk ) xab(1:m) + + x(1:m) = ( 2.0D+00 * xab(1:m) - a - b ) / ( b - a ) + + call v_polynomial ( m, n, x, v ) + + return +end +function v_polynomial_ab_value ( a, b, n, xab ) + +!*****************************************************************************80 +! +!! V_POLYNOMIAL_AB_VALUE: evaluates Chebyshev polynomials VAB(n,x) in [A,B]. +! +! Discussion: +! +! VAB(n,x) = V(n,(2*x-a-b)/(b-a)) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 17 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = rk ) A, B, the domain of definition. +! +! Input, integer N, the highest polynomial to compute. +! +! Input, real ( kind = rk ) XAB, the evaluation point. +! It must be the case that A <= XAB <= B. +! +! Output, real ( kind = rk ) V_POLYNOMIAL_AB_VALUE, the value. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) a + real ( kind = rk ) b + real ( kind = rk ) v_polynomial_ab_value + real ( kind = rk ) v_polynomial_value + real ( kind = rk ) value + real ( kind = rk ) x + real ( kind = rk ) xab + + x = ( 2.0D+00 * xab - a - b ) / ( b - a ) + + value = v_polynomial_value ( n, x ) + + v_polynomial_ab_value = value + + return +end +subroutine v_polynomial_coefficients ( n, c ) + +!*****************************************************************************80 +! +!! V_POLYNOMIAL_COEFFICIENTS: coefficients of Chebyshev polynomials V(n,x). +! +! First terms: +! +! N/K 0 1 2 3 4 5 6 7 8 9 10 +! +! 0 1 +! 1 -1 2 +! 2 -1 -2 4 +! 3 1 -4 -4 8 +! 4 1 +4 -12 -8 16 +! 5 -1 6 +12 -32 -16 32 +! 6 -1 -6 24 +32 -80 -32 64 +! 7 +1 -8 -24 80 +80 -192 -64 128 +! +! Recursion: +! +! V(0,X) = 1, +! V(1,X) = 2 * X - 1, +! V(N,X) = 2 * X * V(N-1,X) - V(N-2,X) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 July 2015 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Parameters: +! +! Input, integer N, the highest order polynomial to compute. +! Note that polynomials 0 through N will be computed. +! +! Output, real ( kind = rk ) C(0:N,0:N), the coefficients. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) c(0:n,0:n) + integer i + + if ( n < 0 ) then + return + end if + + c(0:n,0:n) = 0.0D+00 + + c(0,0) = 1.0D+00 + + if ( n == 0 ) then + return + end if + + c(1,0) = -1.0D+00 + c(1,1) = 2.0D+00 + + do i = 2, n + c(i,0) = - c(i-2,0) + c(i,1:i-2) = 2.0D+00 * c(i-1,0:i-3) - c(i-2,1:i-2) + c(i, i-1) = 2.0D+00 * c(i-1, i-2) + c(i, i ) = 2.0D+00 * c(i-1, i-1) + end do + + return +end +subroutine v_polynomial_plot ( n_num, n_val, output_filename ) + +!*****************************************************************************80 +! +!! V_POLYNOMIAL_PLOT plots Chebyshev polynomials V(n,x). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N_NUM, the number of polynomials to be plotted. +! +! Input, integer N_VAL(N_NUM), the degrees of 1 or more +! Chebyshev polynomials to be plotted together. +! +! Input, character ( len = * ) OUTPUT_FILENAME, the name into which the +! graphics information is to be stored. Note that the PNG format will +! be used. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer, parameter :: m = 501 + integer n_num + + real ( kind = rk ) a + real ( kind = rk ) b + integer column + character ( len = 255 ) command_filename + integer command_unit + character ( len = 255 ) data_filename + integer data_unit + integer i + integer i4vec_max + integer j + integer n + integer n_max + integer n_val(n_num) + character ( len = * ) output_filename + real ( kind = rk ), allocatable :: v(:,:) + real ( kind = rk ) x(m) + + a = -1.0D+00 + b = +1.0D+00 + + call r8vec_linspace ( m, a, b, x ) +! +! Compute all the data. +! + n_max = i4vec_max ( n_num, n_val ) + allocate ( v(m,0:n_max) ) + call v_polynomial ( m, n_max, x, v ) +! +! Create the data file. +! + data_filename = 'v_polynomial_data.txt' + call get_unit ( data_unit ) + open ( unit = data_unit, file = data_filename, status = 'replace' ) + do i = 1, m + write ( data_unit, '(2x,g14.6)', advance = 'no' ) x(i) + do j = 1, n_num + n = n_val(j) + write ( data_unit, '(2x,g14.6)', advance = 'no' ) v(i,n) + end do + write ( data_unit, '(a)' ) '' + end do + close ( unit = data_unit ) + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) & + ' Created graphics data file "' // trim ( data_filename ) // '".' +! +! Plot the selected data. +! + command_filename = 'v_polynomial_commands.txt' + call get_unit ( command_unit ) + open ( unit = command_unit, file = command_filename, status = 'replace' ) + + write ( command_unit, '(a)' ) '# ' // trim ( command_filename ) + write ( command_unit, '(a)' ) '#' + write ( command_unit, '(a)' ) '# Usage:' + write ( command_unit, '(a)' ) '# gnuplot < ' // trim ( command_filename ) + write ( command_unit, '(a)' ) '#' + write ( command_unit, '(a)' ) 'set term png' + write ( command_unit, '(a)' ) 'set nokey' + write ( command_unit, '(a)' ) & + 'set output "' // trim ( output_filename ) // '"' + write ( command_unit, '(a)' ) 'set xlabel "<---X--->"' + write ( command_unit, '(a)' ) 'set ylabel "<---T(n,x)--->"' + write ( command_unit, '(a)' ) & + 'set title "Chebyshev Polynomials V(n,x)"' + write ( command_unit, '(a)' ) 'set grid' + write ( command_unit, '(a)' ) 'set style data lines' + do j = 1, n_num + column = n_val(j) + 1 + if ( j == 1 ) then + write ( command_unit, '(a)', advance = 'no' ) 'plot ' + else + write ( command_unit, '(a)', advance = 'no' ) ' ' + end if + write ( command_unit, '(a,i2,a)', advance = 'no' ) & + '"' // trim ( data_filename ) // & + '" using 1:', column, ' lw 3 linecolor rgb "red"' + if ( j < n_num ) then + write ( command_unit, '(a)' ) ', \' + else + write ( command_unit, '(a)' ) '' + end if + end do + + close ( unit = command_unit ) + write ( *, '(a)' ) & + ' Created graphics command file "' // trim ( command_filename ) // '".' + + deallocate ( v ) + + return +end +function v_polynomial_value ( n, x ) + +!*****************************************************************************80 +! +!! V_POLYNOMIAL_VALUE: returns the single value V(n,x). +! +! Discussion: +! +! In cases where calling V_POLYNOMIAL is inconvenient, because it returns +! a vector of values for multiple arguments X, this simpler interface +! may be appropriate. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the polynomial. +! +! Input, real ( kind = rk ) X, the argument of the polynomial. +! +! Output, real ( kind = rk ) V_POLYNOMIAL_VALUE, the value of V(n,x). +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + real ( kind = rk ) v_polynomial_value + real ( kind = rk ) value + real ( kind = rk ), allocatable :: vec(:) + real ( kind = rk ) x + real ( kind = rk ) x_vec(1) + + if ( n < 0 ) then + + value = 0.0D+00 + + else + + m = 1 + allocate ( vec(0:n) ) + + x_vec(1) = x + call v_polynomial ( m, n, x_vec, vec ) + + value = vec(n) + deallocate ( vec ) + + end if + + v_polynomial_value = value + + return +end +subroutine v_polynomial_values ( n_data, n, x, fx ) + +!*****************************************************************************80 +! +!! V_POLYNOMIAL_VALUES returns values of Chebyshev polynomials V(n,x). +! +! Discussion: +! +! In Mathematica, the function can be evaluated by: +! +! u = Sqrt[(x+1)/2], +! ChebyshevT[2*n+1,u] / u +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2015 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, integer N, the order of the function. +! +! Output, real ( kind = rk ) X, the point where the function is evaluated. +! +! Output, real ( kind = rk ) FX, the value of the function. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer, parameter :: n_max = 14 + + real ( kind = rk ) fx + real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & + 0.0000000000000000D+00, & + 1.0000000000000000D+00, & + 0.6000000000000000D+00, & + -0.0400000000000000D+00, & + -0.6640000000000000D+00, & + -1.0224000000000000D+00, & + -0.9718400000000000D+00, & + -0.5325440000000000D+00, & + 0.1197696000000000D+00, & + 0.7241753600000000D+00, & + 1.0389109760000000D+00, & + 0.9380822016000000D+00, & + 0.4620205465600000D+00, & + -0.1988493271040000D+00 /) + integer n + integer n_data + integer, save, dimension ( n_max ) :: n_vec = (/ & + -1, & + 0, 1, 2, & + 3, 4, 5, & + 6, 7, 8, & + 9, 10, 11, & + 12 /) + real ( kind = rk ) x + real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + n = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + n = n_vec(n_data) + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +subroutine v_polynomial_zeros ( n, z ) + +!*****************************************************************************80 +! +!! V_POLYNOMIAL_ZEROS returns zeroes of Chebyshev polynomials V(n,x). +! +! Discussion: +! +! The I-th zero of U(N,X) is cos((I-1/2)*PI/(N+1/2)), I = 1 to N +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the polynomial. +! +! Output, real ( kind = rk ) Z(N), the zeroes. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) angle + integer i + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) z(n) + + do i = 1, n + angle = real ( 2 * n - 2 * i + 1, kind = rk ) * r8_pi & + / real ( 2 * n + 1, kind = rk ) + z(i) = cos ( angle ) + end do + + return +end +subroutine v_quadrature_rule ( n, t, w ) + +!*****************************************************************************80 +! +!! V_QUADRATURE_RULE: quadrature rule for V(n,x). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the rule. +! +! Output, real ( kind = rk ) T(N), W(N), the points and weights of the rule. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) bj(n) + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) t(n) + real ( kind = rk ) w(n) + + t(1:n) = 0.0D+00 + t(1) = + 0.5D+00 + + bj(1:n) = 0.5D+00 + + w(1) = sqrt ( r8_pi ) + w(2:n) = 0.0D+00 + + call imtqlx ( n, t, bj, w ) + + w(1:n) = w(1:n) ** 2 + + return +end +function vv_product_integral ( i, j ) + +!*****************************************************************************80 +! +!! VV_PRODUCT_INTEGRAL: int (-1"' + write ( command_unit, '(a)' ) 'set ylabel "<---T(n,x)--->"' + write ( command_unit, '(a)' ) & + 'set title "Chebyshev Polynomials W(n,x)"' + write ( command_unit, '(a)' ) 'set grid' + write ( command_unit, '(a)' ) 'set style data lines' + do j = 1, n_num + column = n_val(j) + 1 + if ( j == 1 ) then + write ( command_unit, '(a)', advance = 'no' ) 'plot ' + else + write ( command_unit, '(a)', advance = 'no' ) ' ' + end if + write ( command_unit, '(a,i2,a)', advance = 'no' ) & + '"' // trim ( data_filename ) // & + '" using 1:', column, ' lw 3 linecolor rgb "red"' + if ( j < n_num ) then + write ( command_unit, '(a)' ) ', \' + else + write ( command_unit, '(a)' ) '' + end if + end do + + close ( unit = command_unit ) + write ( *, '(a)' ) & + ' Created graphics command file "' // trim ( command_filename ) // '".' + + deallocate ( v ) + + return +end +function w_polynomial_value ( n, x ) + +!*****************************************************************************80 +! +!! W_POLYNOMIAL_VALUE: returns the single value W(n,x). +! +! Discussion: +! +! In cases where calling W_POLYNOMIAL is inconvenient, because it returns +! a vector of values for multiple arguments X, this simpler interface +! may be appropriate. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 11 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the polynomial. +! +! Input, real ( kind = rk ) X, the argument of the polynomial. +! +! Output, real ( kind = rk ) W_POLYNOMIAL_VALUE, the value of T(n,x). +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer m + integer n + real ( kind = rk ) value + real ( kind = rk ), allocatable :: vec(:) + real ( kind = rk ) w_polynomial_value + real ( kind = rk ) x + real ( kind = rk ) x_vec(1) + + if ( n < 0 ) then + + value = 0.0D+00 + + else + + m = 1 + allocate ( vec(0:n) ) + + x_vec(1) = x + call w_polynomial ( m, n, x_vec, vec ) + + value = vec(n) + deallocate ( vec ) + + end if + + w_polynomial_value = value + + return +end +subroutine w_polynomial_values ( n_data, n, x, fx ) + +!*****************************************************************************80 +! +!! W_POLYNOMIAL_VALUES returns values of Chebyshev polynomials W(n,x). +! +! Discussion: +! +! In Mathematica, the function can be evaluated by: +! +! u = Sqrt[(x+1)/2], +! ChebyshevU[2*n,u] +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 10 July 2015 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Milton Abramowitz, Irene Stegun, +! Handbook of Mathematical Functions, +! National Bureau of Standards, 1964, +! ISBN: 0-486-61272-4, +! LC: QA47.A34. +! +! Stephen Wolfram, +! The Mathematica Book, +! Fourth Edition, +! Cambridge University Press, 1999, +! ISBN: 0-521-64314-7, +! LC: QA76.95.W65. +! +! Parameters: +! +! Input/output, integer N_DATA. The user sets N_DATA to 0 +! before the first call. On each call, the routine increments N_DATA by 1, +! and returns the corresponding data; when there is no more data, the +! output value of N_DATA will be 0 again. +! +! Output, integer N, the order of the function. +! +! Output, real ( kind = rk ) X, the point where the function is evaluated. +! +! Output, real ( kind = rk ) FX, the value of the function. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer, parameter :: n_max = 14 + + real ( kind = rk ) fx + real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & + 0.000000000000000D+00, & + 1.000000000000000D+00, & + 2.600000000000000D+00, & + 3.160000000000000D+00, & + 2.456000000000000D+00, & + 0.769600000000000D+00, & + -1.224640000000000D+00, & + -2.729024000000000D+00, & + -3.141798400000000D+00, & + -2.297853440000000D+00, & + -0.534767104000000D+00, & + 1.442226073600000D+00, & + 2.842328821760000D+00, & + 3.105500041216000D+00 /) + integer n + integer n_data + integer, save, dimension ( n_max ) :: n_vec = (/ & + -1, & + 0, 1, 2, & + 3, 4, 5, & + 6, 7, 8, & + 9, 10, 11, & + 12 /) + real ( kind = rk ) x + real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00, & + 0.8D+00 /) + + if ( n_data < 0 ) then + n_data = 0 + end if + + n_data = n_data + 1 + + if ( n_max < n_data ) then + n_data = 0 + n = 0 + x = 0.0D+00 + fx = 0.0D+00 + else + n = n_vec(n_data) + x = x_vec(n_data) + fx = fx_vec(n_data) + end if + + return +end +subroutine w_polynomial_zeros ( n, z ) + +!*****************************************************************************80 +! +!! W_POLYNOMIAL_ZEROS returns zeroes of Chebyshev polynomials W(n,x). +! +! Discussion: +! +! The I-th zero of U(N,X) is cos(I*PI/(N+1/2)), I = 1 to N +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 April 2012 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the polynomial. +! +! Output, real ( kind = rk ) Z(N), the zeroes. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) angle + integer i + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) z(n) + + do i = 1, n + angle = real ( 2 * ( n - i + 1 ), kind = rk ) * r8_pi & + / real ( 2 * n + 1, kind = rk ) + z(i) = cos ( angle ) + end do + + return +end +subroutine w_quadrature_rule ( n, t, w ) + +!*****************************************************************************80 +! +!! W_QUADRATURE_RULE: quadrature rule for W(n,x). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 July 2015 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer N, the order of the rule. +! +! Output, real ( kind = rk ) T(N), W(N), the points and weights of the rule. +! + implicit none + + integer, parameter :: rk = kind ( 1.0D+00 ) + + integer n + + real ( kind = rk ) bj(n) + real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 + real ( kind = rk ) t(n) + real ( kind = rk ) w(n) + + t(1:n) = 0.0D+00 + t(1) = - 0.5D+00 + + bj(1:n) = 0.5D+00 + + w(1) = sqrt ( r8_pi ) + w(2:n) = 0.0D+00 + + call imtqlx ( n, t, bj, w ) + + w(1:n) = w(1:n) ** 2 + + return +end +function ww_product_integral ( i, j ) + +!*****************************************************************************80 +! +!! WW_PRODUCT_INTEGRAL: int (-1 Date: Sat, 29 Oct 2022 14:46:48 +0900 Subject: [PATCH 37/43] undefined --- src/modules/Utility/CMakeLists.txt | 2 + src/modules/Utility/src/InvUtility.F90 | 8 + src/modules/Utility/src/MappingUtility.F90 | 262 +++++++++++++++ src/modules/Utility/src/Utility.F90 | 2 + src/modules/Utility/src/ZerosUtility.F90 | 363 +++++++++++++++++++++ 5 files changed, 637 insertions(+) create mode 100644 src/modules/Utility/src/MappingUtility.F90 create mode 100644 src/modules/Utility/src/ZerosUtility.F90 diff --git a/src/modules/Utility/CMakeLists.txt b/src/modules/Utility/CMakeLists.txt index bf3b28bf9..4a843172e 100644 --- a/src/modules/Utility/CMakeLists.txt +++ b/src/modules/Utility/CMakeLists.txt @@ -18,6 +18,7 @@ SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") TARGET_SOURCES( ${PROJECT_NAME} PRIVATE + ${src_path}/MappingUtility.F90 ${src_path}/BinomUtility.F90 ${src_path}/AppendUtility.F90 ${src_path}/ApproxUtility.F90 @@ -25,6 +26,7 @@ TARGET_SOURCES( ${src_path}/FunctionalFortranUtility.F90 ${src_path}/GridPointUtility.F90 ${src_path}/OnesUtility.F90 + ${src_path}/ZerosUtility.F90 ${src_path}/EyeUtility.F90 ${src_path}/DiagUtility.F90 ${src_path}/HashingUtility.F90 diff --git a/src/modules/Utility/src/InvUtility.F90 b/src/modules/Utility/src/InvUtility.F90 index 9262374be..6f3d46533 100644 --- a/src/modules/Utility/src/InvUtility.F90 +++ b/src/modules/Utility/src/InvUtility.F90 @@ -56,6 +56,10 @@ END FUNCTION det_3D ! INV@InverseMethods !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of small matrix upto size 4 + INTERFACE MODULE PURE SUBROUTINE Inv_2D(invA, A) REAL(DFP), INTENT(INOUT) :: invA(:, :) @@ -73,6 +77,10 @@ MODULE PURE SUBROUTINE Inv_2D(invA, A) ! INV@InverseMethods !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 18 Oct 2022 +! summary: Inverse of small matrix upto size 4 + INTERFACE MODULE PURE SUBROUTINE Inv_3D(invA, A) REAL(DFP), INTENT(INOUT) :: invA(:, :, :) diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 new file mode 100644 index 000000000..1c3000466 --- /dev/null +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -0,0 +1,262 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Some methods related to standard mapping are defined +! +!{!pages/MappingUtility_.md!} + +MODULE MappingUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE + MODULE PURE FUNCTION FromBiunitLine2Segment1(xin, x1, x2) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in [-1,1] + REAL(DFP), INTENT(IN) :: x1 + !! x1 of physical domain + REAL(DFP), INTENT(IN) :: x2 + !! x2 of physical domain + REAL(DFP) :: ans(SIZE(xin)) + !! mapped coordinates of xin in physical domain + END FUNCTION FromBiunitLine2Segment1 +END INTERFACE + +INTERFACE FromBiunitLine2Segment + MODULE PROCEDURE FromBiunitLine2Segment1 +END INTERFACE FromBiunitLine2Segment + +PUBLIC :: FromBiunitLine2Segment + +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE + MODULE PURE FUNCTION FromBiunitLine2Segment2(xin, x1, x2) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in [-1,1], SIZE(xin) = n + REAL(DFP), INTENT(IN) :: x1(:) + !! x1 of physical domain, SIZE(x1) = nsd + REAL(DFP), INTENT(IN) :: x2(:) + !! x2 of physical domain, SIZE(x2) = nsd + REAL(DFP) :: ans(SIZE(x1), SIZE(xin)) + !! returned coordinates in physical space + !! ans is in xij format + END FUNCTION FromBiunitLine2Segment2 +END INTERFACE + +INTERFACE FromBiunitLine2Segment + MODULE PROCEDURE FromBiunitLine2Segment2 +END INTERFACE FromBiunitLine2Segment + +!---------------------------------------------------------------------------- +! FromUnitTriangle2Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to physical space + +INTERFACE + MODULE PURE FUNCTION FromUnitTriangle2Triangle1(xin, x1, x2, x3) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! vertex coordinate of unit triangle + !! (0,0), (1,0), (0,1) + !! shape(xin) = (2,N) + REAL(DFP), INTENT(IN) :: x1(:) + !! x1 of physical domain, size(x1) = nsd + REAL(DFP), INTENT(IN) :: x2(:) + !! x2 of physical domain, size(x2) = nsd + REAL(DFP), INTENT(IN) :: x3(:) + !! x3 of physical domain, size(x3) = nsd + REAL(DFP) :: ans(SIZE(x1), SIZE(xin, 2)) + !! mapped coordinates of xin in physical domain + !! shape(ans) = nsd, N + END FUNCTION FromUnitTriangle2Triangle1 +END INTERFACE + +INTERFACE FromUnitTriangle2Triangle + MODULE PROCEDURE FromUnitTriangle2Triangle1 +END INTERFACE FromUnitTriangle2Triangle + +PUBLIC :: FromUnitTriangle2Triangle + +!---------------------------------------------------------------------------- +! FromBiUnitLine2UnitLine +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit line to unit line +! +!# Introduction +! +!- Bi unit line is defined by -1 to 1. +!- Unit line is defined by 0 to 1 + +INTERFACE + MODULE PURE FUNCTION FromBiUnitLine2UnitLine(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in biunit line + REAL(DFP) :: ans(SIZE(xin)) + !! mapped coordinates of xin in unit line + END FUNCTION FromBiUnitLine2UnitLine +END INTERFACE + +PUBLIC :: FromBiUnitLine2UnitLine + +!---------------------------------------------------------------------------- +! FromUnitLine2BiUnitLine +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from unit line to biunit line +! +!# Introduction +! +!- Bi unit line is defined by -1 to 1. +!- Unit line is defined by 0 to 1 + +INTERFACE + MODULE PURE FUNCTION FromUnitLine2BiUnitLine(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:) + !! coordinates in unit line + REAL(DFP) :: ans(SIZE(xin)) + !! mapped coordinates of xin in biunit line + END FUNCTION FromUnitLine2BiUnitLine +END INTERFACE + +PUBLIC :: FromUnitLine2BiUnitLine + +!---------------------------------------------------------------------------- +! FromBiUnitTriangle2BiUnitSqr +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit triangle to bi-unit square +! +!# Introduction +! +!- Bi unit triangle is defined by (-1,-1), (1,-1), and (-1,1) +!- Bi unit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) + +INTERFACE + MODULE PURE FUNCTION FromBiUnitTriangle2BiUnitSqr(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in biunit triangle in xij format + !! bi unit triangle is defined by + !! (-1,-1), (1,-1), (-1,1) + REAL(DFP) :: ans(2, SIZE(xin, 2)) + !! mapped coordinates of xin in biunit sqr + END FUNCTION FromBiUnitTriangle2BiUnitSqr +END INTERFACE + +PUBLIC :: FromBiUnitTriangle2BiUnitSqr + +!---------------------------------------------------------------------------- +! FromBiUnitSqr2BiUnitTriangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit triangle to bi-unit square +! +!# Introduction +! +!- Bi unit triangle is defined by (-1,-1), (1,-1), and (-1,1) +!- Bi unit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) + +INTERFACE + MODULE PURE FUNCTION FromBiUnitSqr2BiUnitTriangle(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in bi-unit square in xij coordinate + REAL(DFP) :: ans(2, SIZE(xin, 2)) + !! coordinates in biunit triangle + END FUNCTION FromBiUnitSqr2BiUnitTriangle +END INTERFACE + +PUBLIC :: FromBiUnitSqr2BiUnitTriangle + +!---------------------------------------------------------------------------- +! FromUnitTriangle2BiUnitSqr +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit triangle to bi-unit square +! +!# Introduction +! +!- Unit triangle is defined by (0,0), (0,1), and (1,0) +!- Biunit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) + +INTERFACE + MODULE PURE FUNCTION FromUnitTriangle2BiUnitSqr(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in biunit triangle in xij format + !! bi unit triangle is defined by + !! (-1,-1), (1,-1), (-1,1) + REAL(DFP) :: ans(2, SIZE(xin, 2)) + !! mapped coordinates of xin in biunit sqr + END FUNCTION FromUnitTriangle2BiUnitSqr +END INTERFACE + +PUBLIC :: FromUnitTriangle2BiUnitSqr + +!---------------------------------------------------------------------------- +! FromBiUnitSqr2UnitTriangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 19 Oct 2022 +! summary: Map from biunit triangle to bi-unit square +! +!# Introduction +! +!- Unit triangle is defined by (0,0), (0,1), and (1,0) +!- Bi unit square is defined by (-1,-1), (1,-1), (1,1), and (-1,1) + +INTERFACE + MODULE PURE FUNCTION FromBiUnitSqr2UnitTriangle(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + !! coordinates in bi-unit square in xij coordinate + REAL(DFP) :: ans(2, SIZE(xin, 2)) + !! coordinates in biunit triangle + END FUNCTION FromBiUnitSqr2UnitTriangle +END INTERFACE + +PUBLIC :: FromBiUnitSqr2UnitTriangle + +END MODULE MappingUtility diff --git a/src/modules/Utility/src/Utility.F90 b/src/modules/Utility/src/Utility.F90 index 6c9a81ec4..ba0004514 100755 --- a/src/modules/Utility/src/Utility.F90 +++ b/src/modules/Utility/src/Utility.F90 @@ -15,6 +15,7 @@ ! along with this program. If not, see MODULE Utility +USE MappingUtility USE BinomUtility USE AppendUtility USE ApproxUtility @@ -22,6 +23,7 @@ MODULE Utility USE FunctionalFortranUtility USE GridPointUtility USE OnesUtility +USE ZerosUtility USE EyeUtility USE DiagUtility USE HashingUtility diff --git a/src/modules/Utility/src/ZerosUtility.F90 b/src/modules/Utility/src/ZerosUtility.F90 new file mode 100644 index 000000000..37ee09d66 --- /dev/null +++ b/src/modules/Utility/src/ZerosUtility.F90 @@ -0,0 +1,363 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE ZerosUtility +USE GlobalData +IMPLICIT NONE +PRIVATE + +PUBLIC :: Zeros +! +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_1(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int8), INTENT(IN) :: datatype + INTEGER(Int8) :: ans(dim1) + END FUNCTION Zeros_1 +!! + MODULE PURE FUNCTION Zeros_2(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int16), INTENT(IN) :: datatype + INTEGER(Int16) :: ans(dim1) + END FUNCTION Zeros_2 +!! + MODULE PURE FUNCTION Zeros_3(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int32), INTENT(IN) :: datatype + INTEGER(Int32) :: ans(dim1) + END FUNCTION Zeros_3 +!! + MODULE PURE FUNCTION Zeros_4(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int64), INTENT(IN) :: datatype + INTEGER(Int64) :: ans(dim1) + END FUNCTION Zeros_4 + +#ifdef USE_Int128 +!! + MODULE PURE FUNCTION Zeros_5(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1) + END FUNCTION Zeros_5 +#endif +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_1, Zeros_2, Zeros_3, Zeros_4 +END INTERFACE Zeros + +#ifdef USE_Int128 +INTERFACE Zeros + MODULE PROCEDURE Zeros_5 +END INTERFACE Zeros +#endif + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_6(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + REAL(Real32), INTENT(IN) :: datatype + REAL(Real32) :: ans(dim1) + END FUNCTION Zeros_6 +!! + MODULE PURE FUNCTION Zeros_7(dim1, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + REAL(Real64), INTENT(IN) :: datatype + REAL(Real64) :: ans(dim1) + END FUNCTION Zeros_7 +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_6, Zeros_7 +END INTERFACE Zeros + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_8(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int8), INTENT(IN) :: datatype + INTEGER(Int8) :: ans(dim1, dim2) + END FUNCTION Zeros_8 +!! + MODULE PURE FUNCTION Zeros_9(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int16), INTENT(IN) :: datatype + INTEGER(Int16) :: ans(dim1, dim2) + END FUNCTION Zeros_9 +!! + MODULE PURE FUNCTION Zeros_10(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int32), INTENT(IN) :: datatype + INTEGER(Int32) :: ans(dim1, dim2) + END FUNCTION Zeros_10 +!! + MODULE PURE FUNCTION Zeros_11(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int64), INTENT(IN) :: datatype + INTEGER(Int64) :: ans(dim1, dim2) + END FUNCTION Zeros_11 +!! +#ifdef USE_Int128 +!! + MODULE PURE FUNCTION Zeros_12(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1, dim2) + END FUNCTION Zeros_12 +#endif +!! +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_8, Zeros_9, Zeros_10, Zeros_11 +END INTERFACE Zeros + +#ifdef USE_Int128 +INTERFACE Zeros + MODULE PROCEDURE Zeros_12 +END INTERFACE Zeros +#endif + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_13(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + REAL(Real32), INTENT(IN) :: datatype + REAL(Real32) :: ans(dim1, dim2) + END FUNCTION Zeros_13 +!! + MODULE PURE FUNCTION Zeros_14(dim1, dim2, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + REAL(Real64), INTENT(IN) :: datatype + REAL(Real64) :: ans(dim1, dim2) + END FUNCTION Zeros_14 +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_13, Zeros_14 +END INTERFACE Zeros + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_15(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int8), INTENT(IN) :: datatype + INTEGER(Int8) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_15 +!! + MODULE PURE FUNCTION Zeros_16(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int16), INTENT(IN) :: datatype + INTEGER(Int16) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_16 +!! + MODULE PURE FUNCTION Zeros_17(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int32), INTENT(IN) :: datatype + INTEGER(Int32) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_17 +!! + MODULE PURE FUNCTION Zeros_18(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int64), INTENT(IN) :: datatype + INTEGER(Int64) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_18 + +#ifdef USE_Int128 + !! + MODULE PURE FUNCTION Zeros_19(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_19 +#endif +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_15, Zeros_16, Zeros_17, Zeros_18 +END INTERFACE Zeros + +#ifdef USE_Int128 +INTERFACE Zeros + MODULE PROCEDURE Zeros_19 +END INTERFACE Zeros +#endif + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_20(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + REAL(Real32), INTENT(IN) :: datatype + REAL(Real32) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_20 +!! + MODULE PURE FUNCTION Zeros_21(dim1, dim2, dim3, datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + REAL(Real64), INTENT(IN) :: datatype + REAL(Real64) :: ans(dim1, dim2, dim3) + END FUNCTION Zeros_21 +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_20, Zeros_21 +END INTERFACE Zeros + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_22(dim1, dim2, dim3, dim4,& + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int8), INTENT(IN) :: datatype + INTEGER(Int8) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_22 +!! + MODULE PURE FUNCTION Zeros_23(dim1, dim2, dim3, dim4,& + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int16), INTENT(IN) :: datatype + INTEGER(Int16) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_23 +!! + MODULE PURE FUNCTION Zeros_24(dim1, dim2, dim3, dim4,& + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int32), INTENT(IN) :: datatype + INTEGER(Int32) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_24 +!! + MODULE PURE FUNCTION Zeros_25(dim1, dim2, dim3, dim4,& + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int64), INTENT(IN) :: datatype + INTEGER(Int64) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_25 + +#ifdef USE_Int128 +!! + MODULE PURE FUNCTION Zeros_26(dim1, dim2, dim3, dim4, & + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + INTEGER(Int128), INTENT(IN) :: datatype + INTEGER(Int128) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_26 +#endif +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_22, Zeros_23, Zeros_24, Zeros_25 +END INTERFACE Zeros + +#ifdef USE_Int128 +INTERFACE Zeros + MODULE PROCEDURE Zeros_26 +END INTERFACE Zeros +#endif + +!---------------------------------------------------------------------------- +! Zeros@FunctionalFortran +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION Zeros_27(dim1, dim2, dim3, dim4, & + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + REAL(Real32), INTENT(IN) :: datatype + REAL(Real32) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_27 +!! + MODULE PURE FUNCTION Zeros_28(dim1, dim2, dim3, dim4, & + & datatype) RESULT(Ans) + INTEGER(I4B), INTENT(IN) :: dim1 + INTEGER(I4B), INTENT(IN) :: dim2 + INTEGER(I4B), INTENT(IN) :: dim3 + INTEGER(I4B), INTENT(IN) :: dim4 + REAL(Real64), INTENT(IN) :: datatype + REAL(Real64) :: ans(dim1, dim2, dim3, dim4) + END FUNCTION Zeros_28 +END INTERFACE + +INTERFACE Zeros + MODULE PROCEDURE Zeros_27, Zeros_28 +END INTERFACE Zeros + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ZerosUtility From bd508944242472e9af4ac40c6b1ad1ba1c0f0fae Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:46:55 +0900 Subject: [PATCH 38/43] undefined --- ...eferenceElement_Method@GeometryMethods.F90 | 9 +- .../src/ReferenceLine_Method@Methods.F90 | 89 ++++---- .../ReferenceQuadrangle_Method@Methods.F90 | 214 +++++++++--------- .../src/ReferenceTriangle_Method@Methods.F90 | 6 +- 4 files changed, 163 insertions(+), 155 deletions(-) diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 index ff83184f7..7268efc81 100644 --- a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 +++ b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 @@ -776,7 +776,8 @@ !! ans(ii)%xij = InterpolationPoint_Line( & & order=refelem%order, & - & ipType=refelem%interpolationPointType) + & ipType=refelem%interpolationPointType, & + & layout="VEFC") !! ans(ii)%Order = ElementOrder(ElemType=topo%Name) ans(ii)%NSD = refelem%nsd @@ -842,13 +843,15 @@ !! ans(ii)%xij = InterpolationPoint_Triangle( & & order=refelem%order, & - & ipType=refelem%interpolationPointType) + & ipType=refelem%interpolationPointType, & + & layout="VEFC") !! ELSE IF (isQuadrangle(topo%Name)) THEN !! ans(ii)%xij = InterpolationPoint_Quadrangle( & & order=refelem%order, & - & ipType=refelem%interpolationPointType) + & ipType=refelem%interpolationPointType, & + & layout="VEFC") !! END IF END DO diff --git a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 index dbc332956..35a68518f 100644 --- a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 @@ -17,7 +17,7 @@ !> author: Vikas Sharma, Ph. D. ! date: 2 March 2021 -! summary: This submodule contains methods for [[ReferenceLine_]] +! summary: This submodule contains methods for [[ReferenceLine_]] SUBMODULE(ReferenceLine_Method) Methods USE BaseMethod @@ -30,22 +30,23 @@ MODULE PROCEDURE initiate_ref_Line !! - CALL Reallocate( obj%xij, 3, 2 ) - obj%xij = InterpolationPoint_Line( xij=xij, order=1, ipType=Equidistance ) +CALL Reallocate(obj%xij, 3, 2) +obj%xij = InterpolationPoint_Line(xij=xij, order=1, ipType=Equidistance, & +& layout="VEFC") !! - obj%EntityCounts = [2, 1, 0, 0] - obj%XiDimension = 1 - obj%order = 1 - obj%nsd = nsd - obj%Name = Line2 +obj%EntityCounts = [2, 1, 0, 0] +obj%XiDimension = 1 +obj%order = 1 +obj%nsd = nsd +obj%Name = Line2 !! - IF( ALLOCATED( obj%Topology ) ) DEALLOCATE( obj%Topology ) - ALLOCATE( obj%Topology( 3 ) ) - obj%Topology( 1 ) = ReferenceTopology( [1], Point ) - obj%Topology( 2 ) = ReferenceTopology( [2], Point ) - obj%Topology( 3 ) = ReferenceTopology( [1, 2], Line2 ) +IF (ALLOCATED(obj%Topology)) DEALLOCATE (obj%Topology) +ALLOCATE (obj%Topology(3)) +obj%Topology(1) = ReferenceTopology([1], Point) +obj%Topology(2) = ReferenceTopology([2], Point) +obj%Topology(3) = ReferenceTopology([1, 2], Line2) !! - obj%highorderElement => highorderElement_Line +obj%highorderElement => highorderElement_Line !! END PROCEDURE initiate_ref_Line @@ -55,11 +56,11 @@ MODULE PROCEDURE reference_Line !! - IF( PRESENT( xij ) ) THEN - CALL Initiate( obj, nsd, xij ) - ELSE - CALL Initiate( obj, nsd ) - END IF +IF (PRESENT(xij)) THEN + CALL Initiate(obj, nsd, xij) +ELSE + CALL Initiate(obj, nsd) +END IF !! END PROCEDURE reference_Line @@ -69,13 +70,13 @@ MODULE PROCEDURE reference_Line_Pointer_1 !! - ALLOCATE( obj ) +ALLOCATE (obj) !! - IF( PRESENT( xij ) ) THEN - CALL Initiate( obj, nsd, xij ) - ELSE - CALL Initiate( obj, nsd ) - END IF +IF (PRESENT(xij)) THEN + CALL Initiate(obj, nsd, xij) +ELSE + CALL Initiate(obj, nsd) +END IF !! END PROCEDURE reference_Line_Pointer_1 @@ -87,23 +88,23 @@ !! !! Define internal variables !! - INTEGER( I4B ) :: nns, i +INTEGER(I4B) :: nns, i !! - obj%xij = InterpolationPoint_Line( xij = refelem%xij, order = order, & - & ipType=ipType ) - obj%nsd = refelem%nsd - nns = SIZE( obj%xij, 2 ) - obj%EntityCounts = [nns, 1, 0, 0] - obj%XiDimension = 1 - obj%order = order - obj%Name = ElementType( "Line" // TRIM( INT2STR( nns ) ) ) +obj%xij = InterpolationPoint_Line(xij=refelem%xij, order=order, & + & ipType=ipType, layout="VEFC") +obj%nsd = refelem%nsd +nns = SIZE(obj%xij, 2) +obj%EntityCounts = [nns, 1, 0, 0] +obj%XiDimension = 1 +obj%order = order +obj%Name = ElementType("Line"//TRIM(INT2STR(nns))) !! - ALLOCATE( obj%Topology( nns + 1 ) ) - DO CONCURRENT (i=1:nns) - obj%Topology( i ) = ReferenceTopology( [i], Point ) - END DO +ALLOCATE (obj%Topology(nns + 1)) +DO CONCURRENT(i=1:nns) + obj%Topology(i) = ReferenceTopology([i], Point) +END DO !! - obj%Topology( nns + 1 ) = ReferenceTopology( [(i, i=1,nns)], obj%Name ) +obj%Topology(nns + 1) = ReferenceTopology([(i, i=1, nns)], obj%Name) !! END PROCEDURE highorderElement_Line @@ -112,9 +113,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Measure_Simplex_Line - Ans = SQRT( ( xij( 1, 1 ) - xij( 1, 2 ) ) ** 2 & - & + ( xij( 2, 1 ) - xij( 2, 2 ) ) ** 2 & - & + ( xij( 3, 1 ) - xij( 3, 2 ) ) ** 2 ) +Ans = SQRT((xij(1, 1) - xij(1, 2))**2 & + & + (xij(2, 1) - xij(2, 2))**2 & + & + (xij(3, 1) - xij(3, 2))**2) END PROCEDURE Measure_Simplex_Line !---------------------------------------------------------------------------- @@ -122,7 +123,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Line_quality - ans = 0.0_DFP +ans = 0.0_DFP END PROCEDURE Line_quality -END SUBMODULE Methods \ No newline at end of file +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 index c01d34140..de8de0e77 100644 --- a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 @@ -30,31 +30,32 @@ MODULE PROCEDURE Initiate_ref_Quadrangle !! - CALL Reallocate( obj%xij, 3, 4 ) - !! - obj%xij = InterpolationPoint_Quadrangle( & - & xij=xij, & - & order=1, & - & ipType=Equidistance ) - !! - obj%EntityCounts = [4, 4, 1, 0] - obj%XiDimension = 2 - obj%Name = Quadrangle4 - obj%order = 1 - obj%NSD = NSD - !! - ALLOCATE( obj%Topology( 9 ) ) - obj%Topology( 1 ) = ReferenceTopology( [1], Point ) - obj%Topology( 2 ) = ReferenceTopology( [2], Point ) - obj%Topology( 3 ) = ReferenceTopology( [3], Point ) - obj%Topology( 4 ) = ReferenceTopology( [4], Point ) - obj%Topology( 5 ) = ReferenceTopology( [1, 2], Line2 ) - obj%Topology( 6 ) = ReferenceTopology( [2, 3], Line2 ) - obj%Topology( 7 ) = ReferenceTopology( [3, 4], Line2 ) - obj%Topology( 8 ) = ReferenceTopology( [4, 1], Line2 ) - obj%Topology( 9 ) = ReferenceTopology( [1, 2, 3, 4], Quadrangle4 ) - !! - obj%highorderElement => highorderElement_Quadrangle +CALL Reallocate(obj%xij, 3, 4) + !! +obj%xij = InterpolationPoint_Quadrangle( & + & xij=xij, & + & order=1, & + & ipType=Equidistance, & + & layout="VEFC") + !! +obj%EntityCounts = [4, 4, 1, 0] +obj%XiDimension = 2 +obj%Name = Quadrangle4 +obj%order = 1 +obj%NSD = NSD + !! +ALLOCATE (obj%Topology(9)) +obj%Topology(1) = ReferenceTopology([1], Point) +obj%Topology(2) = ReferenceTopology([2], Point) +obj%Topology(3) = ReferenceTopology([3], Point) +obj%Topology(4) = ReferenceTopology([4], Point) +obj%Topology(5) = ReferenceTopology([1, 2], Line2) +obj%Topology(6) = ReferenceTopology([2, 3], Line2) +obj%Topology(7) = ReferenceTopology([3, 4], Line2) +obj%Topology(8) = ReferenceTopology([4, 1], Line2) +obj%Topology(9) = ReferenceTopology([1, 2, 3, 4], Quadrangle4) + !! +obj%highorderElement => highorderElement_Quadrangle !! END PROCEDURE Initiate_ref_Quadrangle @@ -63,11 +64,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE reference_Quadrangle - IF( PRESENT( xij ) ) THEN - CALL Initiate( obj, NSD, xij ) - ELSE - CALL Initiate( obj, NSD ) - END IF +IF (PRESENT(xij)) THEN + CALL Initiate(obj, NSD, xij) +ELSE + CALL Initiate(obj, NSD) +END IF END PROCEDURE reference_Quadrangle !---------------------------------------------------------------------------- @@ -75,12 +76,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE reference_Quadrangle_Pointer - ALLOCATE( obj ) - IF( PRESENT( xij ) ) THEN - CALL Initiate( obj, NSD, xij ) - ELSE - CALL Initiate( obj, NSD ) - END IF +ALLOCATE (obj) +IF (PRESENT(xij)) THEN + CALL Initiate(obj, NSD, xij) +ELSE + CALL Initiate(obj, NSD) +END IF END PROCEDURE reference_Quadrangle_Pointer !---------------------------------------------------------------------------- @@ -88,68 +89,69 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE highorderElement_Quadrangle - INTEGER( I4B ) :: NNS, I +INTEGER(I4B) :: NNS, I !! - CALL Deallocate( obj ) +CALL Deallocate (obj) !! - SELECT CASE( order ) +SELECT CASE (order) !! - CASE( 1 ) +CASE (1) !! - CALL Initiate( obj=obj, Anotherobj=refelem ) + CALL Initiate(obj=obj, Anotherobj=refelem) !! - CASE( 2 ) +CASE (2) !! - obj%xij = InterpolationPoint_Quadrangle( xij=refelem%xij(1:3, 1:4), & - & order=order, ipType=ipType ) + obj%xij = InterpolationPoint_Quadrangle(xij=refelem%xij(1:3, 1:4), & + & order=order, ipType=ipType, & + & layout="VEFC") !! - NNS = 9 - obj%EntityCounts = [NNS, 4, 1, 0] - obj%XiDimension = 2 - obj%Name = Quadrangle9 - obj%order = order - obj%NSD = refelem%NSD + NNS = 9 + obj%EntityCounts = [NNS, 4, 1, 0] + obj%XiDimension = 2 + obj%Name = Quadrangle9 + obj%order = order + obj%NSD = refelem%NSD !! - ALLOCATE( obj%Topology( SUM( obj%EntityCounts) ) ) - DO I = 1, NNS - obj%Topology( I ) = ReferenceTopology( [I], Point ) - END DO - obj%Topology( NNS + 1 ) = ReferenceTopology( [1, 2, 5], Line3 ) - obj%Topology( NNS + 2 ) = ReferenceTopology( [2, 3, 6], Line3 ) - obj%Topology( NNS + 3 ) = ReferenceTopology( [3, 4, 7], Line3 ) - obj%Topology( NNS + 4 ) = ReferenceTopology( [4, 1, 8], Line3 ) - obj%Topology( NNS + 5 ) = ReferenceTopology( [1,2,3,4,5,6,7,8,9], & - & obj%Name ) - obj%highOrderElement => refelem%highOrderElement + ALLOCATE (obj%Topology(SUM(obj%EntityCounts))) + DO I = 1, NNS + obj%Topology(I) = ReferenceTopology([I], Point) + END DO + obj%Topology(NNS + 1) = ReferenceTopology([1, 2, 5], Line3) + obj%Topology(NNS + 2) = ReferenceTopology([2, 3, 6], Line3) + obj%Topology(NNS + 3) = ReferenceTopology([3, 4, 7], Line3) + obj%Topology(NNS + 4) = ReferenceTopology([4, 1, 8], Line3) + obj%Topology(NNS + 5) = ReferenceTopology([1, 2, 3, 4, 5, 6, 7, 8, 9], & + & obj%Name) + obj%highOrderElement => refelem%highOrderElement !! - CASE( 3 ) +CASE (3) !! - obj%xij = InterpolationPoint_Quadrangle( & - & xij=refelem%xij(1:3, 1:4), & - & order=order, & - & ipType=ipType ) + obj%xij = InterpolationPoint_Quadrangle( & + & xij=refelem%xij(1:3, 1:4), & + & order=order, & + & ipType=ipType, layout="VEFC") !! - NNS = 16 - obj%EntityCounts = [NNS, 4, 1, 0] - obj%XiDimension = 2 - obj%Name = Quadrangle16 - obj%order = order - obj%NSD = refelem%NSD + NNS = 16 + obj%EntityCounts = [NNS, 4, 1, 0] + obj%XiDimension = 2 + obj%Name = Quadrangle16 + obj%order = order + obj%NSD = refelem%NSD !! - ALLOCATE( obj%Topology( SUM( obj%EntityCounts) ) ) - DO I = 1, NNS - obj%Topology( I ) = ReferenceTopology( [I], Point ) - END DO + ALLOCATE (obj%Topology(SUM(obj%EntityCounts))) + DO I = 1, NNS + obj%Topology(I) = ReferenceTopology([I], Point) + END DO !! - obj%Topology( NNS + 1 ) = ReferenceTopology( [1, 2, 5, 6], Line4 ) - obj%Topology( NNS + 2 ) = ReferenceTopology( [2, 3, 7, 8], Line4 ) - obj%Topology( NNS + 3 ) = ReferenceTopology( [3, 4, 9, 10], Line4 ) - obj%Topology( NNS + 4 ) = ReferenceTopology( [4, 1, 11, 12], Line4 ) - obj%Topology( NNS + 5 ) = ReferenceTopology( arange(1,NNS,1), obj%Name) + obj%Topology(NNS + 1) = ReferenceTopology([1, 2, 5, 6], Line4) + obj%Topology(NNS + 2) = ReferenceTopology([2, 3, 7, 8], Line4) + obj%Topology(NNS + 3) = ReferenceTopology([3, 4, 9, 10], Line4) + obj%Topology(NNS + 4) = ReferenceTopology([4, 1, 11, 12], Line4) + obj%Topology(NNS + 5) = ReferenceTopology(arange(1, NNS, 1), obj%Name) !! - obj%highOrderElement => refelem%highOrderElement + obj%highOrderElement => refelem%highOrderElement !! - END SELECT +END SELECT !! END PROCEDURE highorderElement_Quadrangle @@ -158,11 +160,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Measure_Simplex_Quadrangle - IF( refelem%nsd .EQ. 2 ) THEN - CALL QUADAREA2D( xij( 1:2, 1:4 ), Ans ) - ELSE - CALL QUADAREA3D( xij( 1:3, 1:4 ), Ans ) - END IF +IF (refelem%nsd .EQ. 2) THEN + CALL QUADAREA2D(xij(1:2, 1:4), Ans) +ELSE + CALL QUADAREA3D(xij(1:3, 1:4), Ans) +END IF END PROCEDURE Measure_Simplex_Quadrangle !---------------------------------------------------------------------------- @@ -177,16 +179,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadArea3D - REAL( DFP ) :: p(3,4) +REAL(DFP) :: p(3, 4) !! !! Define a parallelogram by averaging consecutive vertices. - p(1:3,1:3) = ( q(1:3,1:3) + q(1:3,2:4) ) / 2.0_DFP - p(1:3, 4) = ( q(1:3, 4) + q(1:3,1 ) ) / 2.0_DFP +p(1:3, 1:3) = (q(1:3, 1:3) + q(1:3, 2:4)) / 2.0_DFP +p(1:3, 4) = (q(1:3, 4) + q(1:3, 1)) / 2.0_DFP !! !! Compute the area. - CALL PARALLELOGRAMAREA3D ( p, area ) +CALL PARALLELOGRAMAREA3D(p, area) !! The quadrilateral's area is twice that of the parallelogram. - area = 2.0_DFP * area +area = 2.0_DFP * area END PROCEDURE QuadArea3D !---------------------------------------------------------------------------- @@ -194,26 +196,26 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadArea2D - INTEGER( I4B ), PARAMETER :: dim_num = 2 +INTEGER(I4B), PARAMETER :: dim_num = 2 !! - REAL( DFP ) :: area_triangle - REAL( DFP ) :: t(dim_num,3) +REAL(DFP) :: area_triangle +REAL(DFP) :: t(dim_num, 3) !! - area = 0.0_DFP +area = 0.0_DFP !! - t(1:dim_num,1:3) = reshape ( (/ & - q(1:2,1), q(1:2,2), q(1:2,3) /), (/ dim_num, 3 /) ) +t(1:dim_num, 1:3) = reshape((/ & + q(1:2, 1), q(1:2, 2), q(1:2, 3)/), (/dim_num, 3/)) !! - CALL TRIANGLEAREA2D ( t, area_triangle ) +CALL TRIANGLEAREA2D(t, area_triangle) !! - area = area + area_triangle +area = area + area_triangle !! - t(1:dim_num,1:3) = RESHAPE ( (/ & - q(1:2,3), q(1:2,4), q(1:2,1) /), (/ dim_num, 3 /) ) +t(1:dim_num, 1:3) = RESHAPE((/ & + q(1:2, 3), q(1:2, 4), q(1:2, 1)/), (/dim_num, 3/)) !! - CALL TRIANGLEAREA2D ( t, area_triangle ) +CALL TRIANGLEAREA2D(t, area_triangle) !! - area = area + area_triangle +area = area + area_triangle !! END PROCEDURE QuadArea2D @@ -223,4 +225,4 @@ #include "./modified_burkardt.inc" -END SUBMODULE Methods \ No newline at end of file +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 index 49c351b29..1c37a8b48 100644 --- a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 @@ -35,7 +35,8 @@ obj%xij = InterpolationPoint_Triangle( & & xij=xij, & & order=1, & - & ipType=Equidistance) + & ipType=Equidistance, & + & layout="VEFC") !! obj%EntityCounts = [3, 3, 1, 0] obj%XiDimension = 2 @@ -98,7 +99,8 @@ obj%xij = InterpolationPoint_Triangle( & & xij=refelem%xij(1:3, 1:3), & & order=order, & - & ipType=ipType) + & ipType=ipType, & + & layout="VEFC") !! nsd = refelem%nsd obj%highOrderElement => refelem%highOrderElement From 293431ba24ebd303ef21f0c2fa02215339574eb3 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:47:02 +0900 Subject: [PATCH 39/43] undefined --- .../GE_Lapack_Method@CompRoutineMethods.F90 | 40 +++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 b/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 index e04f05e3a..9ef6ff814 100644 --- a/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 +++ b/src/submodules/Lapack/src/GE_Lapack_Method@CompRoutineMethods.F90 @@ -31,4 +31,44 @@ ans = 1.0_DFP / ans END PROCEDURE ge_ConditionNo_1 +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat1 +INTEGER(I4B) :: info, ipiv(SIZE(A, 1)) +invA = A +CALL getLU(A=invA, IPIV=ipiv, info=info) +CALL GETRI(A=invA, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat1 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat2 +INTEGER(I4B) :: info +invA = A +CALL GETRI(A=invA, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat2 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat3 +INTEGER(I4B) :: info +CALL GETRI(A=A, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat3 + +!---------------------------------------------------------------------------- +! GetInvMat +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ge_GetInvMat4 +INTEGER(I4B) :: info, ipiv(SIZE(A, 1)) +CALL getLU(A=A, IPIV=ipiv, info=info) +CALL GETRI(A=A, IPIV=ipiv, info=info) +END PROCEDURE ge_GetInvMat4 + END SUBMODULE CompRoutineMethods From db24be4a585a2d048605be370a879822e24e851b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:47:10 +0900 Subject: [PATCH 40/43] undefined --- src/submodules/Polynomial/CMakeLists.txt | 3 +- .../Chebyshev1PolynomialUtility@Methods.F90 | 1117 +++++++++++++++- ...HexahedronInterpolationUtility@Methods.F90 | 56 +- .../src/JacobiPolynomialUtility@Methods.F90 | 900 ++++++++++++- ... => LagrangePolynomialUtility@Methods.F90} | 140 +- .../src/LegendrePolynomialUtility@Methods.F90 | 582 +++++++- .../src/LineInterpolationUtility@Methods.F90 | 199 ++- .../OrthogonalPolynomialUtility@Methods.F90 | 117 +- .../src/PrismInterpolationUtility@Methods.F90 | 55 +- .../PyramidInterpolationUtility@Methods.F90 | 55 +- ...QuadrangleInterpolationUtility@Methods.F90 | 372 +++++- .../src/RecursiveNodesUtility@Methods.F90 | 36 +- ...etrahedronInterpolationUtility@Methods.F90 | 61 +- .../TriangleInterpolationUtility@Methods.F90 | 367 ++++- ...ltrasphericalPolynomialUtility@Methods.F90 | 1189 +++++++++++++++++ 15 files changed, 5045 insertions(+), 204 deletions(-) rename src/submodules/Polynomial/src/{LagrangeUtility@Methods.F90 => LagrangePolynomialUtility@Methods.F90} (60%) create mode 100644 src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index 61c2f3b47..98faf7041 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -26,8 +26,9 @@ TARGET_SOURCES( ${src_path}/PrismInterpolationUtility@Methods.F90 ${src_path}/PyramidInterpolationUtility@Methods.F90 ${src_path}/InterpolationUtility@Methods.F90 - ${src_path}/LagrangeUtility@Methods.F90 + ${src_path}/LagrangePolynomialUtility@Methods.F90 ${src_path}/JacobiPolynomialUtility@Methods.F90 + ${src_path}/UltrasphericalPolynomialUtility@Methods.F90 ${src_path}/LegendrePolynomialUtility@Methods.F90 ${src_path}/LobattoPolynomialUtility@Methods.F90 ${src_path}/UnscaledLobattoPolynomialUtility@Methods.F90 diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 index 0d47806ac..8c905ad17 100644 --- a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 @@ -20,106 +20,1131 @@ IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! Chebyshev1Alpha +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Alpha +ans = 0.0_DFP +END PROCEDURE Chebyshev1Alpha + +!---------------------------------------------------------------------------- +! Chebyshev1Beta +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Beta +SELECT CASE (n) +CASE (0_I4B) + ans = pi +CASE (1_I4B) + ans = 0.5_DFP +CASE DEFAULT + ans = 0.25_DFP +END SELECT +END PROCEDURE Chebyshev1Beta + !---------------------------------------------------------------------------- ! GetChebyshev1RecurrenceCoeff !---------------------------------------------------------------------------- MODULE PROCEDURE GetChebyshev1RecurrenceCoeff - IF( n .LE. 0 ) RETURN - alphaCoeff = 0.0_DFP - betaCoeff(0) = pi - IF( n .EQ. 1 ) RETURN - betaCoeff(1) = 0.5_DFP - IF( n .EQ. 2 ) RETURN - betaCoeff(2:) = 0.25_DFP +IF (n .LE. 0) RETURN +alphaCoeff = 0.0_DFP +betaCoeff(0) = pi +IF (n .EQ. 1) RETURN +betaCoeff(1) = 0.5_DFP +IF (n .EQ. 2) RETURN +betaCoeff(2:) = 0.25_DFP END PROCEDURE GetChebyshev1RecurrenceCoeff +!---------------------------------------------------------------------------- +! GetChebyshev1RecurrenceCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetChebyshev1RecurrenceCoeff2 +IF (n .LE. 0) RETURN +A = 2.0_DFP +B = 0.0_DFP +C = 1.0_DFP +END PROCEDURE GetChebyshev1RecurrenceCoeff2 + !---------------------------------------------------------------------------- ! Chebyshev1LeadingCoeff !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1LeadingCoeff - IF( n .EQ. 0_I4B ) THEN - ans = 1.0_DFP - ELSE - ans = 2.0_DFP ** (n-1_I4B) - END IF +IF (n .EQ. 0_I4B) THEN + ans = 1.0_DFP +ELSE + ans = 2.0_DFP**(n - 1_I4B) +END IF END PROCEDURE Chebyshev1LeadingCoeff +!---------------------------------------------------------------------------- +! Chebyshev1LeadingCoeffRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1LeadingCoeffRatio +IF (n .EQ. 0_I4B) THEN + ans = 1.0_DFP +ELSE + ans = 2.0_DFP +END IF +END PROCEDURE Chebyshev1LeadingCoeffRatio + !---------------------------------------------------------------------------- ! Chebyshev1NormSQR !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1NormSQR - IF( n .EQ. 0_I4B ) THEN - ans = pi - ELSE - ans = pi/2.0_DFP - END IF +IF (n .EQ. 0_I4B) THEN + ans = pi +ELSE + ans = pi / 2.0_DFP +END IF END PROCEDURE Chebyshev1NormSQR +!---------------------------------------------------------------------------- +! Chebyshev1NormSQR2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1NormSQR2 +ans(0) = pi +IF (n .EQ. 0) RETURN +ans(1:) = 0.5_DFP * pi +END PROCEDURE Chebyshev1NormSQR2 + +!---------------------------------------------------------------------------- +! Chebyshev1NormSQRRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1NormSQRRatio +ans = 1.0_DFP +END PROCEDURE Chebyshev1NormSQRRatio + +!---------------------------------------------------------------------------- +! Chebyshev1JacobiMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1JacobiMatrix +CALL JacobiJacobiMatrix(n=n, alpha=-0.5_DFP, beta=-0.5_DFP, & + & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE Chebyshev1JacobiMatrix + !---------------------------------------------------------------------------- ! Chebyshev1GaussQuadrature !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1GaussQuadrature - pt = Chebyshev1Zeros(n=n) - wt = pi/n +pt = Chebyshev1Zeros(n=n) +IF (PRESENT(wt)) wt = pi / n END PROCEDURE Chebyshev1GaussQuadrature +!---------------------------------------------------------------------------- +! Chebyshev1JacobiRadauMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1JacobiRadauMatrix +CALL JacobiJacobiRadauMatrix(a=a, n=n, alpha=-0.5_DFP, beta=-0.5_DFP, & + & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE Chebyshev1JacobiRadauMatrix + !---------------------------------------------------------------------------- ! Chebyshev1GaussRadauQuadrature !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1GaussRadauQuadrature - INTEGER( I4B ) :: ii - REAL( DFP ) :: avar, avar2 - !! - avar = 2.0_DFP * pi / (2.0_DFP * n + 1.0_DFP) - avar2 = pi / (2.0_DFP * n + 1.0_DFP) - !! +INTEGER(I4B) :: ii, c +REAL(DFP) :: avar, avar2 +!! +IF (a .LT. 0.0_DFP) THEN + c = 0_I4B +ELSE + c = 1_I4B +END IF +!! +avar = pi / (2.0_DFP * n + 1.0_DFP) +!! +avar2 = pi / (2.0_DFP * n + 1.0_DFP) +!! +IF (PRESENT(wt)) THEN DO ii = 0, n - pt( ii+1 ) = -COS( avar*ii ) - wt( ii+1 ) = avar2 + pt(ii + 1) = -COS(avar * (2 * ii + c)) + wt(ii + 1) = avar2 END DO - !! - wt( 1 ) = wt( 1 ) / 2.0_DFP - !! +!! + wt(1) = wt(1) / 2.0_DFP +ELSE + DO ii = 0, n + pt(ii + 1) = -COS(avar * (2 * ii + c)) + END DO +END IF +!! END PROCEDURE Chebyshev1GaussRadauQuadrature +!---------------------------------------------------------------------------- +! Chebyshev1JacobiLobattoMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1JacobiLobattoMatrix +CALL JacobiJacobiLobattoMatrix(n=n, alpha=-0.5_DFP, beta=-0.5_DFP, & + & D=D, E=E, alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE Chebyshev1JacobiLobattoMatrix + !---------------------------------------------------------------------------- ! Chebyshev1GaussLobattoQuadrature !---------------------------------------------------------------------------- MODULE PROCEDURE Chebyshev1GaussLobattoQuadrature - INTEGER( I4B ) :: ii - REAL( DFP ) :: avar +INTEGER(I4B) :: ii +REAL(DFP) :: avar +!! +avar = pi / (n + 1.0_DFP) +!! +IF (PRESENT(wt)) THEN + wt = avar + wt(1) = wt(1) / 2.0_DFP + wt(n + 2) = wt(n + 2) / 2.0_DFP +END IF +!! +DO ii = 0, n + 1 + pt(ii + 1) = -COS(avar * ii) +END DO +!! +END PROCEDURE Chebyshev1GaussLobattoQuadrature + +!---------------------------------------------------------------------------- +! Chebyshev1Zeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Zeros +INTEGER(I4B) :: ii +REAL(DFP) :: aval +aval = pi * 0.5_DFP / REAL(n, KIND=DFP) +DO ii = 1, n + ans(ii) = -COS((2.0_DFP * ii - 1.0_DFP) * aval) +END DO +END PROCEDURE Chebyshev1Zeros + +!---------------------------------------------------------------------------- +! Chebyshev1Quadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Quadrature +INTEGER(I4B) :: order +REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP +REAL(DFP), ALLOCATABLE :: p(:), w(:) +LOGICAL(LGT) :: inside +!! +IF (PRESENT(onlyInside)) THEN + inside = onlyInside +ELSE + inside = .FALSE. +END IF +!! +SELECT CASE (QuadType) +CASE (Gauss) + !! + order = n + CALL Chebyshev1GaussQuadrature(n=order, pt=pt, wt=wt) + !! +CASE (GaussRadau, GaussRadauLeft) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL Chebyshev1GaussRadauQuadrature(a=left, n=order, pt=p, wt=w) + pt = p(2:); wt = w(2:) + DEALLOCATE (p, w) + ELSE + order = n - 1 + CALL Chebyshev1GaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussRadauRight) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL Chebyshev1GaussRadauQuadrature(a=right, n=order, pt=p, wt=w) + pt = p(1:n); wt = w(1:n) + ELSE + order = n - 1 + CALL Chebyshev1GaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt) + END IF !! - avar = pi / (n + 1.0_DFP) +CASE (GaussLobatto) !! - DO ii = 0, n+1 - pt( ii+1 ) = -COS( avar*ii ) - wt( ii+1 ) = avar + IF (inside) THEN + order = n + ALLOCATE (p(n + 2), w(n + 2)) + CALL Chebyshev1GaussLobattoQuadrature(n=order, pt=p, wt=w) + pt = p(2:n + 1); wt = w(2:n + 1) + ELSE + order = n - 2 + CALL Chebyshev1GaussLobattoQuadrature(n=order, pt=pt, wt=wt) + END IF +END SELECT + !! +END PROCEDURE Chebyshev1Quadrature + +!---------------------------------------------------------------------------- +! Chebyshev1Eval1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Eval1 +INTEGER(I4B) :: i +REAL(DFP) :: ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = x +!! +DO i = 1, n - 1 + !! + ans_1 = ans + ans = (2.0_DFP * x) * ans - ans_2 + ans_2 = ans_1 + !! +END DO +END PROCEDURE Chebyshev1Eval1 + +!---------------------------------------------------------------------------- +! Chebyshev1Eval2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Eval2 +INTEGER(I4B) :: i +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = x +!! +DO i = 1, n - 1 + !! + ans_1 = ans + ans = (2.0_DFP * x) * ans - ans_2 + ans_2 = ans_1 + !! +END DO +END PROCEDURE Chebyshev1Eval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1EvalAll1 +INTEGER(I4B) :: i +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(2) = x +!! +DO i = 2, n + ans(i + 1) = (2.0_DFP * x) * ans(i) - ans(i - 1) +END DO +!! +END PROCEDURE Chebyshev1EvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1EvalAll2 +INTEGER(I4B) :: i +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(:, 1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(:, 2) = x +!! +DO i = 2, n + ans(:, i + 1) = (2.0_DFP * x) * ans(:, i) - ans(:, i - 1) +END DO +!! +END PROCEDURE Chebyshev1EvalAll2 + +!---------------------------------------------------------------------------- +! Chebyshev1MonomialExpansionAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1MonomialExpansionAll +INTEGER(I4B), PARAMETER :: rk = 1.0_DFP +INTEGER(I4B) :: ii +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 0.0_DFP +ans(1, 1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(2, 2) = 1.0_DFP +!! +DO ii = 2, n + !! + ! ans(ii + 1, 1) = -ans(ii - 1, 1) + ans(1, ii + 1) = -ans(1, ii - 1) + !! + ! ans(ii + 1, 2:ii - 1) = 2.0_DFP*ans(ii, 1:ii - 2) - ans(ii - 1, 2:ii - 1) + ans(2:ii - 1, ii + 1) = 2.0_DFP * ans(1:ii - 2, ii) - ans(2:ii - 1, ii - 1) + !! + ! ans(ii + 1, ii) = 2.0_DFP * ans(ii, ii - 1) + ans(ii, ii + 1) = 2.0_DFP * ans(ii - 1, ii) + !! + ! ans(ii + 1, ii + 1) = 2.0_DFP * ans(ii, ii) + ans(ii + 1, ii + 1) = 2.0_DFP * ans(ii, ii) + !! +END DO +!! +END PROCEDURE Chebyshev1MonomialExpansionAll + +!---------------------------------------------------------------------------- +! Chebyshev1MonomialExpansion +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1MonomialExpansion +REAL(DFP) :: coeff(n + 1, n + 1) +coeff = Chebyshev1MonomialExpansionAll(n) +ans = coeff(:, n + 1) +END PROCEDURE Chebyshev1MonomialExpansion + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalAll1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalAll1 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: p(1:n + 1), r_ii +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(1) = 1.0_DFP +ans(1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +IF (n .EQ. 0_I4B) RETURN +!! +p(2) = x +ans(2) = 1.0_DFP +!! +IF (n .EQ. 1_I4B) RETURN +!! +p(3) = 2.0_DFP * x**2 - 1.0_DFP +ans(3) = 4.0_DFP * x +!! +DO ii = 3, n + !! + r_ii = REAL(ii, KIND=DFP) + p(ii + 1) = (2.0_DFP * x) * p(ii) - p(ii - 1) + ans(ii + 1) = 2.0_DFP * r_ii * p(ii) & + & + r_ii * ans(ii - 1) / (r_ii - 2.0_DFP) + !! +END DO +!! +END PROCEDURE Chebyshev1GradientEvalAll1 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalAll2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalAll2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: p(1:SIZE(x), 1:n + 1), r_ii +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(:, 1) = 1.0_DFP +ans(:, 1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +IF (n .EQ. 0_I4B) RETURN +!! +p(:, 2) = x +ans(:, 2) = 1.0_DFP +!! +IF (n .EQ. 1_I4B) RETURN +!! +p(:, 3) = 2.0_DFP * x**2 - 1.0_DFP +ans(:, 3) = 4.0_DFP * x +!! +DO ii = 3, n + !! + r_ii = REAL(ii, KIND=DFP) + p(:, ii + 1) = (2.0_DFP * x) * p(:, ii) - p(:, ii - 1) + ans(:, ii + 1) = 2.0_DFP * r_ii * p(:, ii) & + & + r_ii * ans(:, ii - 1) / (r_ii - 2.0_DFP) + !! +END DO +!! +END PROCEDURE Chebyshev1GradientEvalAll2 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEval1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEval1 +! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii, p, p_1, p_2, ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +IF (n .EQ. 0_I4B) RETURN +!! +p = x +ans = 1.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n .EQ. 1_I4B) RETURN +!! +p = 2.0_DFP * x**2 - 1.0_DFP +ans = 4.0_DFP * x +!! +DO ii = 3, n + !! + r_ii = REAL(ii, KIND=DFP) + p_1 = p + p = (2.0_DFP * x) * p - p_2 + p_2 = p_1 + !! + ans_1 = ans + ans = 2.0_DFP * r_ii * p_1 & + & + r_ii * ans_2 / (r_ii - 2.0_DFP) + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE Chebyshev1GradientEval1 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEval2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEval2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2, ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +IF (n .EQ. 0_I4B) RETURN +!! +p = x +ans = 1.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n .EQ. 1_I4B) RETURN +!! +p = 2.0_DFP * x**2 - 1.0_DFP +ans = 4.0_DFP * x +!! +DO ii = 3, n + !! + r_ii = REAL(ii, KIND=DFP) + p_1 = p + p = (2.0_DFP * x) * p - p_2 + p_2 = p_1 + !! + ans_1 = ans + ans = 2.0_DFP * r_ii * p_1 & + & + r_ii * ans_2 / (r_ii - 2.0_DFP) + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE Chebyshev1GradientEval2 + +!---------------------------------------------------------------------------- +! Chebyshev1EvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1EvalSum1 +REAL(DFP) :: xx, t, b1, b2 +INTEGER(I4B) :: i +!! +IF (n .LT. 0) RETURN +b1 = 0.0_DFP +b2 = 0.0_DFP +xx = 2.0_DFP * x +!! +DO i = n, 1, -1 + t = xx * b1 - b2 + coeff(i) + b2 = b1 + b1 = t +END DO +ans = x * b1 - b2 + coeff(0) +END PROCEDURE Chebyshev1EvalSum1 + +!---------------------------------------------------------------------------- +! Chebyshev1EvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1EvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: xx, t, b1, b2 +INTEGER(I4B) :: i +!! +IF (n .LT. 0) RETURN +b1 = 0.0_DFP +b2 = 0.0_DFP +xx = 2.0_DFP * x +!! +DO i = n, 1, -1 + t = xx * b1 - b2 + coeff(i) + b2 = b1 + b1 = t +END DO +ans = x * b1 - b2 + coeff(0) +END PROCEDURE Chebyshev1EvalSum2 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalSum1 +REAL(DFP) :: xx, t, b1, b2 +INTEGER(I4B) :: i +IF (n .LT. 0) RETURN +b1 = 0.0_DFP +b2 = 0.0_DFP +xx = 2.0_DFP * x +!! +DO i = n - 1, 0, -1 + t = xx * b1 - b2 + (i + 1) * coeff(i + 1); + b2 = b1; + b1 = t; +END DO +!! +ans = b1 +END PROCEDURE Chebyshev1GradientEvalSum1 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: xx, t, b1, b2 +INTEGER(I4B) :: i +IF (n .LT. 0) RETURN +b1 = 0.0_DFP +b2 = 0.0_DFP +xx = 2.0_DFP * x +!! +DO i = n - 1, 0, -1 + t = xx * b1 - b2 + (i + 1) * coeff(i + 1); + b2 = b1; + b1 = t; +END DO +!! +ans = b1 +END PROCEDURE Chebyshev1GradientEvalSum2 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientEvalSum3 +REAL(DFP) :: s, t, b1, b2 +INTEGER(I4B) :: i +REAL(DFP) :: j +!! +IF (n .LT. 0) RETURN +!! +IF (k .EQ. 0) THEN + !! + ans = Chebyshev1EvalSum(coeff=coeff, n=n, x=x) + !! +ELSE + !! + b1 = 0.0_DFP + b2 = 0.0_DFP + s = 1.0_DFP + !! + DO i = k - 1, 1, -1 + s = 2.0_DFP * s * i END DO !! - wt( 1 ) = wt( 1 ) / 2.0_DFP - wt( n+2 ) = wt( n+2 ) / 2.0_DFP + DO i = n - k, 0, -1 + j = REAL(i, KIND=DFP) + t = 2 * (j + k) / (j + 1) * x * b1 - (j + 2 * k) & + & / (j + 2) * b2 + (j + k) * coeff(i + k); + b2 = b1; + b1 = t; + END DO !! -END PROCEDURE Chebyshev1GaussLobattoQuadrature + ans = s * b1 +END IF +END PROCEDURE Chebyshev1GradientEvalSum3 !---------------------------------------------------------------------------- -! Chebyshev1Zeros +! Chebyshev1GradientEvalSum !---------------------------------------------------------------------------- -MODULE PROCEDURE Chebyshev1Zeros - INTEGER( I4B ) :: ii - DO ii = 1, n - ans( ii ) = -COS( (2.0_DFP*ii-1.0_DFP)*pi*0.5_DFP/n ) +MODULE PROCEDURE Chebyshev1GradientEvalSum4 +REAL(DFP) :: s +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 +INTEGER(I4B) :: i +REAL(DFP) :: j +!! +IF (n .LT. 0) RETURN +!! +IF (k .EQ. 0) THEN + !! + ans = Chebyshev1EvalSum(coeff=coeff, n=n, x=x) + !! +ELSE + !! + b1 = 0.0_DFP + b2 = 0.0_DFP + s = 1.0_DFP + !! + DO i = k - 1, 1, -1 + s = 2.0_DFP * s * i END DO -END PROCEDURE Chebyshev1Zeros + !! + DO i = n - k, 0, -1 + j = REAL(i, KIND=DFP) + t = 2 * (j + k) / (j + 1) * x * b1 - (j + 2 * k) & + & / (j + 2) * b2 + (j + k) * coeff(i + k); + b2 = b1; + b1 = t; + END DO + !! + ans = s * b1 +END IF + +END PROCEDURE Chebyshev1GradientEvalSum4 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform1 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj +REAL(DFP) :: rn +!! +nrmsqr = Chebyshev1NormSQR2(n=n) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = pi +END IF +!! +PP = Chebyshev1EvalAll(n=n, x=x) +!! +DO jj = 0, n + temp = PP(:, jj) * w * coeff + ans(jj) = SUM(temp) / nrmsqr(jj) +END DO +!! +END PROCEDURE Chebyshev1Transform1 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform2 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj, kk +REAL(DFP) :: rn +!! +nrmsqr = Chebyshev1NormSQR2(n=n) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = pi +END IF +!! +PP = Chebyshev1EvalAll(n=n, x=x) +!! +DO kk = 1, SIZE(coeff, 2) + DO jj = 0, n + temp = PP(:, jj) * w * coeff(:, kk) + ans(jj, kk) = SUM(temp) / nrmsqr(jj) + END DO +END DO +!! +END PROCEDURE Chebyshev1Transform2 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform3 +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: ii +!! +CALL Chebyshev1Quadrature(n=n + 1, pt=pt, wt=wt,& + & quadType=quadType) +!! +DO ii = 0, n + coeff(ii) = f(pt(ii)) +END DO +!! +ans = Chebyshev1Transform(n=n, coeff=coeff, x=pt, & + & w=wt, quadType=quadType) +!! +END PROCEDURE Chebyshev1Transform3 + +!---------------------------------------------------------------------------- +! Chebyshev1Transform4 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1Transform4 +INTEGER(I4B) :: ii, jj +REAL(DFP) :: avar +!! +ans = 0.0_DFP +!! +IF (quadType .EQ. GaussLobatto) THEN + !! + DO jj = 0, n + !! + ans(jj) = coeff(0) * 0.5_DFP + coeff(n) * 0.5_DFP * (-1.0)**jj + !! + DO ii = 1, n - 1 + ans(jj) = ans(jj) + coeff(ii) * COS(jj * pi * ii / n) + END DO + !! + ans(jj) = ans(jj) * 2.0_DFP / n + !! + END DO + !! + ans(0) = ans(0) * 0.5_DFP + ans(n) = ans(n) * 0.5_DFP + !! +ELSE + !! + DO jj = 0, n + !! + avar = jj * pi * 0.5_DFP / (n + 1.0_DFP) + !! + DO ii = 0, n + ans(jj) = ans(jj) + coeff(ii) * COS((2.0 * ii + 1.0) * avar) + END DO + !! + ans(jj) = ans(jj) * 2.0_DFP / (n + 1.0) + !! + END DO + !! + ans(0) = ans(0) * 0.5_DFP + !! +END IF +!! +END PROCEDURE Chebyshev1Transform4 + +!---------------------------------------------------------------------------- +! Chebyshev1InvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1InvTransform1 +ans = Chebyshev1EvalSum(n=n, coeff=coeff, x=x) +END PROCEDURE Chebyshev1InvTransform1 + +!---------------------------------------------------------------------------- +! Chebyshev1InvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1InvTransform2 +ans = Chebyshev1EvalSum(n=n, coeff=coeff, x=x) +END PROCEDURE Chebyshev1InvTransform2 + +!---------------------------------------------------------------------------- +! Chebyshev1GradientCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1GradientCoeff1 +REAL(DFP) :: a, b, c +INTEGER(I4B) :: ii +REAL(DFP) :: jj +!! +ans(n) = 0.0_DFP +IF (n .EQ. 0) RETURN +!! +IF (n .EQ. 1) THEN + c = 2.0_DFP +ELSE + c = 1.0_DFP +END IF +!! +ans(n - 1) = 2.0_DFP * n * coeff(n) / c +!! +DO ii = n - 1, 1, -1 + jj = REAL(ii, KIND=DFP) + ans(ii - 1) = 2.0_DFP * jj * coeff(ii) + ans(ii + 1) +END DO +!! +ans(0) = 0.5_DFP * ans(0) +!! +END PROCEDURE Chebyshev1GradientCoeff1 + +!---------------------------------------------------------------------------- +! Chebyshev1DMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1DMatrix1 +SELECT CASE (quadType) +CASE (GaussLobatto) + CALL Chebyshev1DMatrixGL2(n=n, x=x, D=ans) +CASE (Gauss) + CALL Chebyshev1DMatrixG2(n=n, x=x, D=ans) +END SELECT +END PROCEDURE Chebyshev1DMatrix1 + +!---------------------------------------------------------------------------- +! Chebyshev1DMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE Chebyshev1DMatrixGL2(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: rn, j1, j2 + INTEGER(I4B) :: ii, jj, nb2 + !! + nb2 = int(n / 2) + rn = REAL(n, KIND=DFP) + !! + D = 0.0_DFP + !! + DO jj = 0, n + DO ii = 0, nb2 + j1 = SIN(0.5 * (ii + jj) * pi / rn) + j2 = SIN(0.5 * (ii - jj) * pi / rn) + IF (ii .NE. jj) & + & D(ii, jj) = 0.5 * (-1)**(ii + jj) / j1 / j2 + END DO + END DO + !! + D(0, :) = D(0, :) * 2.0_DFP + D(:, 0) = D(:, 0) * 0.5_DFP + D(:, n) = D(:, n) * 0.5_DFP + !! + !! correct diagonal entries + !! + D(0, 0) = -(2.0_DFP * rn**2 + 1.0_DFP) / 6.0_DFP + !! + DO ii = 1, nb2 + D(ii, ii) = -x(ii) * 0.5_DFP / (SIN(pi * ii / rn))**2 + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE Chebyshev1DMatrixGL2 + +!---------------------------------------------------------------------------- +! Chebyshev1DMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE Chebyshev1DMatrixG(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! internal variables + !! + REAL(DFP) :: rn, j3, j4 + INTEGER(I4B) :: ii, jj, nb2 + !! + !! main + !! + rn = REAL(n, KIND=DFP) + nb2 = int(n / 2) + D = 0.0_DFP + !! + DO jj = 0, n + j4 = (rn + 1.0) * SIN((2.0 * jj + 1) * 0.5 * pi) & + & / SIN((2.0 * jj + 1) * 0.5 * pi / (rn + 1.0)) + DO ii = 0, nb2 + j3 = (rn + 1.0) * SIN((2.0 * ii + 1) * 0.5 * pi) & + & / SIN((2.0 * ii + 1) * 0.5 * pi / (rn + 1.0)) + IF (ii .NE. jj) & + & D(ii, jj) = j3 / j4 / (x(ii) - x(jj)) + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = x(ii) * 0.5_DFP / (1.0_DFP - x(ii)**2) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE Chebyshev1DMatrixG + +!---------------------------------------------------------------------------- +! Chebyshev1DMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE Chebyshev1DMatrixG2(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! internal variables + !! + REAL(DFP) :: rn + REAL(DFP) :: J(0:n) + INTEGER(I4B) :: ii, jj, nb2 + !! + !! main + !! + rn = REAL(n, KIND=DFP) + nb2 = int(n / 2) + D = 0.0_DFP + !! + J = Chebyshev1GradientEval(n=n + 1, x=x) + !! + DO jj = 0, n + DO ii = 0, nb2 + IF (ii .NE. jj) & + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = x(ii) * 0.5_DFP / (1.0_DFP - x(ii)**2) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE Chebyshev1DMatrixG2 + +!---------------------------------------------------------------------------- +! Chebyshev1DMatEvenOdd +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Chebyshev1DMatEvenOdd1 +CALL UltrasphericalDMatEvenOdd(n=n, D=D, o=o, e=e) +END PROCEDURE Chebyshev1DMatEvenOdd1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -END SUBMODULE Methods \ No newline at end of file +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 index 97ec9158a..8417d1b3a 100644 --- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 @@ -16,6 +16,7 @@ ! SUBMODULE(HexahedronInterpolationUtility) Methods +USE BaseMethod IMPLICIT NONE CONTAINS @@ -81,11 +82,62 @@ CASE (Equidistance) nodecoord = EquidistancePoint_Hexahedron(xij=xij, order=order) CASE (GaussLegendre) -CASE (GaussLobatto) -CASE (Chebyshev) +CASE (GaussLegendreLobatto) +CASE (GaussChebyshev) +CASE (GaussChebyshevLobatto) END SELECT END PROCEDURE InterpolationPoint_Hexahedron +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +!! +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Hexahedron) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +!! +END PROCEDURE LagrangeCoeff_Hexahedron1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron2 +!! +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +!! +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Hexahedron2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Hexahedron3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Hexahedron4 +ans = LagrangeVandermonde(order=order, xij=xij, elemType=Hexahedron) +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Hexahedron4 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 index f24470fb2..676683b43 100644 --- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 @@ -20,6 +20,38 @@ IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! JacobiAlpha +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiAlpha +IF (n .EQ. 0) THEN + ans = (beta - alpha) / (alpha + beta + 2.0_DFP) +ELSE + ans = (beta**2 - alpha**2) / (alpha + beta + 2.0_DFP * n) & + & / (alpha + beta + 2.0_DFP + 2.0_DFP * n) +END IF +END PROCEDURE JacobiAlpha + +!---------------------------------------------------------------------------- +! JacobiBeta +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiBeta +IF (n .EQ. 0) THEN + ans = 2.0_DFP**(alpha + beta + 1.0_DFP) * GAMMA(alpha + 1.0_DFP) & + & * GAMMA(beta + 1.0_DFP) & + & / GAMMA(alpha + beta + 2.0_DFP) +ELSEIF (n .EQ. 1) THEN + ans = 4.0_DFP * (1.0_DFP + alpha) * (1.0_DFP + beta) / & + & (alpha + beta + 2.0_DFP)**2 / (alpha + beta + 3.0_DFP) +ELSE + ans = 4.0_DFP * n * (n + alpha) * (n + beta) * (n + alpha + beta) & + & / (alpha + beta + 2.0_DFP * n)**2 / (alpha + beta + 1.0_DFP + 2.0 * n) & + & / (alpha + beta - 1.0_DFP + 2.0 * n) +END IF +END PROCEDURE JacobiBeta + !---------------------------------------------------------------------------- ! GetJacobiRecurrenceCoeff !---------------------------------------------------------------------------- @@ -70,6 +102,33 @@ !! END PROCEDURE GetJacobiRecurrenceCoeff +!---------------------------------------------------------------------------- +! GetJacobiRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetJacobiRecurrenceCoeff2 +REAL(DFP) :: j +INTEGER(I4B) :: ii +!! +IF (n .LT. 1) RETURN +A(0) = 0.5_DFP * (alpha + beta + 2.0_DFP) +B(0) = -A(0) * JacobiAlpha(n=0_I4B, alpha=alpha, beta=beta) +j = JacobiBeta(n=0_I4B, alpha=alpha, beta=beta) +C(0) = SQRT(j) * A(0) +!! +IF (n .EQ. 1) RETURN +!! +DO ii = 2, n + j = REAL(ii, KIND=DFP) + A(ii-1) = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + B(ii - 1) = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + C(ii - 1) = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); +END DO +!! +END PROCEDURE GetJacobiRecurrenceCoeff2 + !---------------------------------------------------------------------------- ! JacobiLeadingCoeff !---------------------------------------------------------------------------- @@ -79,6 +138,21 @@ & GAMMA(n + alpha + beta + 1.0_DFP) / 2.0_DFP**n END PROCEDURE JacobiLeadingCoeff +!---------------------------------------------------------------------------- +! JacobiLeadingCoeffRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiLeadingCoeffRatio +REAL(DFP) :: a1, a2, rn +IF (n .EQ. 0) THEN + ans = 0.5_DFP * (alpha + beta + 2.0_DFP) +ELSE + rn = REAL(n, KIND=DFP) + a1 = 2.0_DFP * rn + alpha + beta + 1.0_DFP + ans = 0.5_DFP * a1 * (a1 + 1.0_DFP) / (rn + 1.0_DFP) / (a1 - rn) +END IF +END PROCEDURE JacobiLeadingCoeffRatio + !---------------------------------------------------------------------------- ! JacobiNormSqr !---------------------------------------------------------------------------- @@ -94,6 +168,48 @@ ans = a1 * a2 * a3 / b1 / b2 / b3 END PROCEDURE JacobiNormSqr +!---------------------------------------------------------------------------- +! JacobiNormSqr2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiNormSqr2 +REAL(DFP) :: rn, s +INTEGER(I4B) :: ii +!! +ans(0) = JacobiNormSQR(n=0_I4B, alpha=alpha, beta=beta) +!! +IF (n .EQ. 0) RETURN +!! +s = JacobiNormSQRRatio(n=0_I4B, alpha=alpha, beta=beta) +ans(1) = ans(0) * s +!! +DO ii = 1, n - 1 + rn = REAL(ii, KIND=DFP) + s = (rn + alpha + 1.0_DFP) * (rn + beta + 1.0_DFP) * & + & (2.0_DFP * rn + alpha + beta + 1.0_DFP) / (rn + 1.0_DFP) & + & / (2.0_DFP * rn + alpha + beta + 3.0_DFP) & + & / (rn + alpha + beta + 1.0_DFP) + ans(ii + 1) = s * ans(ii) +END DO +END PROCEDURE JacobiNormSqr2 + +!---------------------------------------------------------------------------- +! JacobiNormSqrRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiNormSqrRatio +REAL(DFP) :: rn +IF (n .EQ. 0) THEN + ans = (1.0_DFP + alpha) * (1.0_DFP + beta) / (3.0_DFP + alpha + beta) +ELSE + rn = REAL(n, KIND=DFP) + ans = (rn + alpha + 1.0_DFP) * (rn + beta + 1.0_DFP) * & + & (2.0_DFP * rn + alpha + beta + 1.0_DFP) / (rn + 1.0_DFP) & + & / (2.0_DFP * rn + alpha + beta + 3.0_DFP) & + & / (rn + alpha + beta + 1.0_DFP) +END IF +END PROCEDURE JacobiNormSqrRatio + !---------------------------------------------------------------------------- ! JacobiJacobiMatrix !---------------------------------------------------------------------------- @@ -117,17 +233,22 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiGaussQuadrature -REAL(DFP) :: beta0, Z(n, n), betaCoeff(0:n - 1) +REAL(DFP) :: beta0, Z(n, n), betaCoeff(0:n - 1), pn(n) INTEGER(I4B) :: ii !! CALL JacobiJacobiMatrix(n=n, alpha=alpha, beta=beta, D=pt, & - & E=wt, betaCoeff=betaCoeff) + & E=pn, betaCoeff=betaCoeff) !! #ifdef USE_LAPACK95 -CALL STEV(D=pt, E=wt, Z=Z) -DO ii = 1, n - wt(ii) = betaCoeff(0) * Z(1, ii)**2 -END DO +IF (PRESENT(wt)) THEN + wt = pn + CALL STEV(D=pt, E=wt, Z=Z) + DO ii = 1, n + wt(ii) = betaCoeff(0) * Z(1, ii)**2 + END DO +ELSE + CALL STEV(D=pt, E=pn) +END IF !! #else CALL ErrorMsg( & @@ -177,18 +298,23 @@ MODULE PROCEDURE JacobiGaussRadauQuadrature !! -REAL(DFP) :: beta0, Z(n + 1, n + 1), betaCoeff(0:n) +REAL(DFP) :: beta0, Z(n + 1, n + 1), betaCoeff(0:n), pn(n + 1) INTEGER(I4B) :: ii !! CALL JacobiJacobiRadauMatrix(a=a, n=n, alpha=alpha, beta=beta, D=pt, & - & E=wt, betaCoeff=betaCoeff) + & E=pn, betaCoeff=betaCoeff) !! #ifdef USE_LAPACK95 !! -CALL STEV(D=pt, E=wt, Z=Z) -DO ii = 1, n + 1 - wt(ii) = betaCoeff(0) * Z(1, ii)**2 -END DO +IF (PRESENT(wt)) THEN + wt = pn + CALL STEV(D=pt, E=wt, Z=Z) + DO ii = 1, n + 1 + wt(ii) = betaCoeff(0) * Z(1, ii)**2 + END DO +ELSE + CALL STEV(D=pt, E=pn) +END IF !! #else CALL ErrorMsg( & @@ -209,7 +335,7 @@ !! REAL(DFP) :: avar, r1, r2, r3, ab !! -IF (n .LT. 1) RETURN +IF (n .LT. 0) RETURN !! CALL JacobiJacobiMatrix( & & n=n + 1, & @@ -241,17 +367,22 @@ MODULE PROCEDURE JacobiGaussLobattoQuadrature !! -REAL(DFP) :: beta0, Z(n + 2, n + 2), betaCoeff(0:n + 1) +REAL(DFP) :: beta0, Z(n + 2, n + 2), betaCoeff(0:n + 1), pn(n + 2) INTEGER(I4B) :: ii !! CALL JacobiJacobiLobattoMatrix(n=n, alpha=alpha, beta=beta, D=pt, & - & E=wt, betaCoeff=betaCoeff) - !! + & E=pn, betaCoeff=betaCoeff) +!! #ifdef USE_LAPACK95 -CALL STEV(D=pt, E=wt, Z=Z) -DO ii = 1, n + 2 - wt(ii) = betaCoeff(0) * Z(1, ii)**2 -END DO +IF (PRESENT(wt)) THEN + wt = pn + CALL STEV(D=pt, E=wt, Z=Z) + DO ii = 1, n + 2 + wt(ii) = betaCoeff(0) * Z(1, ii)**2 + END DO +ELSE + CALL STEV(D=pt, E=pn) +END IF !! #else CALL ErrorMsg( & @@ -304,7 +435,7 @@ INTEGER(I4B) :: order REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP !! -SELECT CASE (QuadType) +SELECT CASE (quadType) CASE (Gauss) order = n CALL JacobiGaussQuadrature(n=order, alpha=alpha, beta=beta, & @@ -554,4 +685,731 @@ END DO END PROCEDURE JacobiEval2 +!---------------------------------------------------------------------------- +! JacobiEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEvalSum1 +REAL(DFP) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP), DIMENSION(0:n + 1) :: A, B, C +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +CALL GetJacobiRecurrenceCoeff2(n=n + 2, alpha=alpha, beta=beta, A=A, B=B, C=C) +!! +b1 = 0.0_DFP +b2 = 0.0_DFP +!! +DO j = n, 0, -1 + t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j); + b2 = b1 + b1 = t +END DO +!! +ans = b1 +!! +END PROCEDURE JacobiEvalSum1 + +!---------------------------------------------------------------------------- +! JacobiEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiEvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP), DIMENSION(0:n + 1) :: A, B, C +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +CALL GetJacobiRecurrenceCoeff2(n=n + 2, alpha=alpha, beta=beta, A=A, B=B, C=C) +!! +b1 = 0.0_DFP +b2 = 0.0_DFP +!! +DO j = n, 0, -1 + t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j); + b2 = b1 + b1 = t +END DO +!! +ans = b1 +!! +END PROCEDURE JacobiEvalSum2 + +!---------------------------------------------------------------------------- +! JacobiGradientEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEval1 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: j +REAL(DFP) :: p, p_1, p_2 +REAL(DFP) :: ans_1, ans_2 +REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +!! +ab = alpha + beta +amb = alpha - beta +p = 0.5 * (ab + 2.0) * x + 0.5 * amb +ans = 0.5 * (ab + 2.0) +!! +DO ii = 2, n + !! + j = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + !! + p = (a1 * x + a2) * p - a3 * p_2 + !! + p_2 = p_1 + !! + ans_1 = ans + !! + j = j - 1.0 + b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) + b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) + b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) + !! + ans = (p_1 - b1 * ans_2 - b2 * ans_1) / b3 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE JacobiGradientEval1 + +!---------------------------------------------------------------------------- +! JacobiGradientEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEval2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: j +REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2, ans_1, ans_2 +REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +!! +ab = alpha + beta +amb = alpha - beta +p = 0.5 * (ab + 2.0) * x + 0.5 * amb +ans = 0.5 * (ab + 2.0) +!! +DO ii = 2, n + !! + j = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + !! + p = (a1 * x + a2) * p - a3 * p_2 + !! + p_2 = p_1 + !! + ans_1 = ans + !! + j = j - 1.0 + b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) + b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) + b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) + !! + ans = (p_1 - b1 * ans_2 - b2 * ans_1) / b3 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE JacobiGradientEval2 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalAll1 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: j +REAL(DFP), DIMENSION(n + 1) :: p +REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(1) = 1.0_DFP +ans(1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +!! +ab = alpha + beta +amb = alpha - beta +p(2) = 0.5 * (ab + 2.0) * x + 0.5 * amb +ans(2) = 0.5 * (ab + 2.0) +!! +DO ii = 2, n + !! + j = REAL(ii, KIND=DFP) + !! + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + !! + p(ii + 1) = (a1 * x + a2) * p(ii) - a3 * p(ii - 1) + !! + j = j - 1.0 + b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) + b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) + b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) + !! + ans(ii + 1) = (p(ii) - b1 * ans(ii - 1) - b2 * ans(ii)) / b3 + !! +END DO +!! +END PROCEDURE JacobiGradientEvalAll1 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalAll2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: j +REAL(DFP), DIMENSION(SIZE(x), n + 1) :: p +REAL(DFP) :: ab, amb, a1, a2, a3, b1, b2, b3 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(:, 1) = 1.0_DFP +ans(:, 1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +ab = alpha + beta +amb = alpha - beta +p(:, 2) = 0.5 * (ab + 2.0) * x + 0.5 * amb +ans(:, 2) = 0.5 * (ab + 2.0) +!! +DO ii = 2, n + !! + j = REAL(ii, KIND=DFP) + !! + a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta)); + a2 = (alpha * alpha - beta * beta) * (2 * j + alpha + beta - 1) & + & / (2 * j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + a3 = (j - 1 + alpha) * (j - 1 + beta) * (2 * j + alpha + beta) & + & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2)); + !! + p(:, ii + 1) = (a1 * x + a2) * p(:, ii) - a3 * p(:, ii - 1) + !! + j = j - 1.0 + b1 = -2.0*(j+alpha)*(j+beta)/(j+ab)/(2.0*j+ab)/(2.0*j+ab+1.0) + b2 = 2.0 * amb / (2.0 * j + ab) / (2.0 * j + ab + 2.0) + b3 = 2.0 * (j + ab + 1.0) / (2.0 * j + ab + 1.0) / (2.0 * j + ab + 2.0) + !! + ans(:, ii + 1) = (p(:, ii) - b1 * ans(:, ii - 1) - b2 * ans(:, ii)) / b3 + !! +END DO +!! +END PROCEDURE JacobiGradientEvalAll2 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalSum1 +REAL(DFP) :: t, b1, b2, Ac, A1, A2, a10, a11, a12, a20, a21, j +REAL(DFP), PARAMETER :: c = 0.5_DFP +INTEGER(I4B) :: i +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +b1 = 0 +b2 = 0 +!! +DO i = n - 1, 0, -1 + j = REAL(i, KIND=DFP) + !! + !! Recurrence coeff + !! + Ac = j + 2 + alpha + beta; + a10 = (2 * j + 3 + alpha + beta) / ((2 * j + 2) * (j + 3 + alpha + beta)); + a11 = (2 * j + 4 + alpha + beta) * x; + a12 = ((alpha - beta) * (alpha + beta + 2)) / (alpha + beta + 2 * j + 2); + A1 = a10 * (a11 + a12); + a20 = -(j + 2 + alpha) * (j + 2 + beta) & + & / ((j + 2) * (alpha + beta + j + 4)); + a21 = (alpha + beta + 2 * j + 6) / (alpha + beta + 2 * j + 4); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + Ac * coeff(i + 1); + b2 = b1; + b1 = t; +END DO + +ans = c * b1 + +END PROCEDURE JacobiGradientEvalSum1 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalSum2 +REAL(DFP) :: Ac, A2, a10, a12, a20, a21, j +REAL(DFP), DIMENSION(SIZE(x)) :: a11, A1, t, b1, b2 +REAL(DFP), PARAMETER :: c = 0.5_DFP +INTEGER(I4B) :: i +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +b1 = 0 +b2 = 0 +!! +DO i = n - 1, 0, -1 + j = REAL(i, KIND=DFP) + !! + !! Recurrence coeff + !! + Ac = j + 2 + alpha + beta; + a10 = (2 * j + 3 + alpha + beta) / ((2 * j + 2) * (j + 3 + alpha + beta)); + a11 = (2 * j + 4 + alpha + beta) * x; + a12 = ((alpha - beta) * (alpha + beta + 2)) / (alpha + beta + 2 * j + 2); + A1 = a10 * (a11 + a12); + a20 = -(j + 2 + alpha) * (j + 2 + beta) & + & / ((j + 2) * (alpha + beta + j + 4)); + a21 = (alpha + beta + 2 * j + 6) / (alpha + beta + 2 * j + 4); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + Ac * coeff(i + 1); + b2 = b1; + b1 = t; +END DO + +ans = c * b1 +END PROCEDURE JacobiGradientEvalSum2 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalSum3 +REAL(DFP) :: t, b1, b2, Ac, A1, A2, a10, a11, a12, a20, a21, c, s +INTEGER(I4B) :: i, j +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +b1 = 0 +b2 = 0 +c = 1.0_DFP +!! +DO i = k, 1, -1 + c = c / 2.0_DFP +END DO +!! +DO i = n - k, 0, -1 + !! + s = 1.0_DFP + !! + DO j = 1, k + s = s * (alpha + beta + i + k + j) + END DO + !! + a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); + a11 = (2 * i + 2 + 2 * k + alpha + beta) * x; + a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); + A1 = a10 * (a11 + a12); + a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); + a21 = (alpha + beta + 2 * i + 4 + 2 * k) & + & / (alpha + beta + 2 * i + 2 + 2 * k); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + s * coeff(i + k); + b2 = b1; + b1 = t; +END DO + +ans = c * b1 + +END PROCEDURE JacobiGradientEvalSum3 + +!---------------------------------------------------------------------------- +! JacobiGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientEvalSum4 +REAL(DFP) :: Ac, A2, a10, a12, a20, a21, c, s +REAL(DFP), DIMENSION(SIZE(x)) :: a11, A1, t, b1, b2 +INTEGER(I4B) :: i, j +!! +IF (n .LT. 0) RETURN +IF (alpha .LE. -1.0_DFP) RETURN +IF (beta .LE. -1.0_DFP) RETURN +!! +b1 = 0 +b2 = 0 +c = 1.0_DFP +!! +DO i = k, 1, -1 + c = c / 2.0_DFP +END DO +!! +DO i = n - k, 0, -1 + !! + s = 1.0_DFP + !! + DO j = 1, k + s = s * (alpha + beta + i + k + j) + END DO + !! + a10=(2*i+1+2*k+alpha+beta)/((2*i+2)*(i+1+2*k+alpha+beta)); + a11 = (2 * i + 2 + 2 * k + alpha + beta) * x; + a12=((alpha-beta)*(alpha+beta+2*k))/(alpha+beta+2*i+2*k); + A1 = a10 * (a11 + a12); + a20=-(i+1+k+alpha)*(i+1+k+beta)/((i+2)*(alpha+beta+i+2+2*k)); + a21 = (alpha + beta + 2 * i + 4 + 2 * k) & + & / (alpha + beta + 2 * i + 2 + 2 * k); + A2 = a20 * a21; + t = A1 * b1 + A2 * b2 + s * coeff(i + k); + b2 = b1; + b1 = t; +END DO + +ans = c * b1 + +END PROCEDURE JacobiGradientEvalSum4 + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform1 +REAL(DFP), DIMENSION(0:n) :: Gamma, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj +!! +Gamma = JacobiNormSQR2(n=n, alpha=alpha, beta=beta) +!! +!! Correct Gamma(n) +!! +IF (quadType .EQ. GaussLobatto) THEN + Gamma(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & + & * Gamma(n) +END IF +!! +PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) +!! +DO jj = 0, n + temp = PP(:, jj) * w * coeff + ans(jj) = SUM(temp) / Gamma(jj) +END DO +!! +END PROCEDURE JacobiTransform1 + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform2 +REAL(DFP), DIMENSION(0:n) :: Gamma, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj, kk +!! +Gamma = JacobiNormSQR2(n=n, alpha=alpha, beta=beta) +!! +!! Correct Gamma(n) +!! +IF (quadType .EQ. GaussLobatto) THEN + Gamma(n) = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) & + & * Gamma(n) +END IF +!! +PP = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) +!! +DO kk = 1, SIZE(coeff, 2) + DO jj = 0, n + temp = PP(:, jj) * w * coeff(:, kk) + ans(jj, kk) = SUM(temp) / Gamma(jj) + END DO +END DO +!! +END PROCEDURE JacobiTransform2 + +!---------------------------------------------------------------------------- +! JacobiTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiTransform3 +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: ii +!! +CALL JacobiQuadrature(n=n + 1, alpha=alpha, beta=beta, pt=pt, wt=wt,& + & quadType=quadType) +!! +DO ii = 0, n + coeff(ii) = f(pt(ii)) +END DO +!! +ans = JacobiTransform(n=n, alpha=alpha, beta=beta, coeff=coeff, x=pt, & + & w=wt, quadType=quadType) +END PROCEDURE JacobiTransform3 + +!---------------------------------------------------------------------------- +! JacobiInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiInvTransform1 +ans = JacobiEvalSum(n=n, alpha=alpha, beta=beta, coeff=coeff, & + & x=x) +END PROCEDURE JacobiInvTransform1 + +!---------------------------------------------------------------------------- +! JacobiInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiInvTransform2 +ans = JacobiEvalSum(n=n, alpha=alpha, beta=beta, coeff=coeff, & + & x=x) +END PROCEDURE JacobiInvTransform2 + +!---------------------------------------------------------------------------- +! JacobiGradientCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiGradientCoeff1 +REAL(DFP) :: a, b, c, ab, amb, tnab, nab +INTEGER(I4B) :: ii +REAL(DFP) :: jj + +ans(n) = 0.0_DFP +IF (n .EQ. 0) RETURN +!! +!! c(n-1) +!! +ab = alpha + beta +amb = alpha - beta +tnab = 2.0 * n + ab +nab = n + ab +!! +IF (n .EQ. 1) THEN + c = 2.0_DFP / (ab + 2.0_DFP) +ELSE + c = 2.0 * (n + ab) / (tnab - 1.0) / tnab +END IF +!! +ans(n - 1) = coeff(n) / c +!! +DO ii = n - 1, 1, -1 + jj = REAL(ii, KIND=DFP) + tnab = 2.0 * jj + ab + nab = jj + ab + c = 2.0 * (jj + ab) / (tnab - 1.0) / tnab + b = 2.0 * amb / tnab / (tnab + 2.0) + a = -2.0 * (jj+alpha+1.0)*(jj+beta+1.0) / (nab+1.0) / (tnab+2.0)/(tnab+3.0) + ans(ii - 1) = (coeff(ii) - b * ans(ii) - a * ans(ii + 1)) / c +END DO +!! +END PROCEDURE JacobiGradientCoeff1 + +!---------------------------------------------------------------------------- +! JacobiDMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE JacobiDMatrix1 +SELECT CASE (quadType) +CASE (GaussLobatto) + CALL JacobiDMatrixGL(n=n, alpha=alpha, beta=beta, x=x, quadType=quadType,& + & D=ans) +CASE (Gauss) + CALL JacobiDMatrixG(n=n, alpha=alpha, beta=beta, x=x, quadType=quadType, & + & D=ans) +END SELECT +END PROCEDURE JacobiDMatrix1 + +!---------------------------------------------------------------------------- +! JacobiDMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE JacobiDMatrixGL(n, alpha, beta, x, quadType, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: ab, rn + INTEGER(I4B) :: ii, jj + REAL(DFP) :: gb2, gna1, gnb1, ga2, sgn, gn, ga1, temp + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! + J = JacobiGradientEval(n=n - 1, alpha=alpha + 1.0_DFP, & + & beta=beta + 1.0_DFP, x=x) + !! + !! zeroth column + !! + ab = alpha + beta + rn = REAL(n, KIND=DFP) + !! + D(0, 0) = 0.5 * (alpha - rn * (rn + ab + 1.0)) / (beta + 2.0) + !! + !! + gb2 = GAMMA(beta + 2.0_DFP) + gna1 = GAMMA(rn + alpha + 1.0_DFP) + gnb1 = GAMMA(rn + beta + 1.0_DFP) + ga1 = GAMMA(alpha + 1.0_DFP) + ga2 = ga1 * (alpha + 1.0_DFP) + gn = GAMMA(rn) + sgn = (-1.0)**n + !! + D(n, 0) = sgn * 0.5 * gb2 * gna1 / gnb1 / ga2 + !! + sgn = (-1.0)**(n - 1) + !! + DO ii = 1, n - 1 + D(ii, 0) = sgn * 0.5 * gn * gb2 * (1.0 - x(ii)) * J(ii) / gnb1 + END DO + !! + !! last column + !! + sgn = (-1.0)**(n + 1) + !! + D(0, n) = sgn * 0.5 * ga2 * gnb1 / gna1 / gb2 + !! + D(n, n) = 0.5 * (-beta + rn * (rn + ab + 1.0)) / (alpha + 2.0) + !! + D(1:n - 1, n) = (gn * ga2 * 0.5 / gna1) * (1.0_DFP + x(1:n - 1)) & + & * J(1:n - 1) + !! + !! internal columns + !! + sgn = (-1.0)**(n) + DO ii = 1, n - 1 + temp = J(ii) * (1.0 - x(ii)) * (1.0 + x(ii))**2 + D(0, ii) = 2.0 * sgn * gnb1 / gn / gb2 / temp + !! + temp = J(ii) * (1.0 + x(ii)) * (1.0 - x(ii))**2 + D(n, ii) = -2.0 * gna1 / gn / ga2 / temp + END DO + !! + DO jj = 1, n - 1 + DO ii = 1, n - 1 + IF (ii .EQ. jj) THEN + D(ii, ii) = (alpha - beta + ab * x(ii)) / 2.0 / (1.0 - x(ii)**2) + ELSE + D(ii, jj) = (1.0 - x(ii)**2) * J(ii) / (1.0 - x(jj)**2) / J(jj) & + & / (x(ii) - x(jj)) + END IF + END DO + END DO +END SUBROUTINE JacobiDMatrixGL + +!---------------------------------------------------------------------------- +! JacobiDMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE JacobiDMatrixG(n, alpha, beta, x, quadType, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: alpha + !! alpha > -1.0 + REAL(DFP), INTENT(IN) :: beta + !! beta > -1.0 + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + INTEGER(I4B), INTENT(IN) :: quadType + !! Gauss and GaussLobatto + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: ab, amb + INTEGER(I4B) :: ii, jj + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! + J = JacobiGradientEval(n=n + 1, alpha=alpha, beta=beta, x=x) + !! + !! zeroth column + !! + ab = alpha + beta + ab = alpha - beta + !! + DO jj = 0, n + DO ii = 0, n + IF (ii .EQ. jj) THEN + D(ii, ii) = (amb + (ab + 2.0) * x(ii)) / 2.0 / (1.0 - x(ii)**2) + ELSE + D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END IF + END DO + END DO +!! +END SUBROUTINE JacobiDMatrixG + END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/LagrangeUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 similarity index 60% rename from src/submodules/Polynomial/src/LagrangeUtility@Methods.F90 rename to src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index d079c14c4..e45a5886a 100644 --- a/src/submodules/Polynomial/src/LagrangeUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE(LagrangeUtility) Methods +SUBMODULE(LagrangePolynomialUtility) Methods USE BaseMethod IMPLICIT NONE CONTAINS @@ -106,27 +106,27 @@ !! degree = TRANSPOSE(LagrangeDegree(order=order, elemType=elemType)) !! -m = SIZE(x, 2) +m = SIZE(xij, 2) nsd = SIZE(degree, 1) n = SIZE(degree, 2) ALLOCATE (ans(m, n)) !! SELECT CASE (nsd) CASE (1) - x0 = x(1, :) + x0 = xij(1, :) DO jj = 1, n ans(:, jj) = x0**degree(1, jj) END DO CASE (2) - x0 = x(1, :) - y0 = x(2, :) + x0 = xij(1, :) + y0 = xij(2, :) DO jj = 1, n ans(:, jj) = x0**degree(1, jj) * y0**degree(2, jj) END DO CASE (3) - x0 = x(1, :) - y0 = x(2, :) - z0 = x(3, :) + x0 = xij(1, :) + y0 = xij(2, :) + z0 = xij(3, :) DO jj = 1, n ans(:, jj) = x0**degree(1, jj) * y0**degree(2, jj) * z0**degree(3, jj) END DO @@ -181,22 +181,132 @@ ALLOCATE (ans(0, 0)) END IF CASE (Line) - ans = InterpolationPoint_Line(order=order, ipType=ipType, xij=xij) + ans = InterpolationPoint_Line(order=order, ipType=ipType, xij=xij, & + & layout=layout) CASE (Triangle) - ans = InterpolationPoint_Triangle(order=order, ipType=ipType, xij=xij) + ans = InterpolationPoint_Triangle(order=order, ipType=ipType, xij=xij, & + & layout=layout) CASE (Quadrangle) - ans = InterpolationPoint_Quadrangle(order=order, ipType=ipType, xij=xij) + ans = InterpolationPoint_Quadrangle(order=order, ipType=ipType, xij=xij, & + & layout=layout) CASE (Tetrahedron) - ans = InterpolationPoint_Tetrahedron(order=order, ipType=ipType, xij=xij) + ans = InterpolationPoint_Tetrahedron(order=order, ipType=ipType, xij=xij, & + & layout=layout) CASE (Hexahedron) - ans = InterpolationPoint_Hexahedron(order=order, ipType=ipType, xij=xij) + ans = InterpolationPoint_Hexahedron(order=order, ipType=ipType, xij=xij, & + &layout=layout) CASE (Prism) - ans = InterpolationPoint_Prism(order=order, ipType=ipType, xij=xij) + ans = InterpolationPoint_Prism(order=order, ipType=ipType, xij=xij, & + & layout=layout) CASE (Pyramid) - ans = InterpolationPoint_Pyramid(order=order, ipType=ipType, xij=xij) + ans = InterpolationPoint_Pyramid(order=order, ipType=ipType, xij=xij, & + & layout=layout) END SELECT END PROCEDURE InterpolationPoint +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff1 +SELECT CASE (elemType) +CASE (Point) + !! +CASE (Line) + ans = LagrangeCoeff_Line(order=order, xij=xij, i=i) +CASE (Triangle) + ans = LagrangeCoeff_Triangle(order=order, xij=xij, i=i) +CASE (Quadrangle) + ans = LagrangeCoeff_Quadrangle(order=order, xij=xij, i=i) +CASE (Tetrahedron) + ans = LagrangeCoeff_Tetrahedron(order=order, xij=xij, i=i) +CASE (Hexahedron) + ans = LagrangeCoeff_Hexahedron(order=order, xij=xij, i=i) +CASE (Prism) + ans = LagrangeCoeff_Prism(order=order, xij=xij, i=i) +CASE (Pyramid) + ans = LagrangeCoeff_Pyramid(order=order, xij=xij, i=i) +END SELECT +END PROCEDURE LagrangeCoeff1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff2 +SELECT CASE (elemType) +CASE (Point) + !! +CASE (Line) + ans = LagrangeCoeff_Line(order=order, xij=xij) +CASE (Triangle) + ans = LagrangeCoeff_Triangle(order=order, xij=xij) +CASE (Quadrangle) + ans = LagrangeCoeff_Quadrangle(order=order, xij=xij) +CASE (Tetrahedron) + ans = LagrangeCoeff_Tetrahedron(order=order, xij=xij) +CASE (Hexahedron) + ans = LagrangeCoeff_Hexahedron(order=order, xij=xij) +CASE (Prism) + ans = LagrangeCoeff_Prism(order=order, xij=xij) +CASE (Pyramid) + ans = LagrangeCoeff_Pyramid(order=order, xij=xij) +END SELECT + !! +END PROCEDURE LagrangeCoeff2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff3 +SELECT CASE (elemType) +CASE (Point) + !! +CASE (Line) + ans = LagrangeCoeff_Line(order=order, i=i, v=v, isVandermonde=.TRUE.) +CASE (Triangle) + ans = LagrangeCoeff_Triangle(order=order, i=i, v=v, isVandermonde=.TRUE.) +CASE (Quadrangle) + ans = LagrangeCoeff_Quadrangle(order=order, i=i, v=v, isVandermonde=.TRUE.) +CASE (Tetrahedron) + ans = LagrangeCoeff_Tetrahedron(order=order, i=i, v=v, isVandermonde=.TRUE.) +CASE (Hexahedron) + ans = LagrangeCoeff_Hexahedron(order=order, i=i, v=v, isVandermonde=.TRUE.) +CASE (Prism) + ans = LagrangeCoeff_Prism(order=order, i=i, v=v, isVandermonde=.TRUE.) +CASE (Pyramid) + ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, isVandermonde=.TRUE.) +END SELECT + !! +END PROCEDURE LagrangeCoeff3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff4 +SELECT CASE (elemType) +CASE (Point) + !! +CASE (Line) + ans = LagrangeCoeff_Line(order=order, i=i, v=v, ipiv=ipiv) +CASE (Triangle) + ans = LagrangeCoeff_Triangle(order=order, i=i, v=v, ipiv=ipiv) +CASE (Quadrangle) + ans = LagrangeCoeff_Quadrangle(order=order, i=i, v=v, ipiv=ipiv) +CASE (Tetrahedron) + ans = LagrangeCoeff_Tetrahedron(order=order, i=i, v=v, ipiv=ipiv) +CASE (Hexahedron) + ans = LagrangeCoeff_Hexahedron(order=order, i=i, v=v, ipiv=ipiv) +CASE (Prism) + ans = LagrangeCoeff_Prism(order=order, i=i, v=v, ipiv=ipiv) +CASE (Pyramid) + ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, ipiv=ipiv) +END SELECT + !! +END PROCEDURE LagrangeCoeff4 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 index a7377dbf3..70ac7f42d 100644 --- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 @@ -20,6 +20,29 @@ IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! LegendreAlpha +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreAlpha +ans = 0.0_DFP +END PROCEDURE LegendreAlpha + +!---------------------------------------------------------------------------- +! LegendreBeta +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreBeta +REAL(DFP) :: avar +!! +IF (n .EQ. 0_I4B) THEN + ans = 2.0_DFP +ELSE + avar = REAL(n**2, KIND=DFP) + ans = avar / (4.0_DFP * avar - 1.0_DFP) +END IF +END PROCEDURE LegendreBeta + !---------------------------------------------------------------------------- ! GetLegendreRecurrenceCoeff !---------------------------------------------------------------------------- @@ -42,6 +65,25 @@ !! END PROCEDURE GetLegendreRecurrenceCoeff +!---------------------------------------------------------------------------- +! GetLegendreRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetLegendreRecurrenceCoeff2 +REAL(DFP) :: j +INTEGER(I4B) :: ii +!! +IF (n .LT. 1) RETURN +B = 0.0_DFP +!! +DO ii = 1, n + j = REAL(ii, KIND=DFP) + A(ii - 1) = (2.0_DFP * j - 1.0_DFP) / j; + C(ii - 1) = (j - 1.0_DFP) / j; +END DO +!! +END PROCEDURE GetLegendreRecurrenceCoeff2 + !---------------------------------------------------------------------------- ! LegendreLeadingCoeff !---------------------------------------------------------------------------- @@ -54,6 +96,14 @@ ans = a1 / a2 / a3 END PROCEDURE LegendreLeadingCoeff +!---------------------------------------------------------------------------- +! LegendreLeadingCoeffRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreLeadingCoeffRatio +ans = (2.0 * n + 1) / (n + 1.0_DFP) +END PROCEDURE LegendreLeadingCoeffRatio + !---------------------------------------------------------------------------- ! LegendreNormSqr !---------------------------------------------------------------------------- @@ -62,6 +112,25 @@ ans = 2.0_DFP / (2.0_DFP * n + 1.0_DFP) END PROCEDURE LegendreNormSqr +!---------------------------------------------------------------------------- +! LegendreNormSqrRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreNormSqrRatio +ans = (2.0_DFP * n + 1.0_DFP) / (2.0_DFP * n + 3.0_DFP) +END PROCEDURE LegendreNormSqrRatio + +!---------------------------------------------------------------------------- +! LegendreNormSqr2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreNormSqr2 +INTEGER(I4B) :: ii +DO ii = 0, n + ans(ii) = 2.0_DFP / (2.0_DFP * ii + 1.0_DFP) +END DO +END PROCEDURE LegendreNormSqr2 + !---------------------------------------------------------------------------- ! LegendreJacobiMatrix !---------------------------------------------------------------------------- @@ -89,15 +158,19 @@ REAL(DFP) :: pn(n), fixvar INTEGER(I4B) :: ii !! -CALL LegendreJacobiMatrix(n=n, D=pt, E=wt) +CALL LegendreJacobiMatrix(n=n, D=pt, E=pn) !! #ifdef USE_LAPACK95 -CALL STEV(D=pt, E=wt) -pn = LegendreEval(n=n - 1, x=pt) -fixvar = 2.0_DFP / REAL(n**2, KIND=DFP) -DO ii = 1, n - wt(ii) = fixvar * (1.0_DFP - pt(ii)**2) / (pn(ii)**2) -END DO +CALL STEV(D=pt, E=pn) +!! +IF (PRESENT(wt)) THEN + wt = pn + pn = LegendreEval(n=n - 1, x=pt) + fixvar = 2.0_DFP / REAL(n**2, KIND=DFP) + DO ii = 1, n + wt(ii) = fixvar * (1.0_DFP - pt(ii)**2) / (pn(ii)**2) + END DO +END IF !! #else CALL ErrorMsg( & @@ -141,17 +214,21 @@ REAL(DFP) :: pn(n + 1), fixvar INTEGER(I4B) :: ii !! -CALL LegendreJacobiRadauMatrix(a=a, n=n, D=pt, E=wt) +CALL LegendreJacobiRadauMatrix(a=a, n=n, D=pt, E=pn) !! #ifdef USE_LAPACK95 !! -CALL STEV(D=pt, E=wt) -pn = LegendreEval(n=n, x=pt) -fixvar = 1.0_DFP / REAL((n + 1)**2, KIND=DFP) +CALL STEV(D=pt, E=pn) !! -DO ii = 1, n + 1 - wt(ii) = fixvar * (1.0_DFP + a * pt(ii)) / (pn(ii)**2) -END DO +IF (PRESENT(wt)) THEN + wt = pn + pn = LegendreEval(n=n, x=pt) + fixvar = 1.0_DFP / REAL((n + 1)**2, KIND=DFP) + !! + DO ii = 1, n + 1 + wt(ii) = fixvar * (1.0_DFP + a * pt(ii)) / (pn(ii)**2) + END DO +END IF !! #else CALL ErrorMsg( & @@ -172,7 +249,7 @@ !! REAL(DFP) :: r1, r2 !! -IF (n .LT. 1) RETURN +IF (n .LT. 0) RETURN !! CALL LegendreJacobiMatrix( & & n=n + 1, & @@ -197,17 +274,21 @@ REAL(DFP) :: pn(n + 2), fixvar INTEGER(I4B) :: ii !! -CALL LegendreJacobiLobattoMatrix(n=n, D=pt, E=wt) +CALL LegendreJacobiLobattoMatrix(n=n, D=pt, E=pn) !! #ifdef USE_LAPACK95 !! -CALL STEV(D=pt, E=wt) -pn = LegendreEval(n=n + 1, x=pt) -fixvar = 2.0_DFP / REAL((n + 1) * (n + 2), KIND=DFP) +CALL STEV(D=pt, E=pn) !! -DO ii = 1, n + 2 - wt(ii) = fixvar / (pn(ii)**2) -END DO +IF (PRESENT(wt)) THEN + wt = pn + pn = LegendreEval(n=n + 1, x=pt) + fixvar = 2.0_DFP / REAL((n + 1) * (n + 2), KIND=DFP) + !! + DO ii = 1, n + 2 + wt(ii) = fixvar / (pn(ii)**2) + END DO +END IF !! #else CALL ErrorMsg( & @@ -431,6 +512,7 @@ ans(:, i + 1) = ((c2 * x) * ans(:, i) + c3 * ans(:, i - 1)) / c1 !! END DO + END PROCEDURE LegendreEvalAll2 !---------------------------------------------------------------------------- @@ -444,7 +526,7 @@ IF (n < 0) THEN RETURN END IF - !! +!! ans = 0.0_DFP ans(1, 1) = 1.0_DFP !! @@ -455,7 +537,7 @@ ans(2, 2) = 1.0_DFP !! DO ii = 2, n - !! + !! r_i = REAL(ii, KIND=DFP) !! ans(1:ii - 1, ii + 1) = & @@ -486,21 +568,21 @@ INTEGER(I4B) :: ii REAL(DFP) :: r_ii REAL(DFP) :: p(1:n + 1) -!! + !! IF (n < 0) THEN RETURN END IF !! p(1) = 1.0_DFP ans(1) = 0.0_DFP -!! + !! IF (n < 1) THEN RETURN END IF !! p(2) = x ans(2) = 1.0_DFP -!! + !! DO ii = 2, n !! r_ii = REAL(ii, KIND=DFP) @@ -647,6 +729,452 @@ !! END PROCEDURE LegendreGradientEval2 +!---------------------------------------------------------------------------- +! LegendreEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEvalSum1 +REAL(DFP) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0.0_DFP +b2 = 0.0_DFP +!! +DO j = n, 1, -1 + i = REAL(j, KIND=DFP) + t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) + b2 = b1 + b1 = t +END DO +!! +ans = x * b1 - b2 / 2.0_DFP + coeff(0) +!! +END PROCEDURE LegendreEvalSum1 + +!---------------------------------------------------------------------------- +! LegendreEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreEvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0.0_DFP +b2 = 0.0_DFP +!! +DO j = n, 1, -1 + i = REAL(j, KIND=DFP) + t = (2 * i + 1) / (i + 1) * x * b1 - (i + 1) / (i + 2) * b2 + coeff(j) + b2 = b1 + b1 = t +END DO +!! +ans = x * b1 - b2 / 2.0_DFP + coeff(0) +!! +END PROCEDURE LegendreEvalSum2 + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalSum1 +REAL(DFP) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0 +b2 = 0 +!! +DO j = n - 1, 0, -1 + i = REAL(j, KIND=DFP) + t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); + b2 = b1; + b1 = t; +END DO +ans = b1 +END PROCEDURE LegendreGradientEvalSum1 + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0 +b2 = 0 +!! +DO j = n - 1, 0, -1 + i = REAL(j, KIND=DFP) + t = (2 * i + 3) / (i + 1) * x * b1 - (i + 3) / (i + 2) * b2 + coeff(j + 1); + b2 = b1; + b1 = t; +END DO +ans = b1 +END PROCEDURE LegendreGradientEvalSum2 + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalSum3 +REAL(DFP) :: t, b1, b2 +REAL(DFP) :: s, A1, A2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0 +b2 = 0 +s = 1.0_DFP +!! +DO j = 2 * k - 1, 1, -2 + s = j * s +END DO +!! +DO j = n - k, 0, -1 + i = REAL(j, KIND=DFP) + A1 = (2 * i + 2 * k + 1) / (i + 1) * x; + A2 = -(i + 2 * k + 1) / (i + 2); + t = A1 * b1 + A2 * b2 + coeff(j + k); + b2 = b1; + b1 = t; +END DO +ans = s * b1 +END PROCEDURE LegendreGradientEvalSum3 + +!---------------------------------------------------------------------------- +! LegendreGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientEvalSum4 +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2, A1 +REAL(DFP) :: s, A2 +INTEGER(I4B) :: j +REAL(DFP) :: i +!! +IF (n .LT. 0) RETURN +!! +b1 = 0 +b2 = 0 +s = 1.0_DFP +!! +DO j = 2 * k - 1, 1, -2 + s = j * s +END DO +!! +DO j = n - k, 0, -1 + i = REAL(j, KIND=DFP) + A1 = (2 * i + 2 * k + 1) / (i + 1) * x; + A2 = -(i + 2 * k + 1) / (i + 2); + t = A1 * b1 + A2 * b2 + coeff(j + k); + b2 = b1; + b1 = t; +END DO +!! +ans = s * b1 +END PROCEDURE LegendreGradientEvalSum4 + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform1 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj +REAL(DFP) :: rn +!! +nrmsqr = LegendreNormSQR2(n=n) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = 2.0_DFP / rn +END IF +!! +PP = LegendreEvalAll(n=n, x=x) +!! +DO jj = 0, n + temp = PP(:, jj) * w * coeff + ans(jj) = SUM(temp) / nrmsqr(jj) +END DO +!! +END PROCEDURE LegendreTransform1 + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform2 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj, kk +REAL(DFP) :: rn +!! +nrmsqr = LegendreNormSQR2(n=n) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = 2.0_DFP / rn +END IF +!! +PP = LegendreEvalAll(n=n, x=x) +!! +DO kk = 1, SIZE(coeff, 2) + DO jj = 0, n + temp = PP(:, jj) * w * coeff(:, kk) + ans(jj, kk) = SUM(temp) / nrmsqr(jj) + END DO +END DO +!! +END PROCEDURE LegendreTransform2 + +!---------------------------------------------------------------------------- +! LegendreTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreTransform3 +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: ii +!! +CALL LegendreQuadrature(n=n + 1, pt=pt, wt=wt,& + & quadType=quadType) +!! +DO ii = 0, n + coeff(ii) = f(pt(ii)) +END DO +!! +ans = LegendreTransform(n=n, coeff=coeff, x=pt, & + & w=wt, quadType=quadType) +!! +END PROCEDURE LegendreTransform3 + +!---------------------------------------------------------------------------- +! LegendreInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreInvTransform1 +ans = LegendreEvalSum(n=n, coeff=coeff, x=x) +END PROCEDURE LegendreInvTransform1 + +!---------------------------------------------------------------------------- +! LegendreInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreInvTransform2 +ans = LegendreEvalSum(n=n, coeff=coeff, x=x) +END PROCEDURE LegendreInvTransform2 + +!---------------------------------------------------------------------------- +! LegendreGradientCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreGradientCoeff1 +ans = UltrasphericalGradientCoeff(n=n, lambda=0.5_DFP, coeff=coeff) +END PROCEDURE LegendreGradientCoeff1 + +!---------------------------------------------------------------------------- +! LegendreDMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreDMatrix1 +SELECT CASE (quadType) +CASE (GaussLobatto) + CALL LegendreDMatrixGL2(n=n, x=x, D=ans) +CASE (Gauss) + CALL LegendreDMatrixG2(n=n, x=x, D=ans) +END SELECT +END PROCEDURE LegendreDMatrix1 + +!---------------------------------------------------------------------------- +! LegendreDMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE LegendreDMatrixGL(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: rn + INTEGER(I4B) :: ii, jj + !! + rn = REAL(n, KIND=DFP) + !! + J = LegendreEval(n=n, x=x) + !! + D = 0.0_DFP + D(0, 0) = 0.125_DFP * rn * (rn + 1.0_DFP) + D(n, n) = -D(0, 0) + !! + DO jj = 0, n + DO ii = 0, n + IF (ii .NE. jj) & + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END DO + END DO + !! +END SUBROUTINE LegendreDMatrixGL + +!---------------------------------------------------------------------------- +! LegendreDMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE LegendreDMatrixGL2(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: rn + INTEGER(I4B) :: ii, jj, nb2 + !! + nb2 = int(n / 2) + rn = REAL(n, KIND=DFP) + !! + J = LegendreEval(n=n, x=x) + D = 0.0_DFP + !! + DO jj = 0, n + DO ii = 0, nb2 + IF (ii .NE. jj) & + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = -SUM(D(ii, :)) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE LegendreDMatrixGL2 + +!---------------------------------------------------------------------------- +! LegendreDMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE LegendreDMatrixG(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + INTEGER(I4B) :: ii, jj + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! + J = LegendreGradientEval(n=n + 1, x=x) + !! + DO jj = 0, n + DO ii = 0, n + IF (ii .EQ. jj) THEN + D(ii, ii) = x(ii) / (1.0 - x(ii)**2) + ELSE + D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END IF + END DO + END DO +!! +END SUBROUTINE LegendreDMatrixG + +!---------------------------------------------------------------------------- +! LegendreDMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE LegendreDMatrixG2(n, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! internal variables + !! + REAL(DFP) :: J(0:n) + INTEGER(I4B) :: ii, jj, nb2 + !! + !! main + !! + nb2 = int(n / 2) + D = 0.0_DFP + !! + J = LegendreGradientEval(n=n + 1, x=x) + !! + DO jj = 0, n + DO ii = 0, nb2 + IF (ii .NE. jj) & + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = -SUM(D(ii, :)) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE LegendreDMatrixG2 + +!---------------------------------------------------------------------------- +! LegendreDMatEvenOdd +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LegendreDMatEvenOdd1 +CALL UltrasphericalDMatEvenOdd(n=n, D=D, o=o, e=e) +END PROCEDURE LegendreDMatEvenOdd1 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 27813cb2e..944c117e3 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -182,13 +182,90 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Line1 +CHARACTER(LEN=20) :: astr +INTEGER(I4B) :: nsd, ii +REAL(DFP) :: temp(order + 1), t1 +!! +IF (order .EQ. 0_I4B) THEN + IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + CALL Reallocate(ans, nsd, 1) + ans(1:nsd, 1) = 0.5_DFP * (xij(1:nsd, 1) + xij(1:nsd, 2)) + ELSE + CALL Reallocate(ans, 1, 1) + ans(1:nsd, 1) = 0.0_DFP + END IF + RETURN +END IF +!! +astr = TRIM(UpperCase(layout)) +!! SELECT CASE (ipType) CASE (Equidistance) + !! ans = EquidistancePoint_Line(xij=xij, order=order) + !! + IF (astr .EQ. "INCREASING") THEN + DO ii = 1, SIZE(ans, 1) + ans(ii, :) = SORT(ans(ii, :)) + END DO + END IF + !! + RETURN + !! CASE (GaussLegendre) -CASE (GaussLobatto) -CASE (Chebyshev) + !! + CALL LegendreQuadrature(n=order + 1, pt=temp, quadType=Gauss) + !! +CASE (GaussLegendreLobatto) + !! + CALL LegendreQuadrature(n=order + 1, pt=temp, quadType=GaussLobatto) + !! + IF (layout .EQ. "VEFC") THEN + t1 = temp(order + 1) + IF (order .GE. 2) THEN + temp(3:) = temp(2:order) + END IF + temp(2) = t1 + END IF + !! +CASE (GaussChebyshev) + !! + CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=Gauss) + !! +CASE (GaussChebyshevLobatto) + !! + CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=GaussLobatto) + !! + IF (layout .EQ. "VEFC") THEN + t1 = temp(order + 1) + IF (order .GE. 2) THEN + temp(3:) = temp(2:order) + END IF + temp(2) = t1 + END IF + !! +CASE DEFAULT + CALL ErrorMsg(& + & msg="Unknown iptype", & + & file=__FILE__, & + & routine="InterpolationPoint_Line1", & + & line=__LINE__, & + & unitno=stderr) END SELECT +!! +IF (ipType .NE. Equidistance) THEN + IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) + CALL Reallocate(ans, nsd, order + 1) + ans = FromBiunitLine2Segment(xin=temp, x1=xij(:, 1), & + & x2=xij(:, 2)) + ELSE + CALL Reallocate(ans, 1, order + 1) + ans(1, :) = temp + END IF + !! +END IF END PROCEDURE InterpolationPoint_Line1 !---------------------------------------------------------------------------- @@ -196,15 +273,129 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Line2 +CHARACTER(LEN=20) :: astr +REAL(DFP) :: t1 +!! +IF (order .EQ. 0_I4B) THEN + ans = [0.5_DFP * (xij(1) + xij(2))] + RETURN +END IF +!! +astr = TRIM(UpperCase(layout)) +!! SELECT CASE (ipType) CASE (Equidistance) + !! ans = EquidistancePoint_Line(xij=xij, order=order) + IF (astr .EQ. "INCREASING") ans = SORT(ans) + RETURN + !! CASE (GaussLegendre) -CASE (GaussLobatto) -CASE (Chebyshev) + !! + CALL Reallocate(ans, order + 1) + CALL LegendreQuadrature(n=order + 1, pt=ans, quadType=Gauss) + !! +CASE (GaussLegendreLobatto) + !! + CALL Reallocate(ans, order + 1) + CALL LegendreQuadrature(n=order + 1, pt=ans, quadType=GaussLobatto) + !! + IF (layout .EQ. "VEFC") THEN + t1 = ans(order + 1) + IF (order .GE. 2) THEN + ans(3:) = ans(2:order) + END IF + ans(2) = t1 + END IF + !! +CASE (GaussChebyshev) + !! + CALL Reallocate(ans, order + 1) + CALL Chebyshev1Quadrature(n=order + 1, pt=ans, quadType=Gauss) + !! +CASE (GaussChebyshevLobatto) + !! + CALL Reallocate(ans, order + 1) + CALL Chebyshev1Quadrature(n=order + 1, pt=ans, quadType=GaussLobatto) + !! + IF (layout .EQ. "VEFC") THEN + t1 = ans(order + 1) + IF (order .GE. 2) THEN + ans(3:) = ans(2:order) + END IF + ans(2) = t1 + END IF + !! +CASE DEFAULT + CALL ErrorMsg(& + & msg="Unknown iptype", & + & file=__FILE__, & + & routine="InterpolationPoint_Line2", & + & line=__LINE__, & + & unitno=stderr) END SELECT +!! +IF (ipType .NE. Equidistance) THEN + ans = FromBiunitLine2Segment(xin=ans, x1=xij(1), x2=xij(2)) +END IF +!! END PROCEDURE InterpolationPoint_Line2 +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line1 +REAL(DFP) :: v(SIZE(xij, 2), SIZE(xij, 2)) +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +!! +v = LagrangeVandermonde(order=order, xij=xij, elemType=Line2) +CALL getLU(A=v, IPIV=ipiv, info=info) +!! +!! deploy to subroutine +!! +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +!! +END PROCEDURE LagrangeCoeff_Line1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line2 +REAL(DFP) :: vtemp(SIZE(v, 1), SIZE(v, 2)) +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +!! +vtemp = v; ipiv = 0 +CALL getLU(A=vtemp, IPIV=ipiv, info=info) +!! +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +!! +END PROCEDURE LagrangeCoeff_Line2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Line3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line4 +ans = LagrangeVandermonde(order=order, xij=xij, elemType=Line2) +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Line4 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 index cf9db5405..500b7cfc5 100644 --- a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 @@ -25,30 +25,30 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Clenshaw_1 - REAL( DFP ), DIMENSION( 0:SIZE( c ) ) :: u +REAL(DFP), DIMENSION(0:SIZE(c)) :: u !! n+2 - INTEGER( I4B ) :: ii, n - REAL( DFP ) :: y00, ym10 +INTEGER(I4B) :: ii, n +REAL(DFP) :: y00, ym10 !! - y00 = INPUT( default=1.0_DFP, option=y0 ) - ym10 = INPUT( default=0.0_DFP, option=ym1 ) +y00 = INPUT(default=1.0_DFP, option=y0) +ym10 = INPUT(default=0.0_DFP, option=ym1) !! !! !! The size of c, alpha, beta should be same n+1: 0 to n !! The size of u is n+2, 0 to n+1 !! - n = SIZE( c ) - 1 +n = SIZE(c) - 1 !! - u( n ) = c( n ) - u( n+1 ) = 0.0_DFP +u(n) = c(n) +u(n + 1) = 0.0_DFP !! - DO ii = n-1, 0, -1 - u( ii ) = ( x - alpha( ii ) )*u( ii+1 ) - beta( ii+1 ) * u( ii+2 ) + c(ii) - END DO +DO ii = n - 1, 0, -1 + u(ii) = (x - alpha(ii)) * u(ii + 1) - beta(ii + 1) * u(ii + 2) + c(ii) +END DO !! !! !! - ans = u( 0 ) * y00 - beta( 0 ) * u( 1 ) * ym10 +ans = u(0) * y00 - beta(0) * u(1) * ym10 !! END PROCEDURE Clenshaw_1 @@ -57,30 +57,30 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Clenshaw_2 - REAL( DFP ), DIMENSION( 1:SIZE(x), 0:SIZE( c ) ) :: u +REAL(DFP), DIMENSION(1:SIZE(x), 0:SIZE(c)) :: u !! n+2 - INTEGER( I4B ) :: ii, n - REAL( DFP ) :: y00, ym10 +INTEGER(I4B) :: ii, n +REAL(DFP) :: y00, ym10 !! - y00 = INPUT( default=1.0_DFP, option=y0 ) - ym10 = INPUT( default=0.0_DFP, option=ym1 ) +y00 = INPUT(default=1.0_DFP, option=y0) +ym10 = INPUT(default=0.0_DFP, option=ym1) !! !! The size of c, alpha, beta should be same n+1: 0 to n !! The size of u is n+2, 0 to n+1 !! - n = SIZE( c ) - 1 +n = SIZE(c) - 1 !! - u( :, n ) = c( n ) - u( :, n+1 ) = 0.0_DFP +u(:, n) = c(n) +u(:, n + 1) = 0.0_DFP !! - DO ii = n-1, 0, -1 - u( :, ii ) = ( x - alpha( ii ) )*u( :, ii+1 ) & - & - beta( ii+1 ) * u( :, ii+2 ) + c(ii) - END DO +DO ii = n - 1, 0, -1 + u(:, ii) = (x - alpha(ii)) * u(:, ii + 1) & + & - beta(ii + 1) * u(:, ii + 2) + c(ii) +END DO !! !! !! - ans = u( :, 0 ) * y00 - beta( 0 ) * u( :, 1 ) * ym10 +ans = u(:, 0) * y00 - beta(0) * u(:, 1) * ym10 !! END PROCEDURE Clenshaw_2 @@ -89,25 +89,25 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE ChebClenshaw_1 - REAL( DFP ), DIMENSION( 0:SIZE( c )+2 ) :: u +REAL(DFP), DIMENSION(0:SIZE(c) + 2) :: u !! n+2 - INTEGER( I4B ) :: ii, n +INTEGER(I4B) :: ii, n !! !! !! The size of c is n+1: 0 to n !! The size of u is n+3, 0 to n+2 !! - n = SIZE( c ) - 1 +n = SIZE(c) - 1 !! - u( n ) = c( n ) - u( n+1 ) = 0.0_DFP - u( n+2 ) = 0.0_DFP +u(n) = c(n) +u(n + 1) = 0.0_DFP +u(n + 2) = 0.0_DFP !! - DO ii = n-1, 0, -1 - u( ii ) = 2.0_DFP * x * u( ii + 1 ) - u( ii+2 ) + c( ii ) - END DO +DO ii = n - 1, 0, -1 + u(ii) = 2.0_DFP * x * u(ii + 1) - u(ii + 2) + c(ii) +END DO !! - ans = 0.5_DFP*( u(0)-u(2)) +ans = 0.5_DFP * (u(0) - u(2)) !! END PROCEDURE ChebClenshaw_1 @@ -116,24 +116,24 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE ChebClenshaw_2 - REAL( DFP ), DIMENSION( 1:SIZE(x), 0:SIZE( c )+2 ) :: u +REAL(DFP), DIMENSION(1:SIZE(x), 0:SIZE(c) + 2) :: u !! n+2 - INTEGER( I4B ) :: ii, n +INTEGER(I4B) :: ii, n !! !! The size of c is n+1: 0 to n !! The size of u is n+3, 0 to n+2 !! - n = SIZE( c ) - 1 +n = SIZE(c) - 1 !! - u( :, n ) = c( n ) - u( :, n+1 ) = 0.0_DFP - u( :, n+2 ) = 0.0_DFP +u(:, n) = c(n) +u(:, n + 1) = 0.0_DFP +u(:, n + 2) = 0.0_DFP !! - DO ii = n-1, 0, -1 - u( :, ii ) = 2.0_DFP * x * u( :, ii + 1 ) - u( :, ii+2 ) + c( ii ) - END DO +DO ii = n - 1, 0, -1 + u(:, ii) = 2.0_DFP * x * u(:, ii + 1) - u(:, ii + 2) + c(ii) +END DO !! - ans = 0.5_DFP*( u(:, 0)-u(:, 2)) +ans = 0.5_DFP * (u(:, 0) - u(:, 2)) !! END PROCEDURE ChebClenshaw_2 @@ -142,10 +142,27 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE JacobiMatrix_1 - INTEGER( I4B ) :: n - n = SIZE( alphaCoeff ) - D(1:n ) = alphaCoeff( 0:n-1 ) - E( 1:n-1 ) = SQRT( betaCoeff(1:n-1) ) +INTEGER(I4B) :: n +n = SIZE(alphaCoeff) +D(1:n) = alphaCoeff(0:n - 1) +E(1:n - 1) = SQRT(betaCoeff(1:n - 1)) END PROCEDURE JacobiMatrix_1 -END SUBMODULE Methods \ No newline at end of file +!---------------------------------------------------------------------------- +! EvalAllOrthopol +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EvalAllOrthopol +SELECT CASE (orthopol) +CASE (Jacobi) + ans = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x) +CASE (Ultraspherical) + ans = UltraSphericalEvalAll(n=n, lambda=lambda, x=x) +CASE (Legendre) + ans = LegendreEvalAll(n=n, x=x) +CASE (Chebyshev) + ans = Chebyshev1EvalAll(n=n, x=x) +END SELECT +END PROCEDURE EvalAllOrthopol + +END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 index 27898ef8d..14b8e8e2e 100644 --- a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 @@ -81,11 +81,62 @@ CASE (Equidistance) nodecoord = EquidistancePoint_Prism(xij=xij, order=order) CASE (GaussLegendre) -CASE (GaussLobatto) -CASE (Chebyshev) +CASE (GaussLegendreLobatto) +CASE (GaussChebyshev) +CASE (GaussChebyshevLobatto) END SELECT END PROCEDURE InterpolationPoint_Prism +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +!! +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Prism) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +!! +END PROCEDURE LagrangeCoeff_Prism1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism2 +!! +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +!! +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Prism2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Prism3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Prism4 +ans = LagrangeVandermonde(order=order, xij=xij, elemType=Prism) +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Prism4 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 index 3de8ef768..881a25e1b 100644 --- a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 @@ -80,11 +80,62 @@ CASE (Equidistance) nodecoord = EquidistancePoint_Pyramid(xij=xij, order=order) CASE (GaussLegendre) -CASE (GaussLobatto) -CASE (Chebyshev) +CASE (GaussLegendreLobatto) +CASE (GaussChebyshev) +CASE (GaussChebyshevLobatto) END SELECT END PROCEDURE InterpolationPoint_Pyramid +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +!! +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Pyramid) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +!! +END PROCEDURE LagrangeCoeff_Pyramid1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid2 +!! +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +!! +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Pyramid2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Pyramid3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Pyramid4 +ans = LagrangeVandermonde(order=order, xij=xij, elemType=Pyramid) +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Pyramid4 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index e3b59655e..39cfc68d9 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -266,13 +266,381 @@ CASE (Equidistance) nodecoord = EquidistancePoint_Quadrangle(xij=xij, order=order) CASE (GaussLegendre) -CASE (GaussLobatto) -CASE (Chebyshev) +CASE (GaussLegendreLobatto) +CASE (GaussChebyshev) +CASE (GaussChebyshevLobatto) END SELECT END PROCEDURE InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +!! +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Quadrangle) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +!! +END PROCEDURE LagrangeCoeff_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle2 +!! +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +!! +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle4 +ans = LagrangeVandermonde(order=order, xij=xij, elemType=Quadrangle) +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Quadrangle4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Quadrangle1 +REAL(DFP) :: P1(SIZE(xij, 2), order + 1), P2(SIZE(xij, 2), order + 1) +REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) +REAL(DFP) :: avec(SIZE(xij, 2)), alpha, beta +INTEGER(I4B) :: k1, k2, max_k2, cnt +!! +x = xij(1, :) +y = xij(2, :) +!! +P1 = LegendreEvalAll(n=order, x=x) +!! +!! we do not need x now, so let store (1-y)/2 in x +!! +x = 0.5_DFP * (1.0_DFP - y) +!! +alpha = 0.0_DFP +beta = 0.0_DFP +cnt = 0 +!! +DO k1 = 0, order + !! + avec = (x)**k1 !! note here x = 0.5_DFP*(1-y) + alpha = 2.0_DFP * k1 + 1.0_DFP + !! + max_k2 = order - k1 + !! + P2(:, 1:max_k2 + 1) = JacobiEvalAll(n=max_k2, x=y, alpha=alpha, beta=beta) + !! + DO k2 = 0, max_k2 + cnt = cnt + 1 + ans(:, cnt) = P1(:, k1 + 1) * avec * P2(:, k2 + 1) + END DO + !! +END DO + +END PROCEDURE Dubiner_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Quadrangle2 +REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) +INTEGER(I4B) :: ii, jj, cnt +!! +xij = 0.0_DFP +cnt = 0 +DO ii = 1, SIZE(x) + DO jj = 1, SIZE(y) + cnt = cnt + 1 + xij(1, cnt) = x(ii) + xij(2, cnt) = y(jj) + END DO +END DO +!! +ans = Dubiner_Quadrangle1(order=order, xij=xij) +!! +END PROCEDURE Dubiner_Quadrangle2 + +!---------------------------------------------------------------------------- +! TensorProdOrthoPol_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdOrthoPol_Quadrangle1 +REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)) +REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) +INTEGER(I4B) :: ii, k1, k2, cnt +!! +x = xij(1, :) +y = xij(2, :) +!! +P1 = EvalAllOrthopol(n=p, x=x, orthopol=orthopol1, & + & alpha=alpha1, beta=beta1, lambda=lambda1) +Q1 = EvalAllOrthopol(n=q, x=y, orthopol=orthopol2, & + & alpha=alpha2, beta=beta2, lambda=lambda2) +!! +cnt = 0 +!! +DO k1 = 1, p + 1 + DO k2 = 1, q + 1 + cnt = cnt + 1 + ans(:, cnt) = P1(:, k1) * Q1(:, k2) + END DO +END DO +!! +END PROCEDURE TensorProdOrthoPol_Quadrangle1 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +MODULE PROCEDURE TensorProdOrthoPol_Quadrangle2 +REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) +INTEGER(I4B) :: ii, jj, cnt +!! +xij = 0.0_DFP +cnt = 0 +DO ii = 1, SIZE(x) + DO jj = 1, SIZE(y) + cnt = cnt + 1 + xij(1, cnt) = x(ii) + xij(2, cnt) = y(jj) + END DO +END DO +!! +ans = TensorProdOrthopol_Quadrangle1( & + & p=p, q=q, xij=xij, orthopol1=orthopol1, orthopol2=orthopol2, & + & alpha1=alpha1, beta1=beta1, beta2=beta2, lambda1=lambda1, & + & lambda2=lambda2) +!! +END PROCEDURE TensorProdOrthoPol_Quadrangle2 + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle +ans(:, 1) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP - y) +ans(:, 2) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP - y) +ans(:, 3) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP + y) +ans(:, 4) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP + y) +END PROCEDURE VertexBasis_Quadrangle + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle2 +ans(:, 1) = L1(:, 0) * L2(:, 0) +ans(:, 2) = L1(:, 1) * L2(:, 0) +ans(:, 3) = L1(:, 1) * L2(:, 1) +ans(:, 4) = L1(:, 0) * L2(:, 1) +END PROCEDURE VertexBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! VerticalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VerticalEdgeBasis_Quadrangle +REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2)) +INTEGER(I4B) :: maxQ, k2, cnt +!! +maxQ = MAX(qe1, qe2) +!! +L2 = LobattoEvalAll(n=maxQ, x=y) +!! +cnt = 0 +!! +DO k2 = 2, qe1 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * (1.0_DFP - x) * L2(:, k2) +END DO +!! +DO k2 = 2, qe2 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * (1.0_DFP + x) * L2(:, k2) +END DO +!! +END PROCEDURE VerticalEdgeBasis_Quadrangle + +!---------------------------------------------------------------------------- +! VerticalEdgeBasis_Quadrangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VerticalEdgeBasis_Quadrangle2 +INTEGER(I4B) :: k2, cnt +!! +cnt = 0 +!! +DO k2 = 2, qe1 + cnt = cnt + 1 + ans(:, cnt) = L1(:, 0) * L2(:, k2) +END DO +!! +DO k2 = 2, qe2 + cnt = cnt + 1 + ans(:, cnt) = L1(:, 1) * L2(:, k2) +END DO +!! +END PROCEDURE VerticalEdgeBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle +REAL(DFP) :: L1(1:SIZE(x), 0:MAX(pe3, pe4)) +INTEGER(I4B) :: maxP, k1, cnt +!! +maxP = MAX(pe3, pe4) +!! +L1 = LobattoEvalAll(n=maxP, x=x) +!! +cnt = 0 +!! +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * (1.0_DFP - y) * L1(:, k1) +END DO +!! +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt) = 0.25_DFP * (1.0_DFP + y) * L1(:, k1) +END DO +!! +END PROCEDURE HorizontalEdgeBasis_Quadrangle + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle2 +INTEGER(I4B) :: k1, cnt +!! +cnt = 0 +!! +DO k1 = 2, pe3 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, 0) +END DO +!! +DO k1 = 2, pe4 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, 1) +END DO +!! +END PROCEDURE HorizontalEdgeBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! CellBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Quadrangle +REAL(DFP) :: L1(1:SIZE(x), 0:pb) +REAL(DFP) :: L2(1:SIZE(y), 0:qb) +INTEGER(I4B) :: k1, k2, cnt +!! +L1 = LobattoEvalAll(n=pb, x=x) +L2 = LobattoEvalAll(n=qb, x=y) +!! +cnt = 0 +!! +DO k1 = 2, pb + DO k2 = 2, qb + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, k2) + END DO +END DO +!! +END PROCEDURE CellBasis_Quadrangle + +!---------------------------------------------------------------------------- +! CellBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Quadrangle2 +INTEGER(I4B) :: k1, k2, cnt +!! +cnt = 0 +!! +DO k1 = 2, pb + DO k2 = 2, qb + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * L2(:, k2) + END DO +END DO +!! +END PROCEDURE CellBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle1 +INTEGER(I4B) :: a, b, maxP, maxQ +REAL(DFP) :: L1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb)) +REAL(DFP) :: L2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb)) +!! +maxP = MAX(pe3, pe4, pb) +maxQ = MAX(qe1, qe2, qb) +!! +L1 = LobattoEvalAll(n=maxP, x=xij(1, :)) +L2 = LobattoEvalAll(n=maxQ, x=xij(2, :)) +!! +!! Vertex basis function +!! +ans(:, 1:4) = VertexBasis_Quadrangle2(L1=L1, L2=L2) +!! +!! Edge basis function +!! +b = 4 +!! +IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + qe1 + qe2 - 2 !!4+qe1 + qe2 - 2 + ans(:, a:b) = VerticalEdgeBasis_Quadrangle2( & + & qe1=qe1, qe2=qe2, L1=L1, L2=L2) +END IF +!! +!! Edge basis function +!! +IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + pe3 + pe4 - 2 !!4+pe3 + pe4 - 2 + ans(:, a:b) = HorizontalEdgeBasis_Quadrangle2( & + & pe3=pe3, pe4=pe4, L1=L1, L2=L2) +END IF +!! +!! Cell basis function +!! +IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + (pb - 1) * (qb - 1) + ans(:, a:b) = CellBasis_Quadrangle2(pb=pb, qb=qb, L1=L1, L2=L2) +END IF +END PROCEDURE HeirarchicalBasis_Quadrangle1 + END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 index 80ca94964..2fee7d440 100644 --- a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 @@ -33,13 +33,11 @@ REAL(DFP), ALLOCATABLE :: x(:) !! n = order -x = InterpolationPoint_Line(order=order, ipType=ipType, xij=xij) -!! -IF (order .GT. 1) THEN - avar = x(2) - x(2:order) = x(3:) - x(order + 1) = avar -END IF +x = InterpolationPoint_Line( & + & order=order, & + & ipType=ipType, & + & xij=xij, & + & layout="INCREASING") !! indices = GetMultiIndices(n=n, d=d) CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) @@ -73,8 +71,9 @@ INTEGER(I4B), ALLOCATABLE :: indices(:, :) !! n = order -CALL BarycentericNodeFamily1D(order=order, ipType=ipType, ans=BX, Xn=Xn) -! +CALL BarycentericNodeFamily1D(order=order, ipType=ipType, ans=BX, & + & Xn=Xn) +!! indices = GetMultiIndices(n=n, d=d) CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2)) !! @@ -108,7 +107,7 @@ END PROCEDURE RecursiveNode2D !---------------------------------------------------------------------------- -! RecursiveNode3D +! RecursiveNode3D !---------------------------------------------------------------------------- MODULE PROCEDURE RecursiveNode3D @@ -158,7 +157,7 @@ ! !---------------------------------------------------------------------------- -PURE SUBROUTINE BarycentericNodeFamily1D(order, ipType, ans, Xn) +SUBROUTINE BarycentericNodeFamily1D(order, ipType, ans, Xn) INTEGER(I4B), INTENT(IN) :: order INTEGER(I4B), INTENT(IN) :: ipType REAL(DFP), INTENT(OUT) :: ans(2, order + 1, order + 1) @@ -191,7 +190,7 @@ END SUBROUTINE BarycentericNodeFamily1D ! !---------------------------------------------------------------------------- -PURE SUBROUTINE BarycentericNodeFamily2D(order, ipType, ans, Xn) +SUBROUTINE BarycentericNodeFamily2D(order, ipType, ans, Xn) INTEGER(I4B), INTENT(IN) :: order INTEGER(I4B), INTENT(IN) :: ipType REAL(DFP), INTENT(OUT) :: ans(3, order + 1, order + 1, order + 1) @@ -218,13 +217,14 @@ PURE SUBROUTINE BarycentericNodeFamily2D(order, ipType, ans, Xn) !! END DO !! - Xn = InterpolationPoint_Line(order=order, ipType=ipType, xij=xij) + Xn = InterpolationPoint_Line(order=order, ipType=ipType, xij=xij, & + & layout="INCREASING") !! - IF (order .GT. 1) THEN - avar = Xn(2) - Xn(2:order) = Xn(3:) - Xn(order + 1) = avar - END IF + ! IF (order .GT. 1) THEN + ! avar = Xn(2) + ! Xn(2:order) = Xn(3:) + ! Xn(order + 1) = avar + ! END IF !! IF (ALLOCATED(BXn)) DEALLOCATE (BXn) IF (ALLOCATED(indices)) DEALLOCATE (indices) diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 index f3825463c..f0d6c8b71 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 @@ -26,12 +26,12 @@ MODULE PROCEDURE LagrangeDegree_Tetrahedron INTEGER(I4B) :: n, ii, jj, kk, ll - !! +!! n = LagrangeDOF_Tetrahedron(order=order) ALLOCATE (ans(n, 3)) - !! +!! ll = 0 - !! +!! DO kk = 0, order DO jj = 0, order DO ii = 0, order @@ -288,11 +288,62 @@ CASE (Equidistance) nodecoord = EquidistancePoint_Tetrahedron(xij=xij, order=order) CASE (GaussLegendre) -CASE (GaussLobatto) -CASE (Chebyshev) +CASE (GaussLegendreLobatto) +CASE (GaussChebyshev) +CASE (GaussChebyshevLobatto) END SELECT END PROCEDURE InterpolationPoint_Tetrahedron +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +!! +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Tetrahedron) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +!! +END PROCEDURE LagrangeCoeff_Tetrahedron1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron2 +!! +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +!! +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Tetrahedron2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Tetrahedron3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Tetrahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Tetrahedron4 +ans = LagrangeVandermonde(order=order, xij=xij, elemType=Tetrahedron) +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Tetrahedron4 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 index 01a0d2819..adf7d3096 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 @@ -26,12 +26,14 @@ MODULE PROCEDURE LagrangeDegree_Triangle INTEGER(I4B) :: n, ii, jj, kk - !! +!! n = LagrangeDOF_Triangle(order=order) ALLOCATE (ans(n, 2)) - !! +!! kk = 0 - !! +!! +!! left diagonal +!! DO jj = 0, order DO ii = 0, order - jj kk = kk + 1 @@ -39,7 +41,28 @@ ans(kk, 2) = jj END DO END DO - !! +!! +!! right diagonal +!! +! DO ii = 0, order +! DO jj = 0, order - ii +! kk = kk + 1 +! ans(kk, 1) = ii +! ans(kk, 2) = jj +! END DO +! END DO +!! +!! +!! base +!! +! DO ii = 0, order +! DO jj = 0, ii +! kk = kk + 1 +! ans(kk, 1) = ii-jj +! ans(kk, 2) = jj +! END DO +! END DO +!! END PROCEDURE LagrangeDegree_Triangle !---------------------------------------------------------------------------- @@ -231,22 +254,348 @@ !! END PROCEDURE EquidistanceInPoint_Triangle +!---------------------------------------------------------------------------- +! BlythPozrikidis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BlythPozrikidis_Triangle +REAL(DFP) :: v(order + 1), xi(order + 1, order + 1), eta(order + 1, order + 1) +REAL(DFP), ALLOCATABLE :: temp(:, :) +INTEGER(I4B) :: nsd, N, ii, jj, kk +CHARACTER(LEN=*), PARAMETER :: myName = "BlythPozrikidis_Triangle" +!! +v = InterpolationPoint_Line(order=order, ipType=ipType, & + & xij=[0.0_DFP, 1.0_DFP], layout="INCREASING") +!! +N = LagrangeDOF_Triangle(order=order) +!! +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) +ELSE + nsd = 2 +END IF +!! +CALL Reallocate(ans, nsd, N) +CALL Reallocate(temp, 2, N) +!! +xi = 0.0_DFP +eta = 0.0_DFP +!! +DO ii = 1, order + 1 + DO jj = 1, order + 2 - ii + kk = order + 3 - ii - jj + xi(ii, jj) = (1.0 + 2.0 * v(ii) - v(jj) - v(kk)) / 3.0_DFP + eta(ii, jj) = (1.0 + 2.0 * v(jj) - v(ii) - v(kk)) / 3.0_DFP + END DO +END DO +!! +IF (layout .EQ. "VEFC") THEN + !! + CALL IJ2VEFC(xi=xi, eta=eta, temp=temp, order=order, N=N, myname=myname) + !! + IF (PRESENT(xij)) THEN + ans = FromUnitTriangle2Triangle(xin=temp, & + & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3)) + END IF + !! +ELSE + CALL ErrorMsg( & + & msg="Only layout=VEFC is allowed, given layout is " & + & //TRIM(layout), & + & file=__FILE__, & + & routine=myname, & + & line=__LINE__, & + & unitno=stderr) + STOP +END IF +!! +IF (ALLOCATED(temp)) DEALLOCATE (temp) +!! +END PROCEDURE BlythPozrikidis_Triangle + +!---------------------------------------------------------------------------- +! BlythPozrikidis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Isaac_Triangle +REAL(DFP) :: xi(order + 1, order + 1), eta(order + 1, order + 1) +REAL(DFP), ALLOCATABLE :: temp(:, :), rPoints(:, :) +INTEGER(I4B) :: nsd, N, cnt, ii, jj +CHARACTER(LEN=*), PARAMETER :: myName = "Isaac_Triangle" +!! +rPoints = RecursiveNode2D(order=order, ipType=ipType) +N = SIZE(rPoints, 2) +!! +IF (PRESENT(xij)) THEN + nsd = SIZE(xij, 1) +ELSE + nsd = 2 +END IF +!! +CALL Reallocate(ans, nsd, N) +!! +!! convert from rPoints to xi and eta +!! +cnt = 0 +xi = 0.0_DFP +eta = 0.0_DFP +!! +DO ii = 1, order + 1 + DO jj = 1, order + 2 - ii + cnt = cnt + 1 + xi(ii, jj) = rPoints(1, cnt) + eta(ii, jj) = rPoints(2, cnt) + END DO +END DO +!! +IF (layout .EQ. "VEFC") THEN + !! + CALL Reallocate(temp, 2, N) + CALL IJ2VEFC(xi=xi, eta=eta, temp=temp, order=order, N=N, myname=myname) + !! + IF (PRESENT(xij)) THEN + ans = FromUnitTriangle2Triangle(xin=temp, & + & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3)) + END IF + !! +ELSE + CALL ErrorMsg( & + & msg="Only layout=VEFC is allowed, given layout is " & + & //TRIM(layout), & + & file=__FILE__, & + & routine=myname, & + & line=__LINE__, & + & unitno=stderr) + STOP +END IF +!! +IF (ALLOCATED(temp)) DEALLOCATE (temp) +IF (ALLOCATED(rPoints)) DEALLOCATE (rPoints) +!! +END PROCEDURE Isaac_Triangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +SUBROUTINE IJ2VEFC(xi, eta, temp, order, N, myname) + REAL(DFP), INTENT(IN) :: xi(:, :) + REAL(DFP), INTENT(IN) :: eta(:, :) + REAL(DFP), INTENT(OUT) :: temp(:, :) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B), INTENT(IN) :: N + CHARACTER(LEN=*), INTENT(IN) :: myname + !! + INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, llt, llr + !! + !! vertices + !! + cnt = 0 + m = order + llt = INT((m - 1) / 3) + llr = MOD(m - 1, 3) + DO ll = 0, llt + !! + !! v1 + !! + cnt = cnt + 1 + ii = 1 + ll; jj = 1 + ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + !! + !! v2 + !! + cnt = cnt + 1 + ii = m + 1 - 2 * ll; jj = 1 + ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + !! + !! v3 + !! + cnt = cnt + 1 + ii = 1 + ll; jj = m + 1 - 2 * ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + !! + !! nodes on edge 12 + !! + jj = ll + 1 + DO ii = 2 + ll, m - 2 * ll + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + !! + !! nodes on edge 23 + !! + DO jj = 2 + ll, m - 2 * ll + cnt = cnt + 1 + ii = m - ll + 2 - jj + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + !! + !! nodes on edge 31 + !! + ii = ll + 1 + DO jj = m - 2 * ll, 2 + ll, -1 + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + !! + !! internal nodes + !! + END DO + !! + IF (llr .EQ. 2_I4B) THEN + !! + !! a internal point + !! + cnt = cnt + 1 + ll = llt + 1 + ii = 1 + ll; jj = 1 + ll + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END IF + !! + IF (cnt .NE. N) THEN + CALL ErrorMsg( & + & msg="cnt="//tostring(cnt)//" not equal to total DOF, N=" & + & //tostring(N), & + & file=__FILE__, & + & routine=myname, & + & line=__LINE__, & + & unitno=stderr) + STOP + END IF +END SUBROUTINE IJ2VEFC + !---------------------------------------------------------------------------- ! InterpolationPoint_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Triangle +CHARACTER(LEN=*), PARAMETER :: myName = "InterpolationPoint_Triangle" SELECT CASE (ipType) CASE (Equidistance) - nodecoord = EquidistancePoint_Triangle(xij=xij, order=order) -CASE (GaussLegendre) -CASE (GaussLobatto) -CASE (Chebyshev) + ans = EquidistancePoint_Triangle(xij=xij, order=order) +CASE (Feket, Hesthaven, ChenBabuska) + CALL ErrorMsg(msg="Feket, Hesthaven, ChenBabuska nodes not available", & + & file=__FILE__, & + & routine=myname, & + & line=__LINE__, & + & unitno=stderr) + STOP +CASE (BlythPozLegendre) + ans = BlythPozrikidis_Triangle(order=order, & + & ipType=GaussLegendreLobatto, & + & layout="VEFC", xij=xij) +CASE (BlythPozChebyshev) + ans = BlythPozrikidis_Triangle(order=order, & + & ipType=GaussChebyshevLobatto, & + & layout="VEFC", xij=xij) +CASE (GaussLegendreLobatto, IsaacLegendre) + ans = Isaac_Triangle(order=order, ipType=GaussLegendreLobatto, & + & layout="VEFC", xij=xij) +CASE (GaussChebyshevLobatto, IsaacChebyshev) + ans = Isaac_Triangle(order=order, ipType=GaussChebyshevLobatto, & + & layout="VEFC", xij=xij) END SELECT END PROCEDURE InterpolationPoint_Triangle !---------------------------------------------------------------------------- -! +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle1 +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info +!! +ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP +V = LagrangeVandermonde(order=order, xij=xij, elemType=Triangle) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info) +!! +END PROCEDURE LagrangeCoeff_Triangle1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle2 +!! +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info +!! +vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Triangle2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle3 +INTEGER(I4B) :: info +ans = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Triangle3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle !---------------------------------------------------------------------------- +MODULE PROCEDURE LagrangeCoeff_Triangle4 +ans = LagrangeVandermonde(order=order, xij=xij, elemType=Triangle) +CALL GetInvMat(ans) +END PROCEDURE LagrangeCoeff_Triangle4 + +!---------------------------------------------------------------------------- +! Dubiner_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Triangle1 +CHARACTER(LEN=20) :: layout +REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) +!! +layout = TRIM(UpperCase(refTriangle)) +!! +SELECT CASE (TRIM(layout)) +CASE ("BIUNIT") + x = FromBiUnitTriangle2BiUnitSqr(xin=xij) +CASE ("UNIT") + x = FromUnitTriangle2BiUnitSqr(xin=xij) +END SELECT +!! +ans = Dubiner_Quadrangle(order=order, xij=x) +!! +END PROCEDURE Dubiner_Triangle1 + +!---------------------------------------------------------------------------- +! Dubiner_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Triangle2 +CHARACTER(LEN=20) :: layout +REAL(DFP) :: x0(SIZE(x)), y0(SIZE(y)) +!! +layout = TRIM(UpperCase(refTriangle)) +!! +SELECT CASE (TRIM(layout)) +CASE ("BIUNIT") + x0 = x + y0 = y +CASE ("UNIT") + x0 = FromUnitLine2BiUnitLine(xin=x) + y0 = FromUnitLine2BiUnitLine(xin=y) +END SELECT +!! +ans = Dubiner_Quadrangle(order=order, x=x0, y=y0) +!! +END PROCEDURE Dubiner_Triangle2 + END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 new file mode 100644 index 000000000..666ea6114 --- /dev/null +++ b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 @@ -0,0 +1,1189 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modIFy +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. IF not, see +! + +SUBMODULE(UltrasphericalPolynomialUtility) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! UltrasphericalAlpha +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalAlpha +ans = 0.0_DFP +END PROCEDURE UltrasphericalAlpha + +!---------------------------------------------------------------------------- +! UltrasphericalBeta +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalBeta +REAL(DFP) :: avar, bvar +!! +SELECT CASE (n) +CASE (0_I4B) + avar = pi * GAMMA(2.0_DFP * lambda) + bvar = (GAMMA(lambda))**2 * lambda * 2.0_DFP**(2.0_DFP * lambda - 1.0_DFP) + ans = avar / bvar +CASE (1_I4B) + ans = 0.5_DFP / (1.0_DFP + lambda) +CASE DEFAULT + avar = n * (2.0_DFP * lambda + n - 1.0_DFP) + bvar = 4.0_DFP * (n + lambda) * (n + lambda - 1.0_DFP) + ans = avar / bvar +END SELECT +END PROCEDURE UltrasphericalBeta + +!---------------------------------------------------------------------------- +! GetUltrasphericalRecurrenceCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetUltrasphericalRecurrenceCoeff +REAL(DFP) :: avar, bvar +INTEGER(I4B) :: ii +!! +IF (n .LE. 0) RETURN +!! +alphaCoeff = 0.0_DFP +!! +avar = pi * GAMMA(2.0_DFP * lambda) +bvar = (GAMMA(lambda))**2 * lambda * 2.0_DFP**(2.0_DFP * lambda - 1.0_DFP) +betaCoeff(0) = avar / bvar +!! +IF (n .EQ. 1) RETURN +!! +betaCoeff(1) = 0.5_DFP / (1.0_DFP + lambda) +!! +IF (n .EQ. 2) RETURN +!! +DO ii = 2, n - 1 + avar = ii * (2.0_DFP * lambda + ii - 1.0_DFP) + bvar = 4.0_DFP * (ii + lambda) * (ii + lambda - 1.0_DFP) + betaCoeff(ii) = avar / bvar +END DO +!! +END PROCEDURE GetUltrasphericalRecurrenceCoeff + +!---------------------------------------------------------------------------- +! GetUltrasphericalRecurrenceCoeff2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetUltrasphericalRecurrenceCoeff2 +REAL(DFP) :: j +INTEGER(I4B) :: ii +!! +IF (n .LT. 1) RETURN +B = 0.0_DFP +!! +DO ii = 1, n + j = REAL(ii, KIND=DFP) + A(ii - 1) = 2 * (j + lambda - 1) / j; + C(ii - 1) = (j + 2 * lambda - 2) / j; +END DO +!! +END PROCEDURE GetUltrasphericalRecurrenceCoeff2 + +!---------------------------------------------------------------------------- +! UltrasphericalLeadingCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalLeadingCoeff +REAL(DFP) :: a1, a2 +a1 = (2.0_DFP**n) * GAMMA(n + lambda) +a2 = Factorial(n) * GAMMA(lambda) +ans = a1 / a2 +END PROCEDURE UltrasphericalLeadingCoeff + +!---------------------------------------------------------------------------- +! UltrasphericalLeadingCoeffRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalLeadingCoeffRatio +ans = 2.0_DFP * (n + lambda) / (n + 1.0_DFP) +END PROCEDURE UltrasphericalLeadingCoeffRatio + +!---------------------------------------------------------------------------- +! UltrasphericalNormSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalNormSqr +REAL(DFP) :: a1, a2 +a1 = 2.0_DFP**(1.0_DFP - 2.0_DFP * lambda) * pi * GAMMA(n + 2.0_DFP * lambda) +a2 = GAMMA(lambda)**2 * (n + lambda) * Factorial(n) +ans = a1 / a2 +END PROCEDURE UltrasphericalNormSqr + +!---------------------------------------------------------------------------- +! UltrasphericalNormSqrRatio +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalNormSqrRatio +REAL(DFP) :: a1, a2 +a1 = (n + lambda) * (n + 2.0_DFP * lambda) +a2 = (n + 1.0_DFP) * (n + lambda + 1.0_DFP) +ans = a1 / a2 +END PROCEDURE UltrasphericalNormSqrRatio + +!---------------------------------------------------------------------------- +! UltrasphericalNormSqr2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalNormSqr2 +REAL(DFP) :: rn, s +INTEGER(I4B) :: ii +!! +ans(0) = UltrasphericalNormSQR(n=0_I4B, lambda=lambda) +!! +IF (n .EQ. 0) RETURN +!! +s = UltrasphericalNormSQRRatio(n=0_I4B, lambda=lambda) +ans(1) = ans(0) * s +!! +DO ii = 1, n - 1 + rn = REAL(ii, KIND=DFP) + s = (rn + lambda) * (rn + 2.0_DFP * lambda) / (rn + 1.0_DFP) & + & / (rn + lambda + 1.0_DFP) + ans(ii + 1) = s * ans(ii) +END DO +END PROCEDURE UltrasphericalNormSqr2 + +!---------------------------------------------------------------------------- +! UltrasphericalJacobiMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalJacobiMatrix +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiJacobiMatrix(n=n, alpha=alpha, beta=alpha, D=D, E=E, & + & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE UltrasphericalJacobiMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalGaussQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGaussQuadrature +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiGaussQuadrature(n=n, alpha=alpha, beta=alpha, pt=pt, wt=wt) +END PROCEDURE UltrasphericalGaussQuadrature + +!---------------------------------------------------------------------------- +! UltrasphericalJacobiRadauMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalJacobiRadauMatrix +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiJacobiRadauMatrix(a=a, n=n, alpha=alpha, beta=alpha, D=D, E=E, & + & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE UltrasphericalJacobiRadauMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalGaussRadauQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGaussRadauQuadrature +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiGaussRadauQuadrature(a=a, n=n, alpha=alpha, beta=alpha, & + & pt=pt, wt=wt) +END PROCEDURE UltrasphericalGaussRadauQuadrature + +!---------------------------------------------------------------------------- +! UltrasphericalJacobiLobattoMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalJacobiLobattoMatrix +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiJacobiLobattoMatrix(n=n, alpha=alpha, beta=alpha, D=D, E=E, & + & alphaCoeff=alphaCoeff, betaCoeff=betaCoeff) +END PROCEDURE UltrasphericalJacobiLobattoMatrix + +!---------------------------------------------------------------------------- +! UltrasphericalGaussLobattoQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGaussLobattoQuadrature +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +CALL JacobiGaussLobattoQuadrature(n=n, alpha=alpha, beta=alpha, & + & pt=pt, wt=wt) +END PROCEDURE UltrasphericalGaussLobattoQuadrature + +!---------------------------------------------------------------------------- +! UltrasphericalZeros +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalZeros +REAL(DFP) :: alpha +alpha = lambda - 0.5_DFP +ans = JacobiZeros(alpha=alpha, beta=alpha, n=n) +END PROCEDURE UltrasphericalZeros + +!---------------------------------------------------------------------------- +! UltrasphericalQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalQuadrature +INTEGER(I4B) :: order +REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP +REAL(DFP), ALLOCATABLE :: p(:), w(:) +LOGICAL(LGT) :: inside +!! +IF (PRESENT(onlyInside)) THEN + inside = onlyInside +ELSE + inside = .FALSE. +END IF +!! +SELECT CASE (QuadType) +CASE (Gauss) + !! + order = n + CALL UltrasphericalGaussQuadrature(n=order, lambda=lambda, pt=pt, wt=wt) + !! +CASE (GaussRadau, GaussRadauLeft) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL UltrasphericalGaussRadauQuadrature(a=left, lambda=lambda, & + & n=order, pt=p, wt=w) + pt = p(2:); wt = w(2:) + DEALLOCATE (p, w) + ELSE + order = n - 1 + CALL UltrasphericalGaussRadauQuadrature(a=left, lambda=lambda, & + & n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussRadauRight) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 1), w(n + 1)) + CALL UltrasphericalGaussRadauQuadrature(a=right, lambda=lambda, & + & n=order, pt=p, wt=w) + pt = p(1:n); wt = w(1:n) + ELSE + order = n - 1 + CALL UltrasphericalGaussRadauQuadrature(a=right, lambda=lambda, & + & n=order, pt=pt, wt=wt) + END IF + !! +CASE (GaussLobatto) + !! + IF (inside) THEN + order = n + ALLOCATE (p(n + 2), w(n + 2)) + CALL UltrasphericalGaussLobattoQuadrature(n=order, lambda=lambda, & + & pt=p, wt=w) + pt = p(2:n + 1); wt = w(2:n + 1) + ELSE + order = n - 2 + CALL UltrasphericalGaussLobattoQuadrature(n=order, lambda=lambda, & + & pt=pt, wt=wt) + END IF +END SELECT +END PROCEDURE UltrasphericalQuadrature + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEval1 +INTEGER(I4B) :: ii +REAL(DFP) :: c1, c2, c3, r_ii, ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans = 2.0_DFP * lambda * x +IF (n .EQ. 1) RETURN +!! +DO ii = 1, n - 1 + !! + r_ii = REAL(ii, kind=DFP) + c1 = r_ii + 1.0_DFP + c2 = 2.0_DFP * (r_ii + lambda) + c3 = -(2.0_DFP * lambda + r_ii - 1.0_DFP) + !! + ans_1 = ans + ans = ((c2 * x) * ans + c3 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE UltrasphericalEval1 + +!---------------------------------------------------------------------------- +! UltrasphericalEval +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEval2 +INTEGER(I4B) :: ii +REAL(DFP) :: c1, c2, c3, r_ii +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans = 1.0_DFP +ans_2 = ans +!! +IF (n .EQ. 0) RETURN +!! +ans = 2.0_DFP * lambda * x +!! +IF (n .EQ. 1) RETURN +!! +DO ii = 1, n - 1 + !! + r_ii = REAL(ii, kind=DFP) + c1 = r_ii + 1.0_DFP + c2 = 2.0_DFP * (r_ii + lambda) + c3 = -(2.0_DFP * lambda + r_ii - 1.0_DFP) + !! + ans_1 = ans + ans = ((c2 * x) * ans + c3 * ans_2) / c1 + ans_2 = ans_1 + !! +END DO +END PROCEDURE UltrasphericalEval2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEvalAll1 +INTEGER(I4B) :: ii +REAL(DFP) :: c1, c2, c3, r_ii +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(2) = 2.0_DFP * lambda * x +!! +DO ii = 2, n + !! + r_ii = real(ii, kind=DFP) + c1 = r_ii + c2 = 2.0_DFP * (r_ii + lambda - 1.0_DFP) + c3 = -(2.0_DFP * lambda + r_ii - 2.0_DFP) + !! + ans(ii + 1) = ((c2 * x) * ans(ii) + c3 * ans(ii - 1)) / c1 + !! +END DO +!! +END PROCEDURE UltrasphericalEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEvalAll2 +INTEGER(I4B) :: ii +REAL(DFP) :: c1, c2, c3, r_ii +!! +ans = 0.0_DFP +!! +IF (n < 0) THEN + RETURN +END IF +!! +ans(:, 1) = 1.0_DFP +!! +IF (n .EQ. 0) THEN + RETURN +END IF +!! +ans(:, 2) = 2.0_DFP * lambda * x +!! +DO ii = 2, n + !! + r_ii = real(ii, kind=DFP) + c1 = r_ii + c2 = 2.0_DFP * (r_ii + lambda - 1.0_DFP) + c3 = -(2.0_DFP * lambda + r_ii - 2.0_DFP) + !! + ans(:, ii + 1) = ((c2 * x) * ans(:, ii) + c3 * ans(:, ii - 1)) / c1 + !! +END DO +END PROCEDURE UltrasphericalEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalAll1 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p(1:n + 1) +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(1) = 1.0_DFP +ans(1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +p(2) = 2.0_DFP * lambda * x +ans(2) = 2.0_DFP * lambda +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p(ii + 1) = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p(ii) & + & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p(ii - 1)) & + & / r_ii + !! + ans(ii + 1) = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p(ii) + ans(ii - 1) + !! +END DO +!! +END PROCEDURE UltrasphericalGradientEvalAll1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalAll2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p(1:SIZE(x), 1:n + 1) +!! +IF (n < 0) THEN + RETURN +END IF +!! +p(:, 1) = 1.0_DFP +ans(:, 1) = 0.0_DFP +!! +IF (n < 1) THEN + RETURN +END IF +!! +p(:, 2) = 2.0_DFP * lambda * x +ans(:, 2) = 2.0_DFP * lambda +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p(:, ii + 1) = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p(:, ii) & + & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p(:, ii - 1)) & + & / r_ii + !! + ans(:, ii + 1) = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p(:, ii) & + & + ans(:, ii - 1) + !! +END DO +!! +END PROCEDURE UltrasphericalGradientEvalAll2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEval1 + !! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP) :: p, p_1, p_2 +REAL(DFP) :: ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +p = 2.0_DFP * lambda * x +ans = 2.0_DFP * lambda +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + p = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p & + & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p_2) & + & / r_ii + !! + p_2 = p_1 + !! + ans_1 = ans + ans = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p_1 + ans_2 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE UltrasphericalGradientEval1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEval2 +!! +INTEGER(I4B) :: ii +REAL(DFP) :: r_ii +REAL(DFP), DIMENSION(SIZE(x)) :: p, p_1, p_2 +REAL(DFP), DIMENSION(SIZE(x)) :: ans_1, ans_2 +!! +IF (n < 0) THEN + RETURN +END IF +!! +p = 1.0_DFP +ans = 0.0_DFP +p_2 = p +ans_2 = ans +!! +IF (n < 1) THEN + RETURN +END IF +!! +p = 2.0_DFP * lambda * x +ans = 2.0_DFP * lambda +!! +DO ii = 2, n + !! + r_ii = REAL(ii, KIND=DFP) + !! + p_1 = p + !! + p = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p & + & - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p_2) & + & / r_ii + !! + p_2 = p_1 + !! + ans_1 = ans + ans = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p_1 + ans_2 + ans_2 = ans_1 + !! +END DO +!! +END PROCEDURE UltrasphericalGradientEval2 + +!---------------------------------------------------------------------------- +! UltrasphericalEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEvalSum1 +REAL(DFP) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP), DIMENSION(0:n + 1) :: A, B, C +!! +IF (n .LT. 0) RETURN +IF (lambda .LE. -0.5_DFP) RETURN +IF (lambda .EQ. 0.0_DFP) RETURN +!! +CALL GetUltrasphericalRecurrenceCoeff2(n=n + 2, lambda=lambda, A=A, B=B, C=C) +!! +b1 = 0.0_DFP +b2 = 0.0_DFP +!! +DO j = n, 0, -1 + t = (A(j) * x) * b1 - C(j + 1) * b2 + coeff(j); + b2 = b1 + b1 = t +END DO +!! +ans = b1 +!! +END PROCEDURE UltrasphericalEvalSum1 + +!---------------------------------------------------------------------------- +! UltrasphericalEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalEvalSum2 +REAL(DFP), DIMENSION(SIZE(x)) :: t, b1, b2 +INTEGER(I4B) :: j +REAL(DFP), DIMENSION(0:n + 1) :: A, B, C +!! +IF (n .LT. 0) RETURN +IF (lambda .LE. -0.5_DFP) RETURN +IF (lambda .EQ. 0.0_DFP) RETURN +!! +CALL GetUltrasphericalRecurrenceCoeff2(n=n + 2, lambda=lambda, A=A, B=B, C=C) +!! +b1 = 0.0_DFP +b2 = 0.0_DFP +!! +DO j = n, 0, -1 + t = (A(j) * x) * b1 - C(j + 1) * b2 + coeff(j); + b2 = b1 + b1 = t +END DO +!! +ans = b1 +!! +END PROCEDURE UltrasphericalEvalSum2 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalSum1 +REAL(DFP) :: t, b1, b2 +REAL(DFP) :: A1, A2 +INTEGER(I4B) :: i +REAL(DFP) :: j +REAL(DFP) :: c +!! +IF (n .LT. 0) RETURN +IF (lambda .LE. -0.5_DFP) RETURN +IF (lambda .EQ. 0.0_DFP) RETURN +!! +c = 2 * lambda; +b1 = 0 +b2 = 0 +!! +DO i = n - 1, 0, -1 + j = REAL(i, KIND=DFP) + A1 = 2 * (j + 1 + lambda) * x / (j + 1) + A2 = -(j + 2 * lambda + 2) / (j + 2) + t = A1 * b1 + A2 * b2 + coeff(i + 1) + b2 = b1 + b1 = t +END DO +ans = C * b1 +END PROCEDURE UltrasphericalGradientEvalSum1 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalSum2 +REAL(DFP) :: A2 +REAL(DFP), DIMENSION(SIZE(x)) :: A1, t, b1, b2 +INTEGER(I4B) :: i +REAL(DFP) :: j +REAL(DFP) :: c +!! +IF (n .LT. 0) RETURN +IF (lambda .LE. -0.5_DFP) RETURN +IF (lambda .EQ. 0.0_DFP) RETURN +!! +c = 2 * lambda; +b1 = 0 +b2 = 0 +!! +DO i = n - 1, 0, -1 + j = REAL(i, KIND=DFP) + A1 = 2 * (j + 1 + lambda) * x / (j + 1) + A2 = -(j + 2 * lambda + 2) / (j + 2) + t = A1 * b1 + A2 * b2 + coeff(i + 1) + b2 = b1 + b1 = t +END DO +ans = C * b1 +END PROCEDURE UltrasphericalGradientEvalSum2 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalSum3 +REAL(DFP) :: t, b1, b2, s +REAL(DFP) :: A1, A2 +INTEGER(I4B) :: i +REAL(DFP) :: j +!! +IF (n .LT. 0) RETURN +IF (lambda .LE. -0.5_DFP) RETURN +IF (lambda .EQ. 0.0_DFP) RETURN +!! +s = 1.0_DFP +DO i = 1, k + s = 2 * s * (lambda + i - 1); +END DO +!! +b1 = 0 +b2 = 0 +!! +DO i = n - k, 0, -1 + j = REAL(i, KIND=DFP) + A1 = 2 * (j + k + lambda) * x / (j + 1); + A2 = -(j + 2 * lambda + 2 * k) / (j + 2); + t = A1 * b1 + A2 * b2 + coeff(i + k); + b2 = b1; + b1 = t; +END DO +ans = s * b1 +END PROCEDURE UltrasphericalGradientEvalSum3 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientEvalSum +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientEvalSum4 +REAL(DFP) :: A2, s +REAL(DFP), DIMENSION(SIZE(x)) :: A1, b1, b2, t +INTEGER(I4B) :: i +REAL(DFP) :: j +!! +IF (n .LT. 0) RETURN +IF (lambda .LE. -0.5_DFP) RETURN +IF (lambda .EQ. 0.0_DFP) RETURN +!! +s = 1.0_DFP +DO i = 1, k + s = 2 * s * (lambda + i - 1); +END DO +!! +b1 = 0 +b2 = 0 +!! +DO i = n - k, 0, -1 + j = REAL(i, KIND=DFP) + A1 = 2 * (j + k + lambda) * x / (j + 1); + A2 = -(j + 2 * lambda + 2 * k) / (j + 2); + t = A1 * b1 + A2 * b2 + coeff(i + k); + b2 = b1; + b1 = t; +END DO +ans = s * b1 +END PROCEDURE UltrasphericalGradientEvalSum4 + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalTransform1 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj +REAL(DFP) :: rn +!! +nrmsqr = UltrasphericalNormSQR2(n=n, lambda=lambda) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = 2.0_DFP * (rn + lambda) / rn * nrmsqr(n) +END IF +!! +PP = UltrasphericalEvalAll(n=n, lambda=lambda, x=x) +!! +DO jj = 0, n + temp = PP(:, jj) * w * coeff + ans(jj) = SUM(temp) / nrmsqr(jj) +END DO +!! +END PROCEDURE UltrasphericalTransform1 + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalTransform2 +REAL(DFP), DIMENSION(0:n) :: nrmsqr, temp +REAL(DFP), DIMENSION(0:n, 0:n) :: PP +INTEGER(I4B) :: jj, kk +REAL(DFP) :: rn +!! +nrmsqr = UltrasphericalNormSQR2(n=n, lambda=lambda) +!! +!! Correct nrmsqr(n) +!! +rn = REAL(n, KIND=DFP) +!! +IF (quadType .EQ. GaussLobatto) THEN + nrmsqr(n) = 2.0_DFP * (rn + lambda) / rn * nrmsqr(n) +END IF +!! +PP = UltrasphericalEvalAll(n=n, lambda=lambda, x=x) +!! +DO kk = 1, SIZE(coeff, 2) + DO jj = 0, n + temp = PP(:, jj) * w * coeff(:, kk) + ans(jj, kk) = SUM(temp) / nrmsqr(jj) + END DO +END DO +!! +END PROCEDURE UltrasphericalTransform2 + +!---------------------------------------------------------------------------- +! UltrasphericalTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalTransform3 +REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n) +INTEGER(I4B) :: ii +!! +CALL UltrasphericalQuadrature(n=n + 1, lambda=lambda, pt=pt, wt=wt,& + & quadType=quadType) +!! +DO ii = 0, n + coeff(ii) = f(pt(ii)) +END DO +!! +ans = UltrasphericalTransform(n=n, lambda=lambda, coeff=coeff, x=pt, & + & w=wt, quadType=quadType) +!! +END PROCEDURE UltrasphericalTransform3 + +!---------------------------------------------------------------------------- +! UltrasphericalInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalInvTransform1 +ans = UltrasphericalEvalSum(n=n, lambda=lambda, coeff=coeff, & + & x=x) +END PROCEDURE UltrasphericalInvTransform1 + +!---------------------------------------------------------------------------- +! UltrasphericalInvTransform +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalInvTransform2 +ans = UltrasphericalEvalSum(n=n, lambda=lambda, coeff=coeff, & + & x=x) +END PROCEDURE UltrasphericalInvTransform2 + +!---------------------------------------------------------------------------- +! UltrasphericalGradientCoeff +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalGradientCoeff1 +REAL(DFP) :: a, b, c +INTEGER(I4B) :: ii +REAL(DFP) :: jj +!! +ans(n) = 0.0_DFP +IF (n .EQ. 0) RETURN +!! +ans(n - 1) = 2.0 * (n + lambda - 1.0_DFP) * coeff(n) +!! +DO ii = n - 1, 1, -1 + jj = REAL(ii, KIND=DFP) + a = jj + lambda - 1.0_DFP + b = jj + lambda + 1.0_DFP + c = a / b + ans(ii - 1) = 2.0_DFP * a * coeff(ii) + c * ans(ii + 1) +END DO +!! +END PROCEDURE UltrasphericalGradientCoeff1 + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalDMatrix1 +SELECT CASE (quadType) +CASE (GaussLobatto) + CALL UltrasphericalDMatrixGL2(n=n, lambda=lambda, x=x,& + & D=ans) +CASE (Gauss) + CALL UltrasphericalDMatrixG2(n=n, lambda=lambda, x=x, & + & D=ans) +END SELECT +END PROCEDURE UltrasphericalDMatrix1 + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE UltrasphericalDMatrixGL(n, lambda, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: rn + INTEGER(I4B) :: ii, jj, nb2 + !! + nb2 = int(n / 2) + rn = REAL(n, KIND=DFP) + !! + J = UltrasphericalEval(n=n, lambda=lambda, x=x) + !! + !! first col + !! + D(0, 0) = (lambda - 0.5_DFP - rn * (rn + 2.0 * lambda)) / & + & (2.0 * lambda + 3.0) + DO ii = 1, n + D(ii, 0) = (lambda + 0.5) * J(ii) / (x(ii) + 1.0) / J(0) + END DO + !! + !! last col + !! + DO ii = 0, n - 1 + D(ii, n) = (lambda + 0.5) * J(ii) / (x(ii) - 1.0) / J(n) + END DO + D(n, n) = -D(0, 0) + !! + !! internal column + !! + DO jj = 1, n - 1 + DO ii = 0, n + IF (ii .EQ. jj) THEN + D(ii, ii) = (lambda - 0.5) * x(ii) / (1.0 - x(ii)**2) + ELSE + D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END IF + END DO + END DO + !! +END SUBROUTINE UltrasphericalDMatrixGL + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrixGL +!---------------------------------------------------------------------------- + +PURE SUBROUTINE UltrasphericalDMatrixGL2(n, lambda, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + REAL(DFP) :: rn + INTEGER(I4B) :: ii, jj, nb2 + !! + nb2 = int(n / 2) + rn = REAL(n, KIND=DFP) + !! + J = UltrasphericalEval(n=n, lambda=lambda, x=x) + D = 0.0_DFP + !! + !! first col + !! + !D(0, 0) = (lambda - 0.5_DFP - rn * (rn + 2.0 * lambda)) / & + ! & (2.0 * lambda + 3.0) + DO ii = 1, nb2 + D(ii, 0) = (lambda + 0.5) * J(ii) / (x(ii) + 1.0) / J(0) + END DO + !! + !! last col + !! + DO ii = 0, nb2 + D(ii, n) = (lambda + 0.5) * J(ii) / (x(ii) - 1.0) / J(n) + END DO + !! + !! internal column + !! + DO jj = 1, n - 1 + DO ii = 0, nb2 + IF (ii .NE. jj) & !THEN + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + ! ELSE + ! D(ii, ii) = (lambda - 0.5) * x(ii) / (1.0 - x(ii)**2) + !END IF + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = -SUM(D(ii, :)) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE UltrasphericalDMatrixGL2 + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE UltrasphericalDMatrixG(n, lambda, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + INTEGER(I4B) :: ii, jj + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! + J = UltrasphericalGradientEval(n=n + 1, lambda=lambda, x=x) + !! + DO jj = 0, n + DO ii = 0, n + IF (ii .EQ. jj) THEN + D(ii, ii) = (lambda + 0.5_DFP) * x(ii) / (1.0 - x(ii)**2) + ELSE + D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END IF + END DO + END DO +!! +END SUBROUTINE UltrasphericalDMatrixG + +!---------------------------------------------------------------------------- +! UltrasphericalDMatrixG +!---------------------------------------------------------------------------- + +PURE SUBROUTINE UltrasphericalDMatrixG2(n, lambda, x, D) + INTEGER(I4B), INTENT(IN) :: n + !! order of Jacobi polynomial + REAL(DFP), INTENT(IN) :: lambda + !! $\lambda > -0.5, \lambda \ne 0.0$ + REAL(DFP), INTENT(IN) :: x(0:n) + !! quadrature points + REAL(DFP), INTENT(OUT) :: D(0:n, 0:n) + !! D matrix + !! + !! main + !! + REAL(DFP) :: J(0:n) + INTEGER(I4B) :: ii, jj, nb2 + !! + !! Compute dJ_{N-1}(a+1,b+1) + !! + nb2 = int(n / 2) + !! + J = UltrasphericalGradientEval(n=n + 1, lambda=lambda, x=x) + !! + DO jj = 0, n + DO ii = 0, nb2 + IF (ii .NE. jj) & + & D(ii, jj) = J(ii) / J(jj) / (x(ii) - x(jj)) + END DO + END DO + !! + !! correct diagonal entries + !! + DO ii = 0, nb2 + D(ii, ii) = -SUM(D(ii, :)) + END DO + !! + !! copy + !! + DO jj = 0, n + DO ii = 0, nb2 + D(n - ii, n - jj) = -D(ii, jj) + END DO + END DO + !! +END SUBROUTINE UltrasphericalDMatrixG2 + +!---------------------------------------------------------------------------- +! UltrasphericalDMatEvenOdd +!---------------------------------------------------------------------------- + +MODULE PROCEDURE UltrasphericalDMatEvenOdd1 +INTEGER(I4B) :: ii, jj, n1, n2 + !! +IF (MOD(N, 2) .EQ. 0) THEN + !! even + !! + n1 = int(n / 2) - 1 + !! + DO jj = 0, n1 + DO ii = 0, n1 + e(ii, jj) = D(ii, jj) + D(ii, n - jj) + o(ii, jj) = D(ii, jj) - D(ii, n - jj) + END DO + END DO + !! + n2 = n1 + 1 + e(1:n1, n2) = D(1:n1, n2) + o(n2, 1:n1) = D(n2, 1:n1) - D(n2, 1:n1) + !! +ELSE + !! odd + n2 = (n - 1) / 2 + n1 = n2 + !! + DO jj = 0, n2 + DO ii = 0, n1 + e(ii, jj) = D(ii, jj) + D(ii, n - jj) + o(ii, jj) = D(ii, jj) - D(ii, n - jj) + END DO + END DO + !! +END IF +END PROCEDURE UltrasphericalDMatEvenOdd1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods From 8ace540a93fb6c4cd6cdb43cf397b03b09445c1e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Oct 2022 14:47:17 +0900 Subject: [PATCH 41/43] undefined --- src/submodules/Utility/CMakeLists.txt | 2 + .../Utility/src/InvUtility@Methods.F90 | 2 +- .../Utility/src/MappingUtility@Methods.F90 | 105 ++++++++ .../Utility/src/ZerosUtility@Methods.F90 | 253 ++++++++++++++++++ 4 files changed, 361 insertions(+), 1 deletion(-) create mode 100644 src/submodules/Utility/src/MappingUtility@Methods.F90 create mode 100644 src/submodules/Utility/src/ZerosUtility@Methods.F90 diff --git a/src/submodules/Utility/CMakeLists.txt b/src/submodules/Utility/CMakeLists.txt index 76c9371ce..ca91752ac 100644 --- a/src/submodules/Utility/CMakeLists.txt +++ b/src/submodules/Utility/CMakeLists.txt @@ -18,6 +18,7 @@ SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") TARGET_SOURCES( ${PROJECT_NAME} PRIVATE + ${src_path}/MappingUtility@Methods.F90 ${src_path}/BinomUtility@Methods.F90 ${src_path}/SortUtility@Methods.F90 ${src_path}/SwapUtility@Methods.F90 @@ -27,6 +28,7 @@ TARGET_SOURCES( ${src_path}/GridPointUtility@Methods.F90 ${src_path}/FunctionalFortranUtility@Methods.F90 ${src_path}/OnesUtility@Methods.F90 + ${src_path}/ZerosUtility@Methods.F90 ${src_path}/EyeUtility@Methods.F90 ${src_path}/DiagUtility@Methods.F90 ${src_path}/AppendUtility@Methods.F90 diff --git a/src/submodules/Utility/src/InvUtility@Methods.F90 b/src/submodules/Utility/src/InvUtility@Methods.F90 index d3a0d9e0e..990624922 100644 --- a/src/submodules/Utility/src/InvUtility@Methods.F90 +++ b/src/submodules/Utility/src/InvUtility@Methods.F90 @@ -17,7 +17,7 @@ !> author: Vikas Sharma, Ph. D. ! date: 3 April 2021 -! summary: Methods for determining determinent and inverse of small matrix +! summary: Methods for determining determinent and inverse of small matrix SUBMODULE(InvUtility) Methods USE BaseMethod diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 new file mode 100644 index 000000000..438cca2f5 --- /dev/null +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -0,0 +1,105 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(MappingUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiunitLine2Segment1 +ans = 0.5_DFP * (x1 + x2) + 0.5_DFP * (x2 - x1) * xin +END PROCEDURE FromBiunitLine2Segment1 + +!---------------------------------------------------------------------------- +! FromBiunitLine2Segment +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiunitLine2Segment2 +INTEGER(I4B) :: ii +DO ii = 1, SIZE(xin) + ans(:, ii) = 0.5_DFP * (x1 + x2) + 0.5_DFP * (x2 - x1) * xin(ii) +END DO +END PROCEDURE FromBiunitLine2Segment2 + +!---------------------------------------------------------------------------- +! FromBiUnitLine2UnitLine +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitLine2UnitLine +ans = 0.5_DFP * (1.0_DFP + xin) +END PROCEDURE FromBiUnitLine2UnitLine + +!---------------------------------------------------------------------------- +! FromUnitLine2BiUnitLine +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitLine2BiUnitLine +ans = 2.0_DFP * xin - 1.0_DFP +END PROCEDURE FromUnitLine2BiUnitLine + +!---------------------------------------------------------------------------- +! FromUnitTriangle2Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTriangle2Triangle1 +INTEGER(I4B) :: ii +DO ii = 1, size(ans, 2) + ans(:, ii) = x1 + (x2 - x1) * xin(1, ii) + (x3 - x1) * xin(2, ii) +END DO +END PROCEDURE FromUnitTriangle2Triangle1 + +!---------------------------------------------------------------------------- +! FromBiUnitTriangle2BiUnitSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitTriangle2BiUnitSqr +ans(1, :) = 2.0_DFP * (1.0_DFP + xin(1, :)) / (1.0_DFP - xin(2, :)) - 1.0_DFP +ans(2, :) = xin(2, :) +END PROCEDURE FromBiUnitTriangle2BiUnitSqr + +!---------------------------------------------------------------------------- +! FromBiUnitSqr2BiUnitTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitSqr2BiUnitTriangle +ans(1, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) * (1.0_DFP - xin(2, :)) & + & - 1.0_DFP +ans(2, :) = xin(2, :) +END PROCEDURE FromBiUnitSqr2BiUnitTriangle + +!---------------------------------------------------------------------------- +! FromUnitTriangle2BiUnitSqr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromUnitTriangle2BiUnitSqr +ans(1, :) = (2.0_DFP * xin(1,:) + xin(2,:) - 1.0_DFP) / (1.0_DFP - xin(2, :)) +ans(2, :) = 2.0_DFP * xin(2, :) - 1.0_DFP +END PROCEDURE FromUnitTriangle2BiUnitSqr + +!---------------------------------------------------------------------------- +! FromBiUnitSqr2UnitTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FromBiUnitSqr2UnitTriangle +ans(1, :) = 0.25_DFP * (1.0_DFP + xin(1, :)) * (1.0_DFP - xin(2, :)) +ans(2, :) = 0.5_DFP * (xin(2, :) + 1.0_DFP) +END PROCEDURE FromBiUnitSqr2UnitTriangle + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ZerosUtility@Methods.F90 b/src/submodules/Utility/src/ZerosUtility@Methods.F90 new file mode 100644 index 000000000..cc9d58616 --- /dev/null +++ b/src/submodules/Utility/src/ZerosUtility@Methods.F90 @@ -0,0 +1,253 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +submodule(ZerosUtility) Methods +implicit none +contains + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_1 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_2 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_3 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_4 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- +#ifdef USE_Int128 +module procedure Zeros_5 +ans = 0 +end procedure +#endif + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_6 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_7 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_8 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_9 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_10 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_11 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +module procedure Zeros_12 +ans = 0 +end procedure +#endif + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_13 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_14 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_15 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_16 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_17 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_18 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +module procedure Zeros_19 +ans = 0 +end procedure +#endif + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_20 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_21 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_22 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_23 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_24 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_25 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +#ifdef USE_Int128 +module procedure Zeros_26 +ans = 0 +end procedure +#endif + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_27 +ans = 0 +end procedure + +!---------------------------------------------------------------------------- +! Zeros +!---------------------------------------------------------------------------- + +module procedure Zeros_28 +ans = 0 +end procedure + +end submodule Methods From 85704e33894c733d205d7b346f2f02a6c61a2522 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 31 Oct 2022 16:58:31 +0900 Subject: [PATCH 42/43] polynomials modified --- .../src/LobattoPolynomialUtility.F90 | 32 ++ .../src/QuadrangleInterpolationUtility.F90 | 31 ++ .../src/TriangleInterpolationUtility.F90 | 352 ++++++++++++++++++ src/modules/Utility/src/MappingUtility.F90 | 34 ++ .../src/LobattoPolynomialUtility@Methods.F90 | 18 + ...QuadrangleInterpolationUtility@Methods.F90 | 9 + .../TriangleInterpolationUtility@Methods.F90 | 349 +++++++++++++++++ .../Utility/src/MappingUtility@Methods.F90 | 20 + 8 files changed, 845 insertions(+) diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 index 51ee1a58d..2473271ab 100644 --- a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 @@ -214,6 +214,38 @@ END FUNCTION LobattoEvalAll2 MODULE PROCEDURE LobattoEvalAll2 END INTERFACE LobattoEvalAll +!---------------------------------------------------------------------------- +! LobattoKernelEvalAll +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 6 Sept 2022 +! summary: Evaluate Lobatto bubble functions order = 2 to n at several points +! +!# Introduction +! +! Evaluate Lobatto bubble polynomials from order = 2 to n at several points +! +!- N, the highest order polynomial to compute. +!- x: the point at which the polynomials are to be evaluated. + +INTERFACE + MODULE PURE FUNCTION LobattoKernelEvalAll1(n, x) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: n + !! n + REAL(DFP), INTENT(IN) :: x(:) + REAL(DFP) :: ans(1:SIZE(x), 0:n ) + !! Evaluate Lobatto polynomial of order = 0 to n (total n+1) + !! at point x + END FUNCTION LobattoKernelEvalAll1 +END INTERFACE + +INTERFACE LobattoKernelEvalAll + MODULE PROCEDURE LobattoKernelEvalAll1 +END INTERFACE LobattoKernelEvalAll + +PUBLIC :: LobattoKernelEvalAll + !---------------------------------------------------------------------------- ! LobattoMonomialExpansionAll !---------------------------------------------------------------------------- diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 5ed3f1082..fbd99ee8c 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -664,4 +664,35 @@ END FUNCTION HeirarchicalBasis_Quadrangle1 PUBLIC :: HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle +! +!# Introduction +! +! This function is identical to `HeirarchicalBasis_Quadrangle1` +! with qe1=qe2=qb=q, and pe3=pe4=pb=p. +! + +INTERFACE + MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle2(p, q, xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! order of interpolation inside the quadrangle in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1)) + !! + END FUNCTION HeirarchicalBasis_Quadrangle2 +END INTERFACE + +INTERFACE HeirarchicalBasis_Quadrangle + MODULE PROCEDURE HeirarchicalBasis_Quadrangle2 +END INTERFACE HeirarchicalBasis_Quadrangle + END MODULE QuadrangleInterpolationUtility diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index 2f6df8821..4faffd533 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -485,6 +485,358 @@ END FUNCTION Dubiner_Triangle2 MODULE PROCEDURE Dubiner_Triangle2 END INTERFACE Dubiner_Triangle +!---------------------------------------------------------------------------- +! BarycentricVertexBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on reference Triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricVertexBasis_Triangle(lambda) & + & RESULT(ans) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentrix coords + REAL(DFP) :: ans(SIZE(lambda, 2), 3) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION BarycentricVertexBasis_Triangle +END INTERFACE + +PUBLIC :: BarycentricVertexBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on edge of triangle +! +!# Introduction +! +! Evaluate basis functions on edges of triangle +! pe1, pe2, pe3 should be greater than or equal to 2 + +INTERFACE + MODULE PURE FUNCTION BarycentricEdgeBasis_Triangle(pe1, pe2, pe3, lambda) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge (e1) + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge (e2) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge (e3) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) + END FUNCTION BarycentricEdgeBasis_Triangle +END INTERFACE + +PUBLIC :: BarycentricEdgeBasis_Triangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 30 Oct 2022 +! summary: Evaluate the edge basis on triangle using barycentric coordinate + +INTERFACE + MODULE PURE FUNCTION BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, & + & lambda, phi) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on edge (e1) + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on edge (e2) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on edge (e3) + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation in terms of barycentric coordinates + !! size(lambda,1) = 3 + !! size(lambda,2) = number of points of evaluation + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 + REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3) + END FUNCTION BarycentricEdgeBasis_Triangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! BarycentricCellBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis in the cell of reference triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricCellBasis_Triangle(order, lambda) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + REAL(DFP), INTENT(IN) :: lambda(:, :) + !! point of evaluation + REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2)) + END FUNCTION BarycentricCellBasis_Triangle +END INTERFACE + +PUBLIC :: BarycentricCellBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Triangle1(order, & + & pe1, pe2, pe3, xij, refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge e1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge e2 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + CHARACTER(LEN=*), INTENT(IN) :: refTriangle + !! reference triangle, "BIUNIT", "UNIT" + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)) + !! + END FUNCTION BarycentricHeirarchicalBasis_Triangle1 +END INTERFACE + +INTERFACE BarycentricHeirarchicalBasis_Triangle + MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle1 +END INTERFACE BarycentricHeirarchicalBasis_Triangle + +PUBLIC :: BarycentricHeirarchicalBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Triangle2(order, xij, & + & refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of approximation on triangle + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + CHARACTER(LEN=*), INTENT(IN) :: refTriangle + !! reference triangle, "BIUNIT", "UNIT" + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & INT((order + 1) * (order + 2) / 2)) + !! + END FUNCTION BarycentricHeirarchicalBasis_Triangle2 +END INTERFACE + +INTERFACE BarycentricHeirarchicalBasis_Triangle + MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle2 +END INTERFACE BarycentricHeirarchicalBasis_Triangle + +!---------------------------------------------------------------------------- +! VertexBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit Triangle + +INTERFACE + MODULE PURE FUNCTION VertexBasis_Triangle(xij, refTriangle) RESULT(ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + CHARACTER(LEN=*), INTENT(IN) :: refTriangle + REAL(DFP) :: ans(SIZE(xij, 2), 3) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Triangle +END INTERFACE + +PUBLIC :: VertexBasis_Triangle + +!---------------------------------------------------------------------------- +! VertexBasis_Triangle2 +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on Triangle + +INTERFACE + MODULE PURE FUNCTION VertexBasis_Triangle2(L1, L2) RESULT(ans) + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(L1, 1), 3) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Triangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! EdgeBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on left, right edge of biunit Triangle +! +!# Introduction +! +! Evaluate basis functions on left and right edge of biunit Triangle +! +! qe1 and qe2 should be greater than or equal to 2 + +INTERFACE + MODULE PURE FUNCTION EdgeBasis_Triangle(pe1, pe2, pe3, xij, refTriangle) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on left vertical edge (e1), should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on right vertical edge(e2), should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on right vertical edge(e3), should be greater than 1 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + CHARACTER(LEN=*), INTENT(IN) :: refTriangle + !! Reference triangle + REAL(DFP) :: ans(SIZE(xij, 2), pe1 + pe2 + pe3 - 3) + END FUNCTION EdgeBasis_Triangle +END INTERFACE + +PUBLIC :: EdgeBasis_Triangle + +!---------------------------------------------------------------------------- +! EdgeBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis on left, right edge of biunit Triangle +! +!# Introduction +! +! Evaluate basis functions on left and right edge of biunit Triangle +! +! qe1 and qe2 should be greater than or equal to 2 + +INTERFACE + MODULE PURE FUNCTION EdgeBasis_Triangle2(pe1, pe2, pe3, L1, L2) & + & RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pe1 + !! order on left vertical edge (e1), should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order on right vertical edge(e2), should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on right vertical edge(e3), should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 - 3) + END FUNCTION EdgeBasis_Triangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! CellBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis in the cell of biunit Triangle +! +!# Introduction +! +! Evaluate basis functions in the cell of biunit Triangle + +INTERFACE + MODULE PURE FUNCTION CellBasis_Triangle(order, xij, refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of approximation inside the cell, order>2 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + CHARACTER(LEN=*), INTENT(IN) :: refTriangle + !! Reference triangle + REAL(DFP) :: ans(SIZE(xij, 2), INT((order - 1) * (order - 2) / 2)) + END FUNCTION CellBasis_Triangle +END INTERFACE + +PUBLIC :: CellBasis_Triangle + +!---------------------------------------------------------------------------- +! CellBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Eval basis in the cell of biunit Triangle +! +!# Introduction +! +! Evaluate basis functions in the cell of biunit Triangle + +INTERFACE + MODULE PURE FUNCTION CellBasis_Triangle2(order, L1, L2, eta_ij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of approximation inside the cell, order>2 + REAL(DFP), INTENT(IN) :: L1(1:, 0:) + !! lobatto polynomials + REAL(DFP), INTENT(IN) :: L2(1:, 0:) + !! lobatto polynomials + REAL(DFP), INTENT(IN) :: eta_ij(:, :) + !! coordinates on biunit square + REAL(DFP) :: ans(SIZE(L1, 1), INT((order - 1) * (order - 2) / 2)) + END FUNCTION CellBasis_Triangle2 +END INTERFACE + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle + +INTERFACE + MODULE PURE FUNCTION HeirarchicalBasis_Triangle1(order, pe1, pe2, pe3,& + & xij, refTriangle) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order in the cell of triangle, it should be greater than 2 + INTEGER(I4B), INTENT(IN) :: pe1 + !! order of interpolation on edge e1 + INTEGER(I4B), INTENT(IN) :: pe2 + !! order of interpolation on edge e2 + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + CHARACTER(LEN=*), INTENT(IN) :: refTriangle + !! reference triangle + REAL(DFP) :: ans( & + & SIZE(xij, 2), & + & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)) + !! + END FUNCTION HeirarchicalBasis_Triangle1 +END INTERFACE + +INTERFACE HeirarchicalBasis_Triangle + MODULE PROCEDURE HeirarchicalBasis_Triangle1 +END INTERFACE HeirarchicalBasis_Triangle + +PUBLIC :: HeirarchicalBasis_Triangle + !---------------------------------------------------------------------------- ! Triangle !---------------------------------------------------------------------------- diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90 index 1c3000466..4fd9db5d7 100644 --- a/src/modules/Utility/src/MappingUtility.F90 +++ b/src/modules/Utility/src/MappingUtility.F90 @@ -259,4 +259,38 @@ END FUNCTION FromBiUnitSqr2UnitTriangle PUBLIC :: FromBiUnitSqr2UnitTriangle +!---------------------------------------------------------------------------- +! BarycentricCoordUnitTriangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns barycentric coord of unit triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricCoordUnitTriangle(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(3, SIZE(xin, 2)) + END FUNCTION BarycentricCoordUnitTriangle +END INTERFACE + +PUBLIC :: BarycentricCoordUnitTriangle + +!---------------------------------------------------------------------------- +! BarycentricCoordBiUnitTriangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns barycentric coord of unit triangle + +INTERFACE + MODULE PURE FUNCTION BarycentricCoordBiUnitTriangle(xin) RESULT(ans) + REAL(DFP), INTENT(IN) :: xin(:, :) + REAL(DFP) :: ans(3, SIZE(xin, 2)) + END FUNCTION BarycentricCoordBiUnitTriangle +END INTERFACE + +PUBLIC :: BarycentricCoordBiUnitTriangle + END MODULE MappingUtility diff --git a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 index e33d5835a..8158c178f 100644 --- a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 @@ -166,6 +166,24 @@ END SELECT END PROCEDURE LobattoEvalAll2 +!---------------------------------------------------------------------------- +! LobattoKernelEvalAll +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LobattoKernelEvalAll1 +REAL(DFP) :: m, avar +INTEGER(I4B) :: ii +!! +ans = UltrasphericalEvalAll(n=n, x=x, lambda=1.5_DFP) +!! +DO ii = 0, n + m = REAL(ii, KIND=DFP) + avar = -SQRT(8.0_DFP*(2.0_DFP*m+3.0_DFP))/(m+1.0_DFP)/(m+2.0_DFP) + ans(:, ii) = avar * ans(:, ii) +END DO +!! +END PROCEDURE LobattoKernelEvalAll1 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 39cfc68d9..7c9751f61 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -643,4 +643,13 @@ END IF END PROCEDURE HeirarchicalBasis_Quadrangle1 +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle2 +ans = HeirarchicalBasis_Quadrangle1(pb=p, pe3=p, pe4=p, & + & qb=q, qe1=q, qe2=q, xij=xij) +END PROCEDURE HeirarchicalBasis_Quadrangle2 + END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 index adf7d3096..6e6ac8d57 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 @@ -598,4 +598,353 @@ END SUBROUTINE IJ2VEFC !! END PROCEDURE Dubiner_Triangle2 +!---------------------------------------------------------------------------- +! BarycentricVertexBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricVertexBasis_Triangle +ans = TRANSPOSE(lambda) +END PROCEDURE BarycentricVertexBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricEdgeBasis_Triangle +REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2)) +REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2)) +INTEGER(I4B) :: maxP, tPoints +!! +tPoints = SIZE(lambda, 2) +maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2) +!! +d_lambda(1:tPoints) = lambda(2, :) - lambda(1, :) +d_lambda(1 + tPoints:2 * tPoints) = lambda(3, :) - lambda(1, :) +d_lambda(1 + 2 * tPoints:3 * tPoints) = lambda(3, :) - lambda(2, :) +phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +!! +ans = BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, & + & lambda=lambda, phi=phi) +!! +END PROCEDURE BarycentricEdgeBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricEdgeBasis_Triangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricEdgeBasis_Triangle2 +INTEGER(I4B) :: tPoints, a, ii +REAL(DFP) :: temp(SIZE(lambda, 2)) +!! +ans = 0.0_DFP +tPoints = SIZE(lambda, 2) +!! +a = 0 +!! +!! edge(1) = (v1, v2) +!! +temp = lambda(1, :) * lambda(2, :) +!! +DO ii = 1, pe1 - 1 + ans(:, a + ii) = temp * phi(1:tPoints, ii - 1) +END DO +!! +!! edge(2) = (v1, v3) +!! +a = pe1 - 1 +temp = lambda(1, :) * lambda(3, :) +!! +DO ii = 1, pe2 - 1 + ans(:, a + ii) = temp & + & * phi(1 + tPoints:2 * tPoints, ii - 1) +END DO +!! +!! edge(3) = (v2, v3) +!! +a = pe1 - 1 + pe2 - 1 +temp = lambda(2, :) * lambda(3, :) +!! +DO ii = 1, pe3 - 1 + ans(:, a + ii) = temp & + & * phi(1 + 2 * tPoints:3 * tPoints, ii - 1) +END DO +!! +END PROCEDURE BarycentricEdgeBasis_Triangle2 + +!---------------------------------------------------------------------------- +! BarycentricCellBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCellBasis_Triangle +INTEGER(I4B) :: k1, k2, cnt +!! +cnt = 0 +!! +DO k1 = 1, order - 2 + DO k2 = 1, order - 1 - k1 + cnt = cnt + 1 + ans(:, cnt) = (lambda(1, :)**k1) * (lambda(2, :)**k2) * lambda(3, :) + END DO +END DO +!! +END PROCEDURE BarycentricCellBasis_Triangle + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle1 +CHARACTER(LEN=20) :: layout +REAL(DFP) :: lambda(3, SIZE(xij, 2)) +INTEGER(I4B) :: a, b +!! +layout = TRIM(UpperCase(refTriangle)) +!! +IF (layout .EQ. "BIUNIT") THEN + lambda = BarycentricCoordBiUnitTriangle(xin=xij) +ELSE + lambda = BarycentricCoordUnitTriangle(xin=xij) +END IF +!! +!! Vertex basis function +!! +ans = 0.0_DFP +ans(:, 1:3) = BarycentricVertexBasis_Triangle(lambda=lambda) +!! +!! Edge basis function +!! +b = 3 +!! +IF (pe1 .GE. 2_I4B .OR. pe2 .GE. 2_I4B .OR. pe3 .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 + ans(:, a:b) = BarycentricEdgeBasis_Triangle( & + & pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda) +END IF +!! +!! Cell basis function +!! +IF (order .GT. 2_I4B) THEN + a = b + 1 + b = a - 1 + INT((order - 1) * (order - 2) / 2) + ans(:, a:b) = BarycentricCellBasis_Triangle(order=order, lambda=lambda) +END IF +!! +END PROCEDURE BarycentricHeirarchicalBasis_Triangle1 + +!---------------------------------------------------------------------------- +! BarycentricHeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle2 +ans = BarycentricHeirarchicalBasis_Triangle1(order=order, pe1=order, & + & pe2=order, pe3=order, xij=xij, refTriangle=refTriangle) +END PROCEDURE BarycentricHeirarchicalBasis_Triangle2 + +!---------------------------------------------------------------------------- +! VertexBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Triangle +CHARACTER(LEN=20) :: layout +REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) +REAL(DFP), PARAMETER :: one = 1.0_DFP, pt5 = 0.5_DFP +!! +layout = TRIM(UpperCase(refTriangle)) +!! +SELECT CASE (TRIM(layout)) +CASE ("BIUNIT") + x = FromBiUnitTriangle2BiUnitSqr(xin=xij) +CASE ("UNIT") + x = FromUnitTriangle2BiUnitSqr(xin=xij) +END SELECT +!! +ans(:, 1) = pt5 * pt5 * (one - x(1, :)) * (one - x(2, :)) +ans(:, 2) = pt5 * pt5 * (one + x(1, :)) * (one - x(2, :)) +ans(:, 3) = pt5 * (one + x(2, :)) +!! +END PROCEDURE VertexBasis_Triangle + +!---------------------------------------------------------------------------- +! VertexBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Triangle2 +ans(:, 1) = L1(:, 0) * L2(:, 0) +ans(:, 2) = L1(:, 1) * L2(:, 0) +ans(:, 3) = L2(:, 1) +END PROCEDURE VertexBasis_Triangle2 + +!---------------------------------------------------------------------------- +! EdgeBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeBasis_Triangle +CHARACTER(LEN=20) :: layout +REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) +REAL(DFP) :: L1(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3)) +REAL(DFP) :: L2(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3)) +INTEGER(I4B) :: maxP +!! +layout = TRIM(UpperCase(refTriangle)) +!! +SELECT CASE (TRIM(layout)) +CASE ("BIUNIT") + x = FromBiUnitTriangle2BiUnitSqr(xin=xij) +CASE ("UNIT") + x = FromUnitTriangle2BiUnitSqr(xin=xij) +END SELECT +!! +maxP = MAX(pe1, pe2, pe3) +L1 = LobattoEvalAll(n=maxP, x=x(1, :)) +L2 = LobattoEvalAll(n=maxP, x=x(2, :)) +!! +ans = EdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, L1=L1, L2=L2) +!! +END PROCEDURE EdgeBasis_Triangle + +!---------------------------------------------------------------------------- +! EdgeBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EdgeBasis_Triangle2 +CHARACTER(LEN=20) :: layout +INTEGER(I4B) :: maxP, k1, k2, a +!! +maxP = MAX(pe1, pe2, pe3) +!! +!! edge(1) +!! +a = 0 +!! +DO k1 = 2, pe1 + ans(:, k1 - 1) = L1(:, k1) * (L2(:, 0)**k1) +END DO +!! +!! edge(2) +!! +a = pe1 - 1 +DO k2 = 2, pe2 + ans(:, a + k2 - 1) = L1(:, 0) * L2(:, k2) +END DO +!! +!! edge(3) +!! +a = pe1 - 1 + pe2 - 1 +DO k2 = 2, pe2 + ans(:, a + k2 - 1) = L1(:, 1) * L2(:, k2) +END DO +!! +END PROCEDURE EdgeBasis_Triangle2 + +!---------------------------------------------------------------------------- +! CellBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Triangle +CHARACTER(LEN=20) :: layout +REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) +REAL(DFP) :: L1(SIZE(xij, 2), 0:order) +REAL(DFP) :: L2(SIZE(xij, 2), 0:1) +!! +layout = TRIM(UpperCase(refTriangle)) +!! +SELECT CASE (TRIM(layout)) +CASE ("BIUNIT") + x = FromBiUnitTriangle2BiUnitSqr(xin=xij) +CASE ("UNIT") + x = FromUnitTriangle2BiUnitSqr(xin=xij) +END SELECT +!! +L1 = LobattoEvalAll(n=order, x=x(1, :)) +L2 = LobattoEvalAll(n=1_I4B, x=x(2, :)) +!! +ans = CellBasis_Triangle2(order=order, L1=L1, L2=L2, eta_ij=x) +!! +END PROCEDURE CellBasis_Triangle + +!---------------------------------------------------------------------------- +! CellBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Triangle2 +REAL(DFP) :: P2(SIZE(eta_ij, 2), 0:order) +REAL(DFP) :: avec(SIZE(eta_ij, 2)), alpha, beta +INTEGER(I4B) :: k1, k2, max_k2, cnt +!! +alpha = 0.0_DFP +beta = 1.0_DFP +cnt = 0 +!! +DO k1 = 2, order + !! + avec = (L2(:, 0)**k1) * L2(:, 1) + alpha = 2.0_DFP * k1 - 1.0_DFP + ! + max_k2 = MAX(order - k1 - 1, 0) + !! + P2(:, 0:max_k2) = JacobiEvalAll(n=max_k2, x=eta_ij(2, :), & + & alpha=alpha, beta=beta) + !! + DO k2 = 2, order + 1 - k1 + cnt = cnt + 1 + ans(:, cnt) = L1(:, k1) * avec * P2(:, k2 - 2) + END DO + !! +END DO + +END PROCEDURE CellBasis_Triangle2 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Triangle1 +CHARACTER(LEN=20) :: layout +REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) +REAL(DFP) :: L1(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order)) +REAL(DFP) :: L2(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order)) +INTEGER(I4B) :: maxP, a, b +!! +layout = TRIM(UpperCase(refTriangle)) +!! +IF (layout .EQ. "BIUNIT") THEN + x = FromBiUnitTriangle2BiUnitSqr(xin=xij) +ELSE + x = FromUnitTriangle2BiUnitSqr(xin=xij) +END IF +!! +maxP = MAX(pe1, pe2, pe3, order) +L1 = LobattoEvalAll(n=maxP, x=x(1, :)) +L2 = LobattoEvalAll(n=maxP, x=x(2, :)) +!! +!! Vertex basis function +!! +ans = 0.0_DFP +ans(:, 1:3) = VertexBasis_Triangle2(L1=L1, L2=L2) +!! +!! Edge basis function +!! +b = 3 +!! +IF (pe1 .GE. 2_I4B .OR. pe2 .GE. 2_I4B .OR. pe3 .GE. 2_I4B) THEN + a = b + 1 + b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 + ans(:, a:b) = EdgeBasis_Triangle2( & + & pe1=pe1, pe2=pe2, pe3=pe3, L1=L1, L2=L2) +END IF +!! +!! Cell basis function +!! +IF (order .GT. 2_I4B) THEN + a = b + 1 + b = a - 1 + INT((order - 1) * (order - 2) / 2) + ans(:, a:b) = CellBasis_Triangle2(order=order, L1=L1, L2=L2, eta_ij=x) +END IF +!! +END PROCEDURE HeirarchicalBasis_Triangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- END SUBMODULE Methods diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90 index 438cca2f5..f0212ffd3 100644 --- a/src/submodules/Utility/src/MappingUtility@Methods.F90 +++ b/src/submodules/Utility/src/MappingUtility@Methods.F90 @@ -102,4 +102,24 @@ ans(2, :) = 0.5_DFP * (xin(2, :) + 1.0_DFP) END PROCEDURE FromBiUnitSqr2UnitTriangle +!---------------------------------------------------------------------------- +! BarycentricCoordUnitTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordUnitTriangle +ans(1, :) = 1.0_DFP - xin(1, :) - xin(2, :) +ans(2, :) = xin(1, :) +ans(3, :) = xin(2, :) +END PROCEDURE BarycentricCoordUnitTriangle + +!---------------------------------------------------------------------------- +! BarycentricCoordBiUnitTriangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BarycentricCoordBiUnitTriangle +ans(1, :) = -0.5_DFP * (xin(1, :) + xin(2, :)) +ans(2, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) +ans(3, :) = 0.5_DFP * (1.0_DFP + xin(2, :)) +END PROCEDURE BarycentricCoordBiUnitTriangle + END SUBMODULE Methods From 1bfe579cc9ea2a6565a2fdec425068bbc4c2e076 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 31 Oct 2022 21:12:53 +0900 Subject: [PATCH 43/43] TriangleInterpolation --- .../src/TriangleInterpolationUtility.F90 | 39 +++--- .../TriangleInterpolationUtility@Methods.F90 | 118 ++++++++++++------ 2 files changed, 107 insertions(+), 50 deletions(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index 4faffd533..d2e64a897 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -574,18 +574,21 @@ END FUNCTION BarycentricEdgeBasis_Triangle2 ! summary: Eval basis in the cell of reference triangle INTERFACE - MODULE PURE FUNCTION BarycentricCellBasis_Triangle(order, lambda) & + MODULE PURE FUNCTION BarycentricCellBasis_Triangle2(order, lambda, phi) & & RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order in the cell of triangle, it should be greater than 2 REAL(DFP), INTENT(IN) :: lambda(:, :) !! point of evaluation + REAL(DFP), INTENT(IN) :: phi(1:, 0:) + !! lobatto kernel values + !! size(phi1, 1) = 3*number of points (lambda2-lambda1), + !! (lambda3-lambda1), (lambda3-lambda2) + !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1 REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2)) - END FUNCTION BarycentricCellBasis_Triangle + END FUNCTION BarycentricCellBasis_Triangle2 END INTERFACE -PUBLIC :: BarycentricCellBasis_Triangle - !---------------------------------------------------------------------------- ! BarycentricHeirarchicalBasis_Triangle !---------------------------------------------------------------------------- @@ -679,10 +682,11 @@ END FUNCTION VertexBasis_Triangle ! summary: Returns the vertex basis functions on Triangle INTERFACE - MODULE PURE FUNCTION VertexBasis_Triangle2(L1, L2) RESULT(ans) - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP) :: ans(SIZE(L1, 1), 3) + MODULE PURE FUNCTION VertexBasis_Triangle2(Lo1, Lo2) RESULT(ans) + REAL(DFP), INTENT(IN) :: Lo1(1:, 0:) + REAL(DFP), INTENT(IN) :: Lo2(1:, 0:) + !! coordinates on biunit square + REAL(DFP) :: ans(SIZE(Lo1, 1), 3) !! ans(:,v1) basis function of vertex v1 at all points END FUNCTION VertexBasis_Triangle2 END INTERFACE @@ -735,8 +739,8 @@ END FUNCTION EdgeBasis_Triangle ! qe1 and qe2 should be greater than or equal to 2 INTERFACE - MODULE PURE FUNCTION EdgeBasis_Triangle2(pe1, pe2, pe3, L1, L2) & - & RESULT(ans) + MODULE PURE FUNCTION EdgeBasis_Triangle2(pe1, pe2, pe3, L1, L2, Lo1, & + & Lo2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: pe1 !! order on left vertical edge (e1), should be greater than 1 INTEGER(I4B), INTENT(IN) :: pe2 @@ -744,7 +748,11 @@ MODULE PURE FUNCTION EdgeBasis_Triangle2(pe1, pe2, pe3, L1, L2) & INTEGER(I4B), INTENT(IN) :: pe3 !! order on right vertical edge(e3), should be greater than 1 REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation + !! L1 and L2 are jacobian polynomials + REAL(DFP), INTENT(IN) :: Lo1(1:, 0:) + !! coordinates on biunit square domain + REAL(DFP), INTENT(IN) :: Lo2(1:, 0:) + !! coordinates on biunit square domain REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 - 3) END FUNCTION EdgeBasis_Triangle2 END INTERFACE @@ -788,15 +796,18 @@ END FUNCTION CellBasis_Triangle ! Evaluate basis functions in the cell of biunit Triangle INTERFACE - MODULE PURE FUNCTION CellBasis_Triangle2(order, L1, L2, eta_ij) RESULT(ans) + MODULE PURE FUNCTION CellBasis_Triangle2(order, L1, eta_ij, & + & Lo1, Lo2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of approximation inside the cell, order>2 REAL(DFP), INTENT(IN) :: L1(1:, 0:) !! lobatto polynomials - REAL(DFP), INTENT(IN) :: L2(1:, 0:) - !! lobatto polynomials REAL(DFP), INTENT(IN) :: eta_ij(:, :) !! coordinates on biunit square + REAL(DFP), INTENT(IN) :: Lo1(1:, 0:) + !! coordinates on biunit square domain + REAL(DFP), INTENT(IN) :: Lo2(1:, 0:) + !! coordinates on biunit square domain REAL(DFP) :: ans(SIZE(L1, 1), INT((order - 1) * (order - 2) / 2)) END FUNCTION CellBasis_Triangle2 END INTERFACE diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 index 6e6ac8d57..541673770 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 @@ -675,19 +675,23 @@ END SUBROUTINE IJ2VEFC ! BarycentricCellBasis_Triangle !---------------------------------------------------------------------------- -MODULE PROCEDURE BarycentricCellBasis_Triangle -INTEGER(I4B) :: k1, k2, cnt +MODULE PROCEDURE BarycentricCellBasis_Triangle2 +INTEGER(I4B) :: tPoints, k1, k2, cnt +REAL(DFP) :: temp(SIZE(lambda, 2)) !! +tPoints = SIZE(lambda, 2) +temp = lambda(1, :) * lambda(2, :) * lambda(3, :) cnt = 0 !! DO k1 = 1, order - 2 DO k2 = 1, order - 1 - k1 cnt = cnt + 1 - ans(:, cnt) = (lambda(1, :)**k1) * (lambda(2, :)**k2) * lambda(3, :) + ans(:, cnt) = temp * phi(1:tPoints, k1 - 1) * & + & phi(1 + tPoints:2 * tPoints, k2 - 1) END DO END DO !! -END PROCEDURE BarycentricCellBasis_Triangle +END PROCEDURE BarycentricCellBasis_Triangle2 !---------------------------------------------------------------------------- ! BarycentricHeirarchicalBasis_Triangle @@ -697,6 +701,10 @@ END SUBROUTINE IJ2VEFC CHARACTER(LEN=20) :: layout REAL(DFP) :: lambda(3, SIZE(xij, 2)) INTEGER(I4B) :: a, b +INTEGER(I4B) :: maxP, tPoints +REAL(DFP) :: phi(1:3 * SIZE(xij, 2), & + & 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2)) +REAL(DFP) :: d_lambda(3 * SIZE(xij, 2)) !! layout = TRIM(UpperCase(refTriangle)) !! @@ -706,6 +714,13 @@ END SUBROUTINE IJ2VEFC lambda = BarycentricCoordUnitTriangle(xin=xij) END IF !! +tPoints = SIZE(lambda, 2) +maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2) +d_lambda(1:tPoints) = lambda(2, :) - lambda(1, :) +d_lambda(1 + tPoints:2 * tPoints) = lambda(3, :) - lambda(1, :) +d_lambda(1 + 2 * tPoints:3 * tPoints) = lambda(3, :) - lambda(2, :) +phi = LobattoKernelEvalAll(n=maxP, x=d_lambda) +!! !! Vertex basis function !! ans = 0.0_DFP @@ -718,8 +733,8 @@ END SUBROUTINE IJ2VEFC IF (pe1 .GE. 2_I4B .OR. pe2 .GE. 2_I4B .OR. pe3 .GE. 2_I4B) THEN a = b + 1 b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 - ans(:, a:b) = BarycentricEdgeBasis_Triangle( & - & pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda) + ans(:, a:b) = BarycentricEdgeBasis_Triangle2( & + & pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda, phi=phi) END IF !! !! Cell basis function @@ -727,7 +742,8 @@ END SUBROUTINE IJ2VEFC IF (order .GT. 2_I4B) THEN a = b + 1 b = a - 1 + INT((order - 1) * (order - 2) / 2) - ans(:, a:b) = BarycentricCellBasis_Triangle(order=order, lambda=lambda) + ans(:, a:b) = BarycentricCellBasis_Triangle2(order=order, & + & lambda=lambda, phi=phi) END IF !! END PROCEDURE BarycentricHeirarchicalBasis_Triangle1 @@ -748,7 +764,8 @@ END SUBROUTINE IJ2VEFC MODULE PROCEDURE VertexBasis_Triangle CHARACTER(LEN=20) :: layout REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) -REAL(DFP), PARAMETER :: one = 1.0_DFP, pt5 = 0.5_DFP +REAL(DFP) :: Lo1(SIZE(xij, 2), 0:1) +REAL(DFP) :: Lo2(SIZE(xij, 2), 0:1) !! layout = TRIM(UpperCase(refTriangle)) !! @@ -759,9 +776,12 @@ END SUBROUTINE IJ2VEFC x = FromUnitTriangle2BiUnitSqr(xin=xij) END SELECT !! -ans(:, 1) = pt5 * pt5 * (one - x(1, :)) * (one - x(2, :)) -ans(:, 2) = pt5 * pt5 * (one + x(1, :)) * (one - x(2, :)) -ans(:, 3) = pt5 * (one + x(2, :)) +Lo1(:, 0) = 0.5_DFP * (1.0 - x(1, :)) +Lo1(:, 1) = 0.5_DFP * (1.0 + x(1, :)) +Lo2(:, 0) = 0.5_DFP * (1.0 - x(2, :)) +Lo2(:, 1) = 0.5_DFP * (1.0 + x(2, :)) +!! +ans = VertexBasis_Triangle2(Lo1=Lo1, Lo2=Lo2) !! END PROCEDURE VertexBasis_Triangle @@ -770,9 +790,9 @@ END SUBROUTINE IJ2VEFC !---------------------------------------------------------------------------- MODULE PROCEDURE VertexBasis_Triangle2 -ans(:, 1) = L1(:, 0) * L2(:, 0) -ans(:, 2) = L1(:, 1) * L2(:, 0) -ans(:, 3) = L2(:, 1) +ans(:, 1) = Lo1(:, 0) * Lo2(:, 0) +ans(:, 2) = Lo1(:, 1) * Lo2(:, 0) +ans(:, 3) = Lo1(:, 1) * Lo2(:, 1) + Lo1(:, 0) * Lo2(:, 1) END PROCEDURE VertexBasis_Triangle2 !---------------------------------------------------------------------------- @@ -784,6 +804,8 @@ END SUBROUTINE IJ2VEFC REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) REAL(DFP) :: L1(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3)) REAL(DFP) :: L2(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3)) +REAL(DFP) :: Lo1(SIZE(xij, 2), 0:1) +REAL(DFP) :: Lo2(SIZE(xij, 2), 0:1) INTEGER(I4B) :: maxP !! layout = TRIM(UpperCase(refTriangle)) @@ -796,10 +818,16 @@ END SUBROUTINE IJ2VEFC END SELECT !! maxP = MAX(pe1, pe2, pe3) -L1 = LobattoEvalAll(n=maxP, x=x(1, :)) -L2 = LobattoEvalAll(n=maxP, x=x(2, :)) +L1 = JacobiEvalAll(n=maxP, x=x(1, :), alpha=1.0_DFP, beta=1.0_DFP) +L2 = JacobiEvalAll(n=maxP, x=x(2, :), alpha=1.0_DFP, beta=1.0_DFP) !! -ans = EdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, L1=L1, L2=L2) +Lo1(:, 0) = 0.5_DFP * (1.0 - x(1, :)) +Lo1(:, 1) = 0.5_DFP * (1.0 + x(1, :)) +Lo2(:, 0) = 0.5_DFP * (1.0 - x(2, :)) +Lo2(:, 1) = 0.5_DFP * (1.0 + x(2, :)) +!! +ans = EdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, L1=L1, L2=L2, & + & Lo1=Lo1, Lo2=Lo2) !! END PROCEDURE EdgeBasis_Triangle @@ -818,21 +846,24 @@ END SUBROUTINE IJ2VEFC a = 0 !! DO k1 = 2, pe1 - ans(:, k1 - 1) = L1(:, k1) * (L2(:, 0)**k1) + ! ans(:, k1 - 1) = L1(:, k1) * (L2(:, 0)**k1) + ans(:, k1 - 1) = Lo1(:, 0) * Lo1(:, 1) * L1(:, k1 - 2) * (Lo2(:, 0)**k1) END DO !! !! edge(2) !! a = pe1 - 1 DO k2 = 2, pe2 - ans(:, a + k2 - 1) = L1(:, 0) * L2(:, k2) + ! ans(:, a + k2 - 1) = L1(:, 0) * L2(:, k2) + ans(:, a + k2 - 1) = Lo1(:, 0) * Lo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2) END DO !! !! edge(3) !! a = pe1 - 1 + pe2 - 1 -DO k2 = 2, pe2 - ans(:, a + k2 - 1) = L1(:, 1) * L2(:, k2) +DO k2 = 2, pe3 + ! ans(:, a + k2 - 1) = L1(:, 1) * L2(:, k2) + ans(:, a + k2 - 1) = Lo1(:, 1) * Lo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2) END DO !! END PROCEDURE EdgeBasis_Triangle2 @@ -845,7 +876,8 @@ END SUBROUTINE IJ2VEFC CHARACTER(LEN=20) :: layout REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) REAL(DFP) :: L1(SIZE(xij, 2), 0:order) -REAL(DFP) :: L2(SIZE(xij, 2), 0:1) +REAL(DFP) :: Lo1(SIZE(xij, 2), 0:1) +REAL(DFP) :: Lo2(SIZE(xij, 2), 0:1) !! layout = TRIM(UpperCase(refTriangle)) !! @@ -856,10 +888,14 @@ END SUBROUTINE IJ2VEFC x = FromUnitTriangle2BiUnitSqr(xin=xij) END SELECT !! -L1 = LobattoEvalAll(n=order, x=x(1, :)) -L2 = LobattoEvalAll(n=1_I4B, x=x(2, :)) +Lo1(:, 0) = 0.5_DFP * (1.0 - x(1, :)) +Lo1(:, 1) = 0.5_DFP * (1.0 + x(1, :)) +Lo2(:, 0) = 0.5_DFP * (1.0 - x(2, :)) +Lo2(:, 1) = 0.5_DFP * (1.0 + x(2, :)) +L1 = JacobiEvalAll(n=order, x=x(1, :), alpha=1.0_DFP, beta=1.0_DFP) !! -ans = CellBasis_Triangle2(order=order, L1=L1, L2=L2, eta_ij=x) +ans = CellBasis_Triangle2(order=order, L1=L1, Lo1=Lo1, & + & Lo2=Lo2, eta_ij=x) !! END PROCEDURE CellBasis_Triangle @@ -876,9 +912,10 @@ END SUBROUTINE IJ2VEFC beta = 1.0_DFP cnt = 0 !! -DO k1 = 2, order +DO k1 = 2, order - 1 + !! + avec = (Lo2(:, 0)**k1) * Lo2(:, 1) * Lo1(:, 0) * Lo1(:, 1) !! - avec = (L2(:, 0)**k1) * L2(:, 1) alpha = 2.0_DFP * k1 - 1.0_DFP ! max_k2 = MAX(order - k1 - 1, 0) @@ -886,9 +923,9 @@ END SUBROUTINE IJ2VEFC P2(:, 0:max_k2) = JacobiEvalAll(n=max_k2, x=eta_ij(2, :), & & alpha=alpha, beta=beta) !! - DO k2 = 2, order + 1 - k1 + DO k2 = 2, order - k1 + 1 cnt = cnt + 1 - ans(:, cnt) = L1(:, k1) * avec * P2(:, k2 - 2) + ans(:, cnt) = L1(:, k1 - 2) * avec * P2(:, k2 - 2) END DO !! END DO @@ -904,7 +941,9 @@ END SUBROUTINE IJ2VEFC REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) REAL(DFP) :: L1(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order)) REAL(DFP) :: L2(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order)) -INTEGER(I4B) :: maxP, a, b +REAL(DFP) :: Lo1(SIZE(xij, 2), 0:1) +REAL(DFP) :: Lo2(SIZE(xij, 2), 0:1) +INTEGER(I4B) :: maxP, a, b, ii !! layout = TRIM(UpperCase(refTriangle)) !! @@ -914,14 +953,19 @@ END SUBROUTINE IJ2VEFC x = FromUnitTriangle2BiUnitSqr(xin=xij) END IF !! -maxP = MAX(pe1, pe2, pe3, order) -L1 = LobattoEvalAll(n=maxP, x=x(1, :)) -L2 = LobattoEvalAll(n=maxP, x=x(2, :)) +Lo1(:, 0) = 0.5_DFP * (1.0 - x(1, :)) +Lo1(:, 1) = 0.5_DFP * (1.0 + x(1, :)) +Lo2(:, 0) = 0.5_DFP * (1.0 - x(2, :)) +Lo2(:, 1) = 0.5_DFP * (1.0 + x(2, :)) !! !! Vertex basis function !! ans = 0.0_DFP -ans(:, 1:3) = VertexBasis_Triangle2(L1=L1, L2=L2) +ans(:, 1:3) = VertexBasis_Triangle2(Lo1=Lo1, Lo2=Lo2) +!! +maxP = MAX(pe1, pe2, pe3, order) +L1 = JacobiEvalAll(n=maxP, x=x(1, :), alpha=1.0_DFP, beta=1.0_DFP) +L2 = JacobiEvalAll(n=maxP, x=x(2, :), alpha=1.0_DFP, beta=1.0_DFP) !! !! Edge basis function !! @@ -931,7 +975,8 @@ END SUBROUTINE IJ2VEFC a = b + 1 b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 ans(:, a:b) = EdgeBasis_Triangle2( & - & pe1=pe1, pe2=pe2, pe3=pe3, L1=L1, L2=L2) + & pe1=pe1, pe2=pe2, pe3=pe3, L1=L1, L2=L2, Lo1=Lo1, & + & Lo2=Lo2) END IF !! !! Cell basis function @@ -939,7 +984,8 @@ END SUBROUTINE IJ2VEFC IF (order .GT. 2_I4B) THEN a = b + 1 b = a - 1 + INT((order - 1) * (order - 2) / 2) - ans(:, a:b) = CellBasis_Triangle2(order=order, L1=L1, L2=L2, eta_ij=x) + ans(:, a:b) = CellBasis_Triangle2(order=order, L1=L1, & + & Lo1=Lo1, Lo2=Lo2, eta_ij=x) END IF !! END PROCEDURE HeirarchicalBasis_Triangle1